diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,31 @@
+Copyright (c) 2013, Henning Thielemann
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * The names of contributors may not be used to endorse or promote
+      products derived from this software without specific prior
+      written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,3 @@
+#! /usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
diff --git a/reactive-midyim.cabal b/reactive-midyim.cabal
new file mode 100644
--- /dev/null
+++ b/reactive-midyim.cabal
@@ -0,0 +1,82 @@
+Name:             reactive-midyim
+Version:          0.2
+License:          BSD3
+License-File:     LICENSE
+Author:           Henning Thielemann <haskell@henning-thielemann.de>
+Maintainer:       Henning Thielemann <haskell@henning-thielemann.de>
+Homepage:         http://www.haskell.org/haskellwiki/Reactive-balsa
+Category:         Sound, Music
+Build-Type:       Simple
+Synopsis:         Process MIDI events via reactive-banana
+Description:
+   MIDI is the Musical Instrument Digital Interface,
+   ALSA is the Advanced Linux Sound Architecture.
+   This package allows to manipulate a sequence of MIDI events via ALSA.
+   It is intended to be plugged as a playing assistant
+   between a MIDI input device
+   (e.g. a keyboard or a controller bank)
+   and a MIDI controlled synthesizer
+   (e.g. a software synthesizer or an external synthesizer).
+   For software synthesizers see the Haskell packages
+   @synthesizer-alsa@, @synthesizer-llvm@, @supercollider-midi@,
+   @hsc3@, @YampaSynth@
+   or the C packages @fluidsynth@ and @Timidity@.
+   .
+   Applications include:
+   Remapping of channels, controller, instruments, keys,
+   Keyboard splitting, Conversion from notes to controllers, Latch mode,
+   Convert parallel chords to serial patterns,
+   Automated change of MIDI controllers,
+   Delay and echo.
+   .
+   It is intended that you write programs for MIDI stream manipulation.
+   It is not intended to provide an executable program
+   with all the functionality available
+   in a custom programming interface.
+   It is most fun to play with the stream editors in GHCi.
+   However we provide an example module that demonstrates various effects.
+Tested-With:      GHC==7.4.1
+Cabal-Version:    >=1.6
+Build-Type:       Simple
+Source-Repository head
+  type:     darcs
+  location: http://hub.darcs.net/thielema/reactive-midyim/
+
+Source-Repository this
+  type:     darcs
+  location: http://hub.darcs.net/thielema/reactive-midyim/
+  tag:      0.2
+
+Library
+  Build-Depends:
+    reactive-banana >=0.7 && <0.8,
+    midi >=0.2 && <0.3,
+    event-list >=0.1 && < 0.2,
+    non-negative >=0.1 && <0.2,
+    data-accessor-transformers >=0.2.1 && <0.3,
+    data-accessor >=0.2.1 && <0.3,
+    utility-ht >=0.0.5 && <0.1,
+    containers >=0.2 && <0.6,
+    transformers >=0.2 && <0.6,
+    random >=1 && <2,
+    base >=4 && <5
+
+  GHC-Options:      -Wall
+  Hs-Source-Dirs:   src
+  Exposed-Modules:
+    Reactive.Banana.MIDI.KeySet
+    Reactive.Banana.MIDI.Pattern
+    Reactive.Banana.MIDI.Guitar
+    Reactive.Banana.MIDI.Training
+    Reactive.Banana.MIDI.Common
+    Reactive.Banana.MIDI.Utility
+    Reactive.Banana.MIDI.Process
+    Reactive.Banana.MIDI.Pitch
+    Reactive.Banana.MIDI.Note
+    Reactive.Banana.MIDI.Time
+    Reactive.Banana.MIDI.IndexedMonad
+    Reactive.Banana.MIDI.Program
+    Reactive.Banana.MIDI.Controller
+  Other-Modules:
+    Reactive.Banana.MIDI.DeBruijn
+    Reactive.Banana.MIDI.Trie
diff --git a/src/Reactive/Banana/MIDI/Common.hs b/src/Reactive/Banana/MIDI/Common.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/MIDI/Common.hs
@@ -0,0 +1,117 @@
+module Reactive.Banana.MIDI.Common where
+
+import qualified Reactive.Banana.MIDI.Time as Time
+
+import qualified Sound.MIDI.Message.Channel as ChannelMsg
+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
+
+import Sound.MIDI.Message.Channel (Channel, )
+import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, Controller, Program, )
+
+import qualified Data.EventList.Relative.TimeBody as EventList
+import qualified Numeric.NonNegative.Class as NonNeg
+
+import Data.Monoid (mempty, )
+
+
+
+-- * Constructors
+
+channel :: Int -> Channel
+channel = ChannelMsg.toChannel
+
+pitch :: Int -> Pitch
+pitch = VoiceMsg.toPitch
+
+velocity :: Int -> Velocity
+velocity = VoiceMsg.toVelocity
+
+controller :: Int -> Controller
+controller = VoiceMsg.toController
+
+program :: Int -> Program
+program = VoiceMsg.toProgram
+
+
+normalVelocity :: Velocity
+normalVelocity = VoiceMsg.normalVelocity
+
+
+
+-- * Fractions
+
+-- | properFraction is useless for negative numbers
+splitFraction :: (RealFrac a) => a -> (Int, a)
+splitFraction x =
+   case floor x of
+      n -> (n, x - fromIntegral n)
+
+
+fraction :: RealFrac a => a -> a
+fraction x =
+   x - fromIntegral (floor x :: Integer)
+
+
+-- * Notes
+
+{-
+The Ord instance is intended for use in a Map,
+but it shall not express a notion of magnitude.
+-}
+data PitchChannel =
+     PitchChannel Pitch Channel
+   deriving (Eq, Ord, Show)
+
+data PitchChannelVelocity =
+     PitchChannelVelocity PitchChannel Velocity
+   deriving (Eq, Show)
+
+
+class VelocityField x where
+   getVelocity :: x -> Velocity
+
+instance VelocityField Velocity where
+   getVelocity = id
+
+
+
+-- * time stamped objects
+
+{- |
+The times are relative to the start time of the bundle
+and do not need to be ordered.
+-}
+data Future m a = Future {futureTime :: Time.T m Time.Relative Time.Ticks, futureData :: a}
+type Bundle m a = [Future m a]
+
+singletonBundle :: a -> Bundle m a
+singletonBundle ev = [now ev]
+
+immediateBundle :: [a] -> Bundle m a
+immediateBundle = map now
+
+now :: a -> Future m a
+now = Future mempty
+
+instance Functor (Future m) where
+   fmap f (Future dt a) = Future dt $ f a
+
+
+
+-- * event list support
+
+mergeStable ::
+   (NonNeg.C time) =>
+   EventList.T time body ->
+   EventList.T time body ->
+   EventList.T time body
+mergeStable =
+   EventList.mergeBy (\_ _ -> True)
+
+mergeEither ::
+   (NonNeg.C time) =>
+   EventList.T time a ->
+   EventList.T time b ->
+   EventList.T time (Either a b)
+mergeEither xs ys =
+   mergeStable (fmap Left xs) (fmap Right ys)
diff --git a/src/Reactive/Banana/MIDI/Controller.hs b/src/Reactive/Banana/MIDI/Controller.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/MIDI/Controller.hs
@@ -0,0 +1,65 @@
+module Reactive.Banana.MIDI.Controller where
+
+import qualified Reactive.Banana.MIDI.Time as Time
+
+import qualified Sound.MIDI.Message.Class.Query as Query
+import qualified Sound.MIDI.Message.Class.Construct as Construct
+import qualified Sound.MIDI.Message.Channel as ChannelMsg
+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
+
+import Sound.MIDI.Message.Channel (Channel, )
+import Sound.MIDI.Message.Channel.Voice (Controller, )
+
+import Data.Maybe.HT (toMaybe, )
+import Data.Monoid (mappend, )
+
+
+tempoDefault :: (Channel, Controller)
+tempoDefault =
+   (ChannelMsg.toChannel 0, VoiceMsg.toController 16)
+
+
+type RelativeTickTime m = Time.T m Time.Relative Time.Ticks
+
+duration, durationLinear, durationExponential ::
+   (RelativeTickTime m, RelativeTickTime m) ->
+   Int -> RelativeTickTime m
+duration = durationExponential
+
+durationLinear (minDur, maxDur) val =
+   let k = fromIntegral val / 127
+   in  Time.scale (1-k) minDur
+       `mappend`
+       Time.scale k maxDur
+--   minDur + Time.scale (fromIntegral val / 127) (maxDur-minDur)
+
+durationExponential (minDur, maxDur) val =
+   Time.scale (Time.div maxDur minDur ** (fromIntegral val / 127)) minDur
+
+
+{-
+range ::
+   (RealFrac b) =>
+   (b,b) -> (a -> b) -> (a -> Int)
+range (l,u) f x =
+   round $
+   limit (0,127) $
+   127*(f x - l)/(u-l)
+-}
+
+
+{- |
+Map NoteOn events to a controller value.
+This way you may play notes via the resonance frequency of a filter.
+-}
+fromNote ::
+   (Query.C msg, Construct.C msg) =>
+   (Int -> Int) -> Controller -> msg -> Maybe msg
+fromNote f ctrl e =
+   maybe
+      (Just e)
+      (\(c, (_v, p, on)) ->
+         toMaybe on $
+         curry (Construct.anyController c) ctrl $
+         f $ VoiceMsg.fromPitch p)
+      (Query.noteExplicitOff e)
diff --git a/src/Reactive/Banana/MIDI/DeBruijn.hs b/src/Reactive/Banana/MIDI/DeBruijn.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/MIDI/DeBruijn.hs
@@ -0,0 +1,138 @@
+module Reactive.Banana.MIDI.DeBruijn where
+
+import qualified Reactive.Banana.MIDI.Trie as Trie
+
+import qualified Data.List.Match as Match
+import qualified Data.List.HT as ListHT
+import qualified Data.List as List
+import Data.Maybe.HT (toMaybe, )
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import qualified Data.Bits as Bits
+import Data.Bits ((.&.), )
+
+import Control.Monad (guard, replicateM, )
+
+import Prelude hiding (all, )
+
+
+{- |
+@'lexLeast' n k@ is a sequence with length n^k
+where @cycle ('lexLeast' n k)@ contains all n-ary numbers with k digits as infixes.
+The function computes the lexicographically smallest of such sequences.
+-}
+lexLeast :: Int -> Int -> [Int]
+lexLeast n k =
+   concat $
+   filter ((0==) . mod k . length) $
+   takeWhile (not . null) $
+   iterate (nextLyndonWord n k) [0]
+
+nextLyndonWord :: Int -> Int -> [Int] -> [Int]
+nextLyndonWord n k =
+   foldr
+      (\x xs ->
+         if null xs
+           then (if x<n-1 then [x+1] else [])
+           else x:xs) [] .
+   take k . cycle
+
+
+{- |
+All Bruijn sequences with a certain alphabet and a certain length of infixes.
+-}
+all :: Int -> Int -> [[Int]]
+all n k =
+   let start = replicate k 0
+       go _ str 0 = do
+          guard $ str==start
+          return []
+       go set str c = do
+          d <- [0 .. n-1]
+          let newStr = tail str ++ [d]
+          guard $ Set.notMember newStr set
+          rest <- go (Set.insert newStr set) newStr (c-1)
+          return $ d:rest
+   in  map (ListHT.rotate (-k)) $
+       go Set.empty start (n^k)
+
+allMap :: Int -> Int -> [[Int]]
+allMap n k =
+   let start = replicate k 0
+       delete d =
+          Map.update (\set ->
+             let newSet = Set.delete d set
+             in  toMaybe (not $ Set.null newSet) newSet)
+       go [] _ = error "infixes must have positive length"
+       go (_:str) todo =
+          case Map.lookup str todo of
+             Nothing -> do
+                guard $ Map.null todo
+                return []
+             Just set -> do
+                d <- Set.toList set
+                rest <- go (str ++ [d]) $ delete d str todo
+                return $ d:rest
+   in  map (take (n^k) . (start ++)) $
+       go start $
+       delete 0 (tail start) $
+       Map.fromAscList $
+       map (flip (,) $ Set.fromList [0 .. n-1]) $
+       replicateM (k-1) [0 .. n-1]
+
+
+allTrie :: Int -> Int -> [[Int]]
+allTrie n k =
+   let start = replicate k 0
+       go [] _ = error "infixes must have positive length"
+       go (_:str) todo =
+          case Trie.lookup str todo of
+             Nothing -> do
+                guard $ Trie.null todo
+                return []
+             Just set -> do
+                d <- set
+                rest <- go (str ++ [d]) $ Trie.delete d str todo
+                return $ d:rest
+   in  map (take (n^k) . (start ++)) $
+       go start $
+       Trie.delete 0 (tail start) $
+       Trie.full [0 .. n-1] [0 .. n-1] (k-1)
+
+
+allBits :: Int -> Int -> [[Int]]
+allBits n k =
+   let go code todo =
+          let shiftedCode = mod (code*n) (n^k)
+          in  case Bits.shiftR todo shiftedCode .&. (2^n-1) of
+                 0 -> do
+                    guard $ todo == 0
+                    return []
+                 set -> do
+                    d <- [0 .. n-1]
+                    guard $ Bits.testBit set d
+                    rest <-
+                       let newCode = shiftedCode + d
+                       in  go newCode $ Bits.clearBit todo newCode
+                    return $ d:rest
+   in  map (take (n^k) . (replicate k 0 ++)) $
+       go 0 $ (2^n^k-2 :: Integer)
+
+
+-- * tests
+
+testLexLeast :: Int -> Int -> Bool
+testLexLeast n k =
+   lexLeast n k == head (allMap n k)
+
+test :: Int -> Int -> [Int] -> Bool
+test n k xs =
+   replicateM k [0 .. n-1]
+   ==
+   (List.sort $ Match.take xs $ map (take k) $ List.tails $ cycle xs)
+
+testAll :: Int -> Int -> Bool
+testAll n k =
+   List.all (test n k) $ allMap n k
diff --git a/src/Reactive/Banana/MIDI/Guitar.hs b/src/Reactive/Banana/MIDI/Guitar.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/MIDI/Guitar.hs
@@ -0,0 +1,30 @@
+-- cf. Haskore/Guitar
+module Reactive.Banana.MIDI.Guitar where
+
+import qualified Reactive.Banana.MIDI.Pitch as Pitch
+import Sound.MIDI.Message.Channel.Voice (Pitch, toPitch, )
+
+import qualified Data.List.Key as Key
+import Data.Maybe (mapMaybe, )
+
+
+mapChordToString ::
+   (Pitch.C pitch) =>
+   [Pitch] -> [pitch] -> [pitch]
+mapChordToString strings chord =
+   mapMaybe (choosePitchForString chord) strings
+
+choosePitchForString ::
+   (Pitch.C pitch) =>
+   [pitch] -> Pitch -> Maybe pitch
+choosePitchForString chord string =
+   let roundDown x d = x - mod x d
+       minAbove x =
+          Pitch.increase
+             (- roundDown (Pitch.subtract string (Pitch.extract x)) 12) x
+   in  Key.maximum (fmap Pitch.extract) $ map minAbove chord
+
+stringPitches :: [Pitch]
+stringPitches =
+   reverse $ map toPitch [40, 45, 50, 55, 59, 64]
+--   reverse [(-2,E), (-2,A), (-1,D), (-1,G), (-1,B), (0,E)]
diff --git a/src/Reactive/Banana/MIDI/IndexedMonad.hs b/src/Reactive/Banana/MIDI/IndexedMonad.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/MIDI/IndexedMonad.hs
@@ -0,0 +1,26 @@
+{-
+This module could as well live in a separate package.
+-}
+module Reactive.Banana.MIDI.IndexedMonad where
+
+import Control.Applicative (Applicative, pure, (<*>), )
+import Control.Monad (liftM, ap, )
+
+
+class C m where
+   point :: a -> m s a
+   bind :: m s a -> (a -> m s b) -> m s b
+
+
+newtype Wrap m s a = Wrap {unwrap :: m s a}
+
+instance C m => Functor (Wrap m s) where
+   fmap = liftM
+
+instance C m => Applicative (Wrap m s) where
+   pure = return
+   (<*>) = ap
+
+instance C m => Monad (Wrap m s) where
+   return = Wrap . point
+   Wrap x >>= k  =  Wrap $ bind x (unwrap . k)
diff --git a/src/Reactive/Banana/MIDI/KeySet.hs b/src/Reactive/Banana/MIDI/KeySet.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/MIDI/KeySet.hs
@@ -0,0 +1,260 @@
+module Reactive.Banana.MIDI.KeySet where
+
+import qualified Reactive.Banana.MIDI.Note as Note
+
+import qualified Data.Traversable as Trav
+
+import qualified Data.Accessor.Monad.Trans.State as AccState
+import qualified Data.Accessor.Basic as Acc
+
+import qualified Control.Monad.Trans.State as MS
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import Data.Maybe.HT (toMaybe, )
+import Data.Maybe (maybeToList, listToMaybe, )
+
+
+{-
+class C set where
+   press :: Channel -> (Velocity, Pitch) -> set -> set
+   release :: Channel -> (Velocity, Pitch) -> set -> set
+   reset :: set -> set
+
+change :: C set => Channel -> (Velocity, Pitch, Bool) -> set -> set
+change chan (vel, pitch, True)  = press   chan (vel, pitch)
+change chan (vel, pitch, False) = release chan (vel, pitch)
+-}
+
+class C set where
+   reset :: MS.State (set key value) [Note.Boundary key value]
+   {- |
+   It must hold @reset == resetSome (const True)@.
+   -}
+   resetSome :: Ord key => (key -> Bool) -> MS.State (set key value) [Note.Boundary key value]
+   size :: set key value -> Int
+   toList :: set key value -> [(key, value)]
+   index :: Ord key => Int -> set key value -> Maybe (key, value)
+   change :: Ord key => Note.Boundary key value -> MS.State (set key value) [Note.Boundary key value]
+
+changeExt ::
+   (Ord key, C set) =>
+   Note.BoundaryExt key value ->
+   MS.State (set key value) [Note.Boundary key value]
+changeExt e =
+   case e of
+      Note.BoundaryExt bnd -> change bnd
+      Note.AllOff p -> resetSome p
+
+class Map set where
+   accessMap :: Acc.T (set key value) (Map.Map key value)
+
+
+newtype Pressed key value = Pressed {deconsPressed :: Map.Map key value}
+   deriving (Show)
+
+pressed :: Pressed key value
+pressed = Pressed Map.empty
+
+instance Map Pressed where
+   accessMap = Acc.fromWrapper Pressed deconsPressed
+
+instance C Pressed where
+   reset = releasePlayedKeys
+   resetSome = releaseSomeKeys
+   size = sizeGen
+   toList = toListGen
+   index = indexGen
+   change bnd@(Note.Boundary key vel on) = do
+      AccState.modify accessMap $
+         if on
+           then Map.insert key vel
+           else Map.delete key
+      return [bnd]
+
+
+
+newtype Latch key value = Latch {deconsLatch :: Map.Map key value}
+   deriving (Show)
+
+latch :: Latch key value
+latch = Latch Map.empty
+
+instance Map Latch where
+   accessMap = Acc.fromWrapper Latch deconsLatch
+
+latchChange ::
+   Ord key =>
+   Note.Boundary key value ->
+   MS.State (Latch key value) (Maybe (Note.Boundary key value))
+latchChange (Note.Boundary key vel on) =
+   Trav.sequence $ toMaybe on $ do
+      isPressed <- MS.gets (Map.member key . deconsLatch)
+      if isPressed
+        then
+           AccState.modify accessMap (Map.delete key) >>
+           return (Note.Boundary key vel False)
+        else
+           AccState.modify accessMap (Map.insert key vel) >>
+           return (Note.Boundary key vel True)
+
+instance C Latch where
+   reset = releasePlayedKeys
+   resetSome = releaseSomeKeys
+   size = sizeGen
+   toList = toListGen
+   index = indexGen
+   change = fmap maybeToList . latchChange
+
+
+
+data GroupLatch key value =
+   GroupLatch {
+      groupLatchPressed_ {- input -} :: Set.Set key,
+      groupLatchPlayed_ {- output -} :: Map.Map key value
+   } deriving (Show)
+
+groupLatch :: GroupLatch key value
+groupLatch = GroupLatch Set.empty Map.empty
+
+groupLatchPressed :: Acc.T (GroupLatch key value) (Set.Set key)
+groupLatchPressed =
+   Acc.fromSetGet
+      (\mp grp -> grp{groupLatchPressed_ = mp})
+      groupLatchPressed_
+
+groupLatchPlayed :: Acc.T (GroupLatch key value) (Map.Map key value)
+groupLatchPlayed =
+   Acc.fromSetGet
+      (\mp grp -> grp{groupLatchPlayed_ = mp})
+      groupLatchPlayed_
+
+instance Map GroupLatch where
+   accessMap = groupLatchPlayed
+
+{- |
+All pressed keys are latched until a key is pressed after a pause
+(i.e. all keys released).
+For aborting the pattern you have to send
+a 'ModeMsg.AllNotesOff' or 'ModeMsg.AllSoundOff' message.
+-}
+instance C GroupLatch where
+   reset = releasePlayedKeys
+   resetSome = releaseSomeKeys
+   size = sizeGen
+   toList = toListGen
+   index = indexGen
+   change (Note.Boundary key vel on) =
+      if on
+        then do
+           pressd <- AccState.get groupLatchPressed
+           noteOffs <-
+              if Set.null pressd
+                then releasePlayedKeys
+                else return []
+           AccState.modify groupLatchPressed (Set.insert key)
+           played <- AccState.get groupLatchPlayed
+           noteOn <-
+              if Map.member key played
+                then
+                   return []
+                else do
+                   AccState.modify groupLatchPlayed (Map.insert key vel)
+                   return [Note.Boundary key vel True]
+           return $
+              noteOffs ++ noteOn
+        else
+           AccState.modify groupLatchPressed (Set.delete key) >>
+           return []
+
+
+
+data SerialLatch key value =
+   SerialLatch {
+      serialLatchSize_ :: Int,
+      serialLatchCursor_ :: Int,
+      serialLatchPlayed_ :: Map.Map Int (key, value)
+   } deriving (Show)
+
+serialLatch :: Int -> SerialLatch key value
+serialLatch num = SerialLatch num 0 Map.empty
+
+serialLatchCursor :: Acc.T (SerialLatch key value) Int
+serialLatchCursor =
+   Acc.fromSetGet
+      (\mp grp -> grp{serialLatchCursor_ = mp})
+      serialLatchCursor_
+
+serialLatchPlayed :: Acc.T (SerialLatch key value) (Map.Map Int (key, value))
+serialLatchPlayed =
+   Acc.fromSetGet
+      (\mp grp -> grp{serialLatchPlayed_ = mp})
+      serialLatchPlayed_
+
+
+
+{- |
+A key is hold until @n@ times further keys are pressed.
+The @n@-th pressed key replaces the current one.
+-}
+instance C SerialLatch where
+--   reset = AccState.lift serialLatchPlayed releasePlayedKeys
+--      (0, Map.empty)
+   reset =
+      fmap (map (uncurry releaseKey) . Map.elems) $
+      AccState.getAndModify serialLatchPlayed (const Map.empty)
+   resetSome p =
+      fmap (map (uncurry releaseKey) . Map.elems) $
+      AccState.lift serialLatchPlayed $
+      MS.state $ Map.partition (p . fst)
+   size = serialLatchSize_
+   toList = Map.elems . serialLatchPlayed_
+   index k = Map.lookup k . serialLatchPlayed_
+   change bnd@(Note.Boundary key vel on) =
+      if on
+        then do
+           n <- MS.gets serialLatchSize_
+           k <- AccState.getAndModify serialLatchCursor (flip mod n . (1+))
+           oldKey <- fmap (Map.lookup k) $ AccState.get serialLatchPlayed
+           AccState.modify serialLatchPlayed (Map.insert k (key, vel))
+           return $ maybeToList (fmap (uncurry releaseKey) oldKey)
+                     ++ [bnd]
+        else return []
+
+sizeGen :: (Map set) => set key value -> Int
+sizeGen = Map.size . Acc.get accessMap
+
+toListGen :: (Map set) => set key value -> [(key, value)]
+toListGen = Map.toAscList . Acc.get accessMap
+
+indexGen ::
+   (Ord key, Map set) =>
+   Int -> set key value -> Maybe (key, value)
+indexGen k =
+   listToMaybe . drop k . Map.toAscList . Acc.get accessMap
+
+releasePlayedKeys ::
+   (Map set) =>
+   MS.State
+      (set key value)
+      [Note.Boundary key value]
+releasePlayedKeys =
+   fmap (map (uncurry releaseKey) . Map.toList) $
+   AccState.getAndModify accessMap $ const Map.empty
+
+releaseSomeKeys ::
+   (Ord key, Map set) =>
+   (key -> Bool) ->
+   MS.State
+      (set key value)
+      [Note.Boundary key value]
+releaseSomeKeys p =
+   fmap (map (uncurry releaseKey) . Map.toList) $
+   AccState.lift accessMap $ MS.state $
+   Map.partitionWithKey (const . p)
+
+releaseKey ::
+   key -> value -> Note.Boundary key value
+releaseKey key vel =
+   Note.Boundary key vel False
diff --git a/src/Reactive/Banana/MIDI/Note.hs b/src/Reactive/Banana/MIDI/Note.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/MIDI/Note.hs
@@ -0,0 +1,141 @@
+module Reactive.Banana.MIDI.Note where
+
+import qualified Reactive.Banana.MIDI.Pitch as Pitch
+import qualified Reactive.Banana.MIDI.Time as Time
+import qualified Reactive.Banana.MIDI.Common as Common
+import Reactive.Banana.MIDI.Common (PitchChannel(PitchChannel), )
+
+import qualified Sound.MIDI.Message.Class.Query as Query
+import qualified Sound.MIDI.Message.Class.Construct as Construct
+import qualified Sound.MIDI.Message.Channel.Mode as Mode
+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
+import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, )
+
+import Control.Monad (mplus, )
+import Data.Monoid (mappend, )
+
+
+
+data Boundary key value =
+     Boundary key value Bool
+   deriving (Eq, Show)
+
+data BoundaryExt key value =
+     BoundaryExt (Boundary key value)
+   | AllOff (key -> Bool)
+   {- ^
+   The predicate shall return True,
+   if a certain key shall be released by the AllOff statement.
+   E.g. the predicate might check for the appropriate channel.
+   -}
+
+
+maybeBnd ::
+   Query.C msg =>
+   msg -> Maybe (Boundary PitchChannel Velocity)
+maybeBnd =
+   fmap (\(c, (v, p, on)) -> Boundary (PitchChannel p c) v on) . Query.note
+
+maybeBndExt ::
+   Query.C msg =>
+   msg -> Maybe (BoundaryExt PitchChannel Velocity)
+maybeBndExt ev =
+   mplus
+      (fmap BoundaryExt $ maybeBnd ev)
+      (let allOff chan = Just $ AllOff $ \(PitchChannel _p c) -> chan == c
+       in  case Query.mode ev of
+               Just (chan, Mode.AllNotesOff) -> allOff chan
+               Just (chan, Mode.AllSoundOff) -> allOff chan
+               _ -> Nothing)
+
+
+class Pitch.C x => Make x where
+   make :: Construct.C msg => x -> Velocity -> Bool -> msg
+
+instance Make Pitch where
+   make p =
+      make (PitchChannel p minBound)
+
+instance Make PitchChannel where
+   make (PitchChannel p c) vel on =
+      Construct.note c (vel, p, on)
+
+
+
+fromBnd ::
+   (Make key, Common.VelocityField value, Construct.C msg) =>
+   Boundary key value -> msg
+fromBnd (Boundary pc vel on) =
+   make pc (Common.getVelocity vel) on
+
+
+bundle ::
+   (Construct.C msg) =>
+   Time.T m Time.Relative Time.Ticks ->
+   Time.T m Time.Relative Time.Ticks ->
+   (PitchChannel, Velocity) ->
+   Common.Bundle m msg
+bundle start dur (pc, vel) =
+   Common.Future start (make pc vel True) :
+   Common.Future (mappend start dur) (make pc vel False) :
+   []
+
+
+
+
+
+lift ::
+   (Query.C msg, Construct.C msg) =>
+   (Boundary PitchChannel Velocity -> Boundary PitchChannel Velocity) ->
+   (msg -> Maybe msg)
+lift f msg =
+   fmap (fromBnd . f) $ maybeBnd msg
+
+liftMaybe ::
+   (Query.C msg, Construct.C msg) =>
+   (Boundary PitchChannel Velocity -> Maybe (Boundary PitchChannel Velocity)) ->
+   (msg -> Maybe msg)
+liftMaybe f msg =
+   fmap fromBnd . f =<< maybeBnd msg
+
+{- |
+Pitch.C a note event by the given number of semitones.
+Non-note events are returned without modification.
+If by transposition a note leaves the range of representable MIDI notes,
+then we return Nothing.
+-}
+transpose ::
+   Int ->
+   Boundary PitchChannel v ->
+   Maybe (Boundary PitchChannel v)
+transpose d (Boundary (PitchChannel p0 c) v on) =
+   fmap
+      (\p1 -> Boundary (PitchChannel p1 c) v on)
+      (Pitch.increase d p0)
+
+{- |
+Swap order of keys.
+Non-note events are returned without modification.
+If by reversing a note leaves the range of representable MIDI notes,
+then we return Nothing.
+-}
+reverse ::
+   Boundary PitchChannel v ->
+   Maybe (Boundary PitchChannel v)
+reverse (Boundary (PitchChannel p0 c) v on) =
+   fmap
+      (\p1 -> Boundary (PitchChannel p1 c) v on)
+      (Pitch.maybeFromInt $ (60+64 -) $ VoiceMsg.fromPitch p0)
+
+reduceVelocity ::
+   Velocity ->
+   Boundary pc Velocity ->
+   Boundary pc Velocity
+reduceVelocity decay (Boundary pc v on) =
+   Boundary pc
+      (case VoiceMsg.fromVelocity v of
+         0 -> v
+         vel ->
+            VoiceMsg.toVelocity $
+            vel - min (VoiceMsg.fromVelocity decay) (vel-1))
+      on
diff --git a/src/Reactive/Banana/MIDI/Pattern.hs b/src/Reactive/Banana/MIDI/Pattern.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/MIDI/Pattern.hs
@@ -0,0 +1,414 @@
+module Reactive.Banana.MIDI.Pattern where
+
+import qualified Reactive.Banana.MIDI.Note as Note
+import qualified Reactive.Banana.MIDI.KeySet as KeySet
+import qualified Reactive.Banana.MIDI.DeBruijn as DeBruijn
+import qualified Reactive.Banana.MIDI.Pitch as Pitch
+
+import Reactive.Banana.MIDI.Common (splitFraction, )
+
+import qualified Reactive.Banana.MIDI.Utility as RBU
+import qualified Reactive.Banana.Combinators as RB
+import Reactive.Banana.Combinators ((<@>), )
+
+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
+import Sound.MIDI.Message.Channel.Voice (Velocity, )
+
+import qualified Data.EventList.Absolute.TimeBody as AbsEventList
+import qualified Data.EventList.Relative.TimeBody as EventList
+import qualified Data.EventList.Relative.TimeMixed as EventListTM
+import Data.EventList.Relative.MixedBody ((/.), (./), )
+import qualified Numeric.NonNegative.Wrapper as NonNegW
+
+import qualified Data.List.HT as ListHT
+import qualified Data.List as List
+
+import qualified System.Random as Rnd
+
+import qualified Control.Monad.Trans.State as MS
+
+import qualified Data.Traversable as Trav
+import qualified Data.Foldable as Fold
+
+import Control.Monad (guard, )
+import Control.Applicative (Applicative, pure, (<*>), )
+import Data.Maybe (mapMaybe, maybeToList, )
+import Data.Bool.HT (if', )
+import Data.Ord.HT (comparing, )
+
+import Prelude hiding (init, filter, reverse, )
+
+
+
+-- * reactive patterns
+
+type T t time set key value =
+   RB.Behavior t (set key value) ->
+   RB.Event t time ->
+   RB.Event t [Note.Boundary key value]
+
+mono ::
+   (KeySet.C set) =>
+   Selector set key Velocity i ->
+   RB.Behavior t (set key Velocity) ->
+   RB.Event t i ->
+   RB.Event t [Note.Boundary key Velocity]
+mono select pressed pattern =
+   fst $ RBU.sequence [] $
+   pure
+      (\set i -> do
+         off <- MS.get
+         let mnote = select i set
+             on =
+                fmap
+                   (\(key, vel) -> Note.Boundary key vel True)
+                   mnote
+         MS.put $ fmap
+            (\(key, _vel) -> Note.Boundary key VoiceMsg.normalVelocity False)
+            mnote
+         return $ off ++ on)
+      <*> pressed
+      <@> pattern
+
+
+poly ::
+   (KeySet.C set) =>
+   Selector set key Velocity i ->
+   RB.Behavior t (set key Velocity) ->
+   RB.Event t [IndexNote i] ->
+   RB.Event t [Note.Boundary key Velocity]
+poly select pressed pattern =
+   fst $ RBU.sequence EventList.empty $
+   pure
+      (\set is -> do
+         off <- MS.get
+         let (nowOff, laterOff) = EventListTM.splitAtTime 1 off
+             sel = concatMap (Trav.traverse (flip select set)) is
+             on =
+                fmap
+                   (\(IndexNote _ (key, vel)) ->
+                      Note.Boundary key vel True)
+                   sel
+         MS.put $
+            EventList.mergeBy (\ _ _ -> False) laterOff $
+            EventList.fromAbsoluteEventList $
+            AbsEventList.fromPairList $
+            List.sortBy (comparing fst) $
+            map
+               (\(IndexNote dur (key, _vel)) ->
+                  (dur, Note.Boundary key VoiceMsg.normalVelocity False))
+            sel
+         return $ Fold.toList nowOff ++ on)
+      <*> pressed
+      <@> pattern
+
+
+
+-- * selectors
+
+type Selector set key value i =
+        i -> set key value -> [(key, value)]
+
+
+data IndexNote i = IndexNote NonNegW.Int i
+   deriving (Show, Eq, Ord)
+
+instance Functor IndexNote where
+   fmap f (IndexNote d i) = IndexNote d $ f i
+
+instance Fold.Foldable IndexNote where
+   foldMap = Trav.foldMapDefault
+
+instance Trav.Traversable IndexNote where
+   sequenceA (IndexNote d i) = fmap (IndexNote d) i
+
+
+item :: i -> Int -> IndexNote i
+item i n = IndexNote (NonNegW.fromNumberMsg "Pattern.item" n) i
+
+data
+   Poly set key value i =
+      Poly (Selector set key value i) (EventList.T Int [IndexNote i])
+
+
+{- |
+Generate notes according to the key set,
+where notes for negative and too large indices
+are padded with keys that are transposed by octaves.
+-}
+selectFromOctaveChord ::
+   (KeySet.C set, Ord pitch, Pitch.C pitch) =>
+   Selector set pitch value Int
+selectFromOctaveChord d chord =
+   maybeToList $ do
+      let size = KeySet.size chord
+      guard (size>0)
+      let (q,r) = divMod d size
+      (pc, vel) <- KeySet.index r chord
+      pcTrans <- Pitch.increase (12*q) pc
+      return (pcTrans, vel)
+
+selectFromChord ::
+   (KeySet.C set, Ord key) =>
+   Selector set key value Int
+selectFromChord n chord =
+   maybeToList $ KeySet.index n chord
+
+selectFromChordRatio ::
+   (KeySet.C set, Ord key) =>
+   Selector set key value Double
+selectFromChordRatio d chord =
+   selectFromChord (floor $ d * fromIntegral (KeySet.size chord)) chord
+
+
+selectInversion ::
+   (KeySet.C set, Pitch.C pitch) =>
+   Selector set pitch value Double
+selectInversion d chord =
+   let makeNote octave (pc, vel) =
+          fmap
+             (\pcTrans -> (pcTrans, vel))
+             (Pitch.increase (octave*12) pc)
+       (oct,p) = splitFraction d
+       pivot = floor (p * fromIntegral (KeySet.size chord))
+       (low,high) = splitAt pivot $ KeySet.toList chord
+   in  mapMaybe (makeNote oct) high ++
+       mapMaybe (makeNote (oct+1)) low
+
+
+
+-- * patterns
+
+{- |
+See Haskore/FlipSong
+
+  flipSeq m !! n = cross sum of the m-ary representation of n modulo m.
+
+  For m=2 this yields
+  http://www.research.att.com/cgi-bin/access.cgi/as/njas/sequences/eisA.cgi?Anum=A010060
+-}
+flipSeq :: Int -> [Int]
+flipSeq n =
+   let incList m = map (\x -> mod (x+m) n)
+       recourse y =
+          let z = concatMap (flip incList y) [1 .. n-1]
+          in  z ++ recourse (y++z)
+   in  [0] ++ recourse [0]
+
+
+cycleUpIndex, cycleDownIndex, pingPongIndex ::
+   RB.Behavior t Int ->
+   RB.Event t time ->
+   RB.Event t Int
+cycleUpIndex numbers times =
+   fst $ RB.mapAccum 0 $
+   pure
+      (\number _time i -> (i, mod (succ i) (max 1 number)))
+      <*> numbers
+      <@> times
+
+cycleDownIndex numbers times =
+   RB.accumE 0 $
+   pure
+      (\number _time i -> mod (pred i) (max 1 number))
+      <*> numbers
+      <@> times
+
+pingPongIndex numbers times =
+   fst $ RB.mapAccum (0,1) $
+   pure
+      (\number _time (i,d0) ->
+         (i, let j = i+d0
+                 d1 =
+                    if' (j>=number) (-1) $
+                    if' (j<0) 1 d0
+             in  (i+d1, d1)))
+      <*> numbers
+      <@> times
+
+crossSumIndex ::
+   RB.Behavior t Int ->
+   RB.Event t time ->
+   RB.Event t Int
+crossSumIndex numbers times =
+   pure
+      (\number i ->
+         let m = fromIntegral number
+         in  if m <= 1
+               then 0
+               else fromInteger $ flip mod m $ sum $ decomposePositional m i)
+      <*> numbers
+      <@> fromList [0..] times
+
+
+crossSumStaticIndex ::
+   Int ->
+   RB.Event t time ->
+   RB.Event t Int
+crossSumStaticIndex number =
+   fromList (flipSeq number)
+
+fromList :: [a] -> RB.Event t time -> RB.Event t a
+fromList xs times =
+   RB.filterJust $ fst $ RB.mapAccum xs $
+   fmap
+      (\_time xs0 ->
+         case xs0 of
+            [] -> (Nothing, [])
+            x:xs1 -> (Just x, xs1))
+      times
+
+
+cycleUp, cycleDown, pingPong, crossSum ::
+   (KeySet.C set, Ord key) =>
+   RB.Behavior t Int -> T t time set key Velocity
+cycleUp   numbers sets times =
+   mono selectFromChord sets (cycleUpIndex numbers times)
+cycleDown numbers sets times =
+   mono selectFromChord sets (cycleDownIndex numbers times)
+pingPong  numbers sets times =
+   mono selectFromChord sets (pingPongIndex numbers times)
+crossSum  numbers sets times =
+   mono selectFromChord sets (crossSumIndex numbers times)
+
+bruijn ::
+   (KeySet.C set, Ord key) =>
+   Int -> Int -> T t time set key Velocity
+bruijn n k sets times =
+   mono selectFromChord sets $
+   fromList (cycle $ DeBruijn.lexLeast n k) times
+
+
+binaryStaccato, binaryLegato, binaryAccident ::
+   (KeySet.C set, Ord key) => T t time set key Velocity
+{-
+binary number Pattern.T:
+   0
+   1
+   0 1
+   2
+   0 2
+   1 2
+   0 1 2
+   3
+-}
+binaryStaccato sets times =
+   poly
+      selectFromChord
+      sets
+      (flip fromList times $
+       map
+          (map (IndexNote 1 . fst) .
+           List.filter ((/=0) . snd) .
+           zip [0..] .
+           decomposePositional 2)
+          [0..])
+
+binaryLegato sets times =
+   poly
+      selectFromChord
+      sets
+      (flip fromList times $
+       map
+          (\m ->
+             map (uncurry IndexNote) $
+             List.filter (\(p,_i) -> mod m p == 0) $
+             takeWhile ((<=m) . fst) $
+             zip (iterate (2*) 1) [0..])
+          [0..])
+
+{-
+This was my first try to implement binaryLegato.
+It was not what I wanted, but it sounded nice.
+-}
+binaryAccident sets times =
+   poly
+      selectFromChord
+      sets
+      (flip fromList times $
+       map
+          (zipWith IndexNote (iterate (2*) 1) .
+           map fst .
+           List.filter ((/=0) . snd) .
+           zip [0..] .
+           decomposePositional 2)
+          [0..])
+
+
+-- cf. htam:NumberTheory
+decomposePositional :: Integer -> Integer -> [Integer]
+decomposePositional b =
+   let recourse 0 = []
+       recourse x =
+          let (q,r) = divMod x b
+          in  r : recourse q
+   in  recourse
+
+cycleUpOctave ::
+   (KeySet.C set, Ord pitch, Pitch.C pitch) =>
+   RB.Behavior t Int -> T t time set pitch Velocity
+cycleUpOctave numbers sets times =
+   mono selectFromOctaveChord sets (cycleUpIndex numbers times)
+
+
+random ::
+   (KeySet.C set, Ord key) =>
+   T t time set key Velocity
+random sets times =
+   mono selectFromChordRatio sets $
+   fst $ RB.mapAccum (Rnd.mkStdGen 42) $
+   fmap (const $ Rnd.randomR (0,1)) times
+
+randomInversions ::
+   (KeySet.C set, Pitch.C pitch) =>
+   T t time set pitch Velocity
+randomInversions =
+   inversions $
+   map sum $
+   ListHT.sliceVertical 3 $
+   Rnd.randomRs (-1,1) $
+   Rnd.mkStdGen 42
+
+cycleUpInversions ::
+   (KeySet.C set, Pitch.C pitch) =>
+   Int -> T t time set pitch Velocity
+cycleUpInversions n =
+   inversions $ cycle $ take n $
+   map (\i -> fromInteger i / fromIntegral n) [0..]
+
+inversions ::
+   (KeySet.C set, Pitch.C pitch) =>
+   [Double] -> T t time set pitch Velocity
+inversions rs sets times =
+   mono selectInversion sets (fromList rs times)
+
+
+
+-- * tests
+
+{-
+We cannot use cycle function here, because we need to cycle a Body-Time list
+which is incompatible to a Body-Body list,
+even if the end is never reached.
+-}
+examplePolyTempo0 ::
+   EventList.T Int [IndexNote Int]
+examplePolyTempo0 =
+   let pat =
+          [item 0 1] ./ 1 /. [item 1 1, item 2 1] ./ 2 /.
+          [item 1 1, item 2 1] ./ 1 /. [item 0 1] ./ 2 /.
+          pat
+   in  0 /. pat
+
+examplePolyTempo1 ::
+   EventList.T Int [IndexNote Int]
+examplePolyTempo1 =
+   let pat =
+          [item 0 1] ./ 1 /.
+          [item 2 1, item 3 1, item 4 1] ./ 1 /.
+          [item 2 1, item 3 1, item 4 1] ./ 1 /.
+          [item 1 1] ./ 1 /.
+          [item 2 1, item 3 1, item 4 1] ./ 1 /.
+          [item 2 1, item 3 1, item 4 1] ./ 1 /.
+          pat
+   in  0 /. pat
diff --git a/src/Reactive/Banana/MIDI/Pitch.hs b/src/Reactive/Banana/MIDI/Pitch.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/MIDI/Pitch.hs
@@ -0,0 +1,62 @@
+module Reactive.Banana.MIDI.Pitch where
+
+import Reactive.Banana.MIDI.Common
+          (PitchChannel(PitchChannel),
+           PitchChannelVelocity(PitchChannelVelocity), )
+
+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
+import Sound.MIDI.Message.Channel.Voice (Pitch, fromPitch, )
+
+import Data.Bool.HT (if', )
+import Data.Maybe.HT (toMaybe, )
+import Data.Maybe (fromMaybe, )
+
+import Prelude hiding (subtract, )
+
+
+class C pitch where
+   extract :: pitch -> Pitch
+   increase :: Int -> pitch -> Maybe pitch
+
+instance C Pitch where
+   extract = id
+   increase d p =
+      maybeFromInt $ d + VoiceMsg.fromPitch p
+
+
+instance C PitchChannel where
+   extract (PitchChannel p _) = p
+   increase d (PitchChannel p c) = do
+      p' <- increase d p
+      return $ PitchChannel p' c
+
+instance C PitchChannelVelocity where
+   extract (PitchChannelVelocity pc _) = extract pc
+   increase d (PitchChannelVelocity pc v) = do
+      pc' <- increase d pc
+      return $ PitchChannelVelocity pc' v
+
+
+maybeFromInt :: Int -> Maybe Pitch
+maybeFromInt p =
+   toMaybe
+      (VoiceMsg.fromPitch minBound <= p  &&
+       p <= VoiceMsg.fromPitch maxBound)
+      (VoiceMsg.toPitch p)
+
+subtract :: Pitch -> Pitch -> Int
+subtract p0 p1 =
+   VoiceMsg.fromPitch p1 - VoiceMsg.fromPitch p0
+
+
+
+toClosestOctave :: C pitch => Int -> pitch -> pitch
+toClosestOctave target sourceClass =
+   let t = target
+       s = fromPitch $ extract sourceClass
+       x = mod (s - t + 6) 12 + t - 6
+       y =
+          if' (x<0) (x+12) $
+          if' (x>127) (x-12) x
+   in  fromMaybe (error "toClosestOctave: pitch should always be in MIDI note range") $
+       increase (y-s) sourceClass
diff --git a/src/Reactive/Banana/MIDI/Process.hs b/src/Reactive/Banana/MIDI/Process.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/MIDI/Process.hs
@@ -0,0 +1,696 @@
+module Reactive.Banana.MIDI.Process (
+   RelativeTicks,
+   AbsoluteTicks,
+   RelativeSeconds,
+   Moment(liftMoment),
+   Reactor(reserveSchedule),
+   scheduleQueue,
+   initialEvent,
+   beat,
+   beatQuant,
+   beatVar,
+   delaySchedule,
+   delay,
+   delayAdd,
+   pressed,
+   latch,
+   controllerRaw,
+   controllerExponential,
+   controllerLinear,
+   tempoCtrl,
+   snapSelect,
+   uniqueChanges,
+   sweep,
+   makeControllerLinear,
+   cyclePrograms,
+   cycleProgramsDefer,
+   noteSequence,
+   guitar,
+   trainer,
+   ) where
+
+import qualified Reactive.Banana.MIDI.Guitar as Guitar
+import qualified Reactive.Banana.MIDI.Program as Program
+import qualified Reactive.Banana.MIDI.Controller as Ctrl
+import qualified Reactive.Banana.MIDI.Note as Note
+import qualified Reactive.Banana.MIDI.Time as Time
+import qualified Reactive.Banana.MIDI.KeySet as KeySet
+import qualified Reactive.Banana.MIDI.Pitch as Pitch
+import qualified Reactive.Banana.MIDI.Utility as RBU
+import qualified Reactive.Banana.MIDI.IndexedMonad as IxMonad
+import qualified Reactive.Banana.MIDI.Common as Common
+import Reactive.Banana.MIDI.Common
+          (PitchChannel(PitchChannel),
+           PitchChannelVelocity(PitchChannelVelocity),
+           fraction, )
+
+import qualified Reactive.Banana.Combinators as RB
+import qualified Reactive.Banana.Frameworks as RBF
+import qualified Reactive.Banana.Switch as RBS
+import Reactive.Banana.Combinators ((<@>), )
+
+import qualified Sound.MIDI.Message.Class.Construct as Construct
+import qualified Sound.MIDI.Message.Class.Check as Check
+import qualified Sound.MIDI.Message.Class.Query as Query
+import Sound.MIDI.Message.Channel (Channel, )
+import Sound.MIDI.Message.Channel.Voice
+          (Pitch, Velocity, Controller, Program, fromPitch, )
+
+import qualified Data.EventList.Relative.TimeBody as EventList
+import qualified Data.EventList.Absolute.TimeBody as EventListAbs
+
+import qualified Data.Accessor.Monad.Trans.State as AccState
+import qualified Data.Accessor.Tuple as AccTuple
+
+import qualified Control.Monad.Trans.State as MS
+
+import qualified Data.Traversable as Trav
+import Control.Monad (join, mplus, when, )
+import Control.Applicative (pure, liftA2, (<*>), (<$>), )
+import Data.Monoid (mempty, mappend, )
+import Data.Tuple.HT (mapPair, mapFst, mapSnd, )
+import Data.Ord.HT (comparing, limit, )
+import Data.Maybe.HT (toMaybe, )
+import Data.Maybe (catMaybes, )
+
+import qualified Data.Map as Map
+import qualified Data.List.Key as Key
+import qualified Data.List.Match as Match
+import qualified Data.List as List
+
+import Prelude hiding (sequence, )
+
+
+type RelativeTicks   m = Time.T m Time.Relative Time.Ticks
+type AbsoluteTicks   m = Time.T m Time.Absolute Time.Ticks
+type RelativeSeconds m = Time.T m Time.Relative Time.Seconds
+
+class Moment moment where
+   liftMoment :: RBS.Moment t a -> moment t a
+
+instance Moment RBS.Moment where
+   liftMoment = id
+
+
+class (Moment reactor, Time.Timed reactor) => Reactor reactor where
+   {- |
+   Provide a function for registering future beats
+   and the return the reactive event list
+   that results from the sent beats.
+   -}
+   reserveSchedule ::
+      (RBF.Frameworks t) =>
+      reactor t
+         ([AbsoluteTicks reactor] -> IO (), IO (),
+          RB.Event t (AbsoluteTicks reactor))
+
+reactimate ::
+   (Moment reactor, RBF.Frameworks t) =>
+   RB.Event t (IO ()) -> IxMonad.Wrap reactor t ()
+reactimate = IxMonad.Wrap . liftMoment . RBF.reactimate
+
+liftIO ::
+   (Moment m, RBF.Frameworks t) =>
+   IO a -> IxMonad.Wrap m t a
+liftIO = IxMonad.Wrap . liftMoment . RBF.liftIO
+
+
+
+scheduleQueue ::
+   (Reactor reactor, RBF.Frameworks t) =>
+   RB.Behavior t (AbsoluteTicks reactor) ->
+   RB.Event t (Common.Bundle reactor a) -> reactor t (RB.Event t a)
+scheduleQueue times e = IxMonad.unwrap $ do
+   (send, _cancel, eEcho) <- IxMonad.Wrap reserveSchedule
+   let -- maintain queue and generate Echo events
+       remove echoTime =
+          MS.state $ uncurry $ \_lastTime ->
+          EventList.switchL
+             (error "scheduleQueue: received more events than sent")
+             (\(_t,x) xs ->
+                ((Just x, return () {- "got echo for event: " ++ show x -}),
+                 ({- Time.inc t lastTime -}
+                  echoTime, xs)))
+       add time new = do
+          MS.modify $ \(lastTime, old) ->
+             (time,
+              Common.mergeStable
+                 (EventList.fromAbsoluteEventListGen Time.subSat mempty $
+                  EventListAbs.fromPairList $
+                  map (\(Common.Future dt a) -> (dt, a)) $
+                  List.sortBy (comparing Common.futureTime) new) $
+              EventList.decreaseStart
+                 (Time.subSat time lastTime) old)
+          return (Nothing, send $ map (flip Time.inc time . Common.futureTime) new)
+
+       -- (Queue that keeps track of events to schedule
+       -- , duration of the new alarm if applicable)
+       (eEchoEvent, _bQueue) =
+          RBU.sequence (mempty, EventList.empty) $
+          RB.union (fmap remove eEcho) (pure add <*> times <@> e)
+
+   reactimate $ fmap snd eEchoEvent
+   return $ RBU.mapMaybe fst eEchoEvent
+
+
+
+{- |
+Generate an event at the first time point.
+-}
+initialEvent ::
+   (Reactor reactor, RBF.Frameworks t) =>
+   a -> reactor t (RB.Event t a)
+initialEvent x = IxMonad.unwrap $ do
+   (send, _cancel, eEcho) <- IxMonad.Wrap reserveSchedule
+   liftIO $ send [mempty]
+   return $ fmap (const x) eEcho
+
+
+
+{- |
+Generate a beat according to the tempo control.
+The input signal specifies the period between two beats.
+The output events hold the times, where they occur.
+-}
+beat ::
+   (Reactor reactor, RBF.Frameworks t) =>
+   RB.Behavior t (RelativeTicks reactor) ->
+   reactor t (RB.Event t (AbsoluteTicks reactor))
+beat tempo = IxMonad.unwrap $ do
+   (send, _cancel, eEcho) <- IxMonad.Wrap reserveSchedule
+
+   liftIO $ send [mempty]
+
+   let next dt time = (time, send [Time.inc dt time])
+       eEchoEvent = fmap next tempo <@> eEcho
+
+   reactimate $ fmap snd eEchoEvent
+   return $ fmap fst eEchoEvent
+
+
+{- |
+Similar to 'beat' but warrants a maximum reaction time to tempo changes.
+This way you can alter slow tempos to faster one more quickly.
+-}
+{-
+Instead of this we could use the reciprocal of Time, that is frequency,
+and integrate that.
+But integration of a piecewise RBU.constant function means a linear function.
+This cannot be represented in FRP.
+The approach we use here samples the tempo signal
+and thus may miss some tempo changes.
+-}
+beatQuant ::
+   (Reactor reactor, RBF.Frameworks t) =>
+   RelativeTicks reactor ->
+   RB.Behavior t (RelativeTicks reactor) ->
+   reactor t (RB.Event t (AbsoluteTicks reactor))
+beatQuant maxDur tempo = IxMonad.unwrap $ do
+   (send, _cancel, eEcho) <- IxMonad.Wrap reserveSchedule
+
+   liftIO $ send [mempty]
+
+   let next dt time = do
+          complete <- MS.gets (>=1)
+          when complete $ MS.modify (subtract 1)
+          portion <- MS.get
+          let dur = limit (mempty,maxDur) (Time.scaleCeiling (1-portion) dt)
+          MS.modify (Time.div dur dt +)
+          return
+             (toMaybe complete time,
+              send [Time.inc dur time]
+              {- print (dur, time, dt, portion) -} )
+
+       eEchoEvent =
+          fst $ RBU.sequence 0 $ fmap next tempo <@> eEcho
+
+   reactimate $ fmap snd eEchoEvent
+   return $ RBU.mapMaybe fst eEchoEvent
+
+
+beatVarNext ::
+   AbsoluteTicks reactor ->
+   MS.State
+      (AbsoluteTicks reactor, Double, RelativeTicks reactor)
+      (Maybe (AbsoluteTicks reactor), AbsoluteTicks reactor)
+beatVarNext _t = do
+   (t0,r,p) <- MS.get
+   {-
+   It should be t1==t,
+   where t is the timestamp from an Echo message
+   and t1 is the computed time.
+   In principle we could use t,
+   but this will be slightly later than the reference time t1.
+   -}
+   let t1 = Time.inc (Time.scale r p) t0
+   MS.put (t1,1,p)
+   return (Just t1, Time.inc p t1)
+
+beatVarChange ::
+   RelativeTicks reactor -> AbsoluteTicks reactor ->
+   MS.State
+      (AbsoluteTicks reactor, Double, RelativeTicks reactor)
+      (AbsoluteTicks reactor)
+beatVarChange p1 t1 = do
+   (t0,r0,p0) <- MS.get
+   let r1 = max 0 $ r0 - Time.div (Time.subSat t1 t0) p0
+   MS.put (t1,r1,p1)
+   return (Time.inc (Time.scale r1 p1) t1)
+
+{- |
+Similar to 'beat' but it reacts immediately to tempo changes.
+This requires the ability of the backend (e.g. ALSA)
+to cancel sent (Echo) messages
+and it requires to know the precise time points of tempo changes,
+thus we need the Discrete input instead of Behaviour
+and we need a behaviour for the current time.
+-}
+beatVar ::
+   (Reactor reactor, RBF.Frameworks t) =>
+   RB.Behavior t (AbsoluteTicks reactor) ->
+   RB.Behavior t (RelativeTicks reactor) ->
+   reactor t (RB.Event t (AbsoluteTicks reactor))
+beatVar time tempo = IxMonad.unwrap $ do
+   (send, cancel, eEcho) <- IxMonad.Wrap reserveSchedule
+   let sendSingle = send . (:[])
+
+   liftIO $ sendSingle mempty
+
+   (tempoInit, tempoChanges) <-
+      IxMonad.Wrap $ liftMoment $
+      liftA2 (,) (RBF.initial tempo) (RBF.changes tempo)
+
+   let next t = mapSnd sendSingle <$> beatVarNext t
+
+       change p1 t1 = do
+          ta <- beatVarChange p1 t1
+          return (Nothing, cancel >> sendSingle ta)
+
+       eEchoEvent =
+          fst $ RBU.sequence (mempty, 0, tempoInit) $
+          RB.union
+             (fmap next eEcho)
+             (fmap (flip change) time <@> tempoChanges)
+
+   reactimate $ fmap snd eEchoEvent
+   return $ RBU.mapMaybe fst eEchoEvent
+
+
+{- |
+Demonstration of scheduleQueue.
+For real use with ALSA you should prefer 'delay',
+since this uses precisely timed delivery by ALSA.
+-}
+delaySchedule ::
+   (Reactor reactor, RBF.Frameworks t) =>
+   RelativeTicks reactor ->
+   RB.Behavior t (AbsoluteTicks reactor) ->
+   RB.Event t a -> reactor t (RB.Event t a)
+delaySchedule dt times =
+   scheduleQueue times .
+   fmap ((:[]) . Common.Future dt)
+
+
+delay ::
+   RelativeTicks m ->
+   RB.Event t ev -> RB.Event t (Common.Future m ev)
+delay dt =
+   fmap (Common.Future dt)
+
+delayAdd ::
+   RelativeTicks m ->
+   RB.Event t ev -> RB.Event t (Common.Future m ev)
+delayAdd dt evs =
+   RB.union (fmap Common.now evs) $ delay dt evs
+
+
+{- |
+register pressed keys
+-}
+pressed ::
+   (KeySet.C set, Ord key) =>
+   set key value ->
+   RB.Event f (Note.BoundaryExt key value) ->
+   (RB.Event f [Note.Boundary key value], RB.Behavior f (set key value))
+pressed empty =
+   RBU.traverse empty KeySet.changeExt
+
+latch ::
+   (Ord key) =>
+   RB.Event f (Note.Boundary key value) ->
+   (RB.Event f (Note.Boundary key value),
+    RB.Behavior f (Map.Map key value))
+latch =
+   mapPair (RB.filterJust, fmap KeySet.deconsLatch) .
+   RBU.traverse KeySet.latch KeySet.latchChange
+
+
+controllerRaw ::
+   (Check.C ev) =>
+   Channel ->
+   Controller ->
+   Int ->
+   RB.Event t ev -> RB.Behavior t Int
+controllerRaw chan ctrl deflt =
+   RB.stepper deflt .
+   RBU.mapMaybe (Check.controller chan ctrl)
+
+controllerExponential ::
+   (Floating a, Check.C ev) =>
+   Channel ->
+   Controller ->
+   a -> (a,a) ->
+   RB.Event t ev -> RB.Behavior t a
+controllerExponential chan ctrl deflt (lower,upper) =
+   let k = log (upper/lower) / 127
+   in  RB.stepper deflt .
+       RBU.mapMaybe
+          (fmap ((lower*) . exp . (k*) . fromIntegral)
+              . Check.controller chan ctrl)
+
+controllerLinear ::
+   (Fractional a, Check.C ev) =>
+   Channel ->
+   Controller ->
+   a -> (a,a) ->
+   RB.Event t ev -> RB.Behavior t a
+controllerLinear chan ctrl deflt (lower,upper) =
+   let k = (upper-lower) / 127
+   in  RB.stepper deflt .
+       RBU.mapMaybe
+          (fmap ((lower+) . (k*) . fromIntegral)
+              . Check.controller chan ctrl)
+
+
+tempoCtrl ::
+   (Check.C ev) =>
+   Channel ->
+   Controller ->
+   RelativeTicks m ->
+   (RelativeTicks m, RelativeTicks m) ->
+   RB.Event t ev ->
+   (RB.Behavior t (RelativeTicks m), RB.Event t ev)
+tempoCtrl chan ctrl deflt (lower,upper) =
+   mapFst (RB.stepper deflt) .
+   RBU.partitionMaybe
+      (fmap (Ctrl.duration (lower, upper))
+          . Check.controller chan ctrl)
+
+
+{- |
+Use a MIDI controller for selecting a note from a key set.
+Only the pitch class of the keys is respected.
+The controller behavior must be in the range 0-127.
+This way, it accesses the whole range of MIDI notes.
+The output note is stopped and a new note is played
+whenever turning the knob alters the note pitch.
+The advantage of the effect is that the pitch range of the knob
+does not depend on the number of pressed keys.
+The disadvantage is that there are distinct distances between the pitches.
+-}
+snapSelect ::
+   (Moment moment, RBF.Frameworks t, KeySet.C set,
+    Pitch.C pitch, Eq pitch, Eq value) =>
+   RB.Behavior t (set pitch value) ->
+   RB.Behavior t Int ->
+   moment t (RB.Event t [Note.Boundary pitch value])
+snapSelect set ctrl =
+   liftMoment $
+   fmap
+      (flip RBU.mapAdjacent Nothing
+         (\oldNote newNote ->
+            let note on (pc, v) = Note.Boundary pc v on
+            in  catMaybes [fmap (note False) oldNote,
+                           fmap (note True) newNote])) $
+   uniqueChanges $
+   liftA2
+      (\s x ->
+         toMaybe (not $ null s) $
+         Key.minimum (\(pc, _v) -> abs (fromPitch (Pitch.extract pc) - x)) $
+         map (\(pc, v) -> (Pitch.toClosestOctave x pc, v)) s)
+      (fmap KeySet.toList set) ctrl
+
+
+uniqueChanges ::
+   (Moment moment, RBF.Frameworks t, Eq a) =>
+   RB.Behavior t a -> moment t (RB.Event t a)
+uniqueChanges x = liftMoment $ do
+   x0 <- RBF.initial x
+   xs <- RBF.changes x
+   return $ RB.filterJust $
+      flip RBU.mapAdjacent x0 (\old new -> toMaybe (new/=old) new) xs
+
+
+sweep ::
+   (RBF.Frameworks t, Reactor reactor) =>
+   RelativeSeconds reactor ->
+   (Double -> Double) ->
+   RB.Behavior t Double ->
+   reactor t
+      (RB.Event t (AbsoluteTicks reactor),
+       RB.Behavior t Double)
+sweep durSecs wave speed = IxMonad.unwrap $ do
+   bt <-
+      IxMonad.Wrap . beat . pure =<<
+         IxMonad.Wrap (Time.ticksFromSeconds durSecs)
+   let dur = realToFrac $ Time.unSeconds $ Time.decons durSecs
+   return
+      (bt,
+       fmap wave $ RB.accumB 0 $
+       fmap (\d _ phase -> fraction (phase + dur * d)) speed <@> bt)
+
+makeControllerLinear ::
+   (Construct.C msg) =>
+   Channel -> Controller ->
+   RB.Behavior t Int ->
+   RB.Behavior t Int ->
+   RB.Event t time -> RB.Behavior t Double ->
+   RB.Event t msg
+makeControllerLinear chan cc depthCtrl centerCtrl bt ctrl =
+   pure
+      (\y depth center _time ->
+         curry (Construct.anyController chan) cc $
+         round $ limit (0,127) $
+         fromIntegral center + fromIntegral depth * y)
+      <*> ctrl
+      <*> depthCtrl
+      <*> centerCtrl
+      <@> bt
+
+
+
+cyclePrograms ::
+   (Construct.C msg, Query.C msg) =>
+   [Program] ->
+   RB.Event t msg -> RB.Event t (Maybe msg)
+cyclePrograms pgms =
+   fst .
+   RBU.traverse (cycle pgms)
+      (Program.traverseSeek (length pgms))
+
+
+{- |
+> cycleProgramsDefer t
+
+After a note that triggers a program change,
+we won't change the program in the next 't' seconds.
+This is in order to allow chords being played
+and in order to skip accidentally played notes.
+-}
+{-
+In the future we might also add a time-out:
+After a certain time, where no key is pressed,
+the program would be reset to the initial program.
+-}
+cycleProgramsDefer ::
+   (Construct.C msg, Query.C msg) =>
+   RelativeTicks m -> [Program] ->
+   RB.Behavior t (AbsoluteTicks m) ->
+   RB.Event t msg -> RB.Event t (Maybe msg)
+cycleProgramsDefer defer pgms times =
+   fst .
+   RBU.traverse (cycle pgms, mempty)
+      (\(eventTime,e) ->
+         fmap join $ Trav.sequence $
+         mplus
+            (flip fmap (Query.program e) $ \(_chan, pgm) ->
+               AccState.lift AccTuple.first $
+                  Program.seek (length pgms) pgm)
+            (flip fmap (Program.maybeNoteOn e) $ \chan -> do
+               blockTime <- MS.gets snd
+               if eventTime < blockTime
+                 then return Nothing
+                 else do
+                    AccState.set AccTuple.second $
+                       Time.inc defer eventTime
+                    AccState.lift AccTuple.first $
+                       Program.next chan)) .
+   RB.apply (fmap (,) times)
+
+
+noteSequence ::
+   (Construct.C msg) =>
+   RelativeTicks m ->
+   Bool -> [Bool -> msg] ->
+   Common.Bundle m msg
+noteSequence stepTime on =
+   zipWith Common.Future (iterate (mappend stepTime) mempty) .
+   map ($on)
+
+{- |
+This process simulates playing chords on a guitar.
+If you press some keys like C, E, G on the keyboard,
+then this process figures out what tones would be played on a guitar.
+
+Call it like @guitar stepTime chords triggers@.
+
+@stepTime@ is the delay between to successive notes.
+A good value is 0.03 (seconds).
+The chords to be played are passed in by @chords@.
+This should be the output of 'pressed'.
+Further on the function needs events
+that trigger playing the chord in @trigger@ argument.
+The trigger consists of the trigger time
+and the direction to be played
+('True' = down from high to low pitches,
+'False' = up from low to high pitches).
+The trigger may be derived from a specific key that is pressed and released,
+or two keys, one for each direction.
+-}
+guitar ::
+   (Construct.C msg, KeySet.C set) =>
+   RelativeTicks m ->
+   RB.Behavior t (set PitchChannel Velocity) ->
+   RB.Event t Bool ->
+   RB.Event t (Common.Bundle m msg)
+guitar stepTime pressd trigger =
+   fst $
+   RBU.traverse []
+      (\(set, on) -> do
+         played <- MS.get
+         let toPlay =
+                case KeySet.toList set of
+                   [] -> []
+                   list ->
+                      fmap (\(PitchChannelVelocity pc v) -> Note.make pc v) $
+                      Guitar.mapChordToString Guitar.stringPitches $
+                      fmap (uncurry PitchChannelVelocity) list
+         MS.put toPlay
+         return $
+            if on
+              then
+                 noteSequence stepTime False
+                    (List.reverse played)
+                 ++
+                 noteSequence stepTime True toPlay
+              else
+                 noteSequence stepTime False played
+                 ++
+                 noteSequence stepTime True
+                    (List.reverse toPlay)) $
+   pure (,) <*> pressd <@> trigger
+
+
+
+{- |
+Audio perception trainer
+
+Play sets of notes and
+let the human player answer to them according to a given scheme.
+Repeat playing the notes sets until the trainee answers correctly.
+Then continue with other sequences, maybe more complicated ones.
+
+possible tasks:
+
+ - replay a sequence of pitches on the keyboard:
+      single notes for training abolute pitches,
+      intervals all with the same base notes,
+      intervals with different base notes
+
+ - transpose a set of pitches:
+      tranpose to a certain base note,
+      transpose by a certain interval
+
+ - play a set of pitches in a different order:
+      reversed order,
+      in increasing pitch
+
+ - replay a set of simultaneously pressed keys
+
+The difficulty can be increased by not connecting
+the keyboard directly with the sound generator.
+This way, the trainee cannot verify,
+how the pressed keys differ from the target keys.
+
+Sometimes it seems that you are catched in an infinite loop.
+This happens if there were too many keys pressed.
+The trainer collects all key press events,
+not only the ones that occur after the target set is played.
+This way you can correct yourself immediately,
+before the target is repeatedly played.
+The downside is, that there may be key press events hanging around.
+You can get rid of them by pressing a key again and again,
+but slowly, until the target is played, again.
+Then the queue of registered keys should be empty
+and you can proceed training.
+-}
+{-
+The Reactor monad is only needed for sending the initial notes.
+-}
+trainer ::
+   (Reactor reactor, RBF.Frameworks t,
+    Query.C msg, Construct.C msg, Time.Quantity time) =>
+   Channel ->
+   Time.T reactor Time.Relative time ->
+   Time.T reactor Time.Relative time ->
+   [([Pitch], [Pitch])] ->
+   RB.Behavior t (AbsoluteTicks reactor) ->
+   RB.Event t msg ->
+   reactor t (RB.Event t (Common.Bundle reactor msg))
+trainer chan pauseSecs durationSecs sets0 times evs0 = IxMonad.unwrap $ do
+   pause    <- IxMonad.Wrap $ Time.ticksFromAny pauseSecs
+   duration <- IxMonad.Wrap $ Time.ticksFromAny durationSecs
+   let makeSeq sets =
+          case sets of
+             (target, _) : _ ->
+                (concat $
+                 zipWith
+                    (\t p ->
+                       Note.bundle t duration
+                          (PitchChannel p chan, Common.normalVelocity))
+                    (iterate (mappend duration) pause) target,
+                 mappend pause $ Time.scaleInt (length target) duration)
+             [] -> ([], mempty)
+
+   let (initial, initIgnoreUntil) = makeSeq sets0
+   initEv <- IxMonad.Wrap $ initialEvent initial
+
+   return $ RB.union initEv $ fst $
+      flip (RBU.traverse (sets0, [], Time.inc initIgnoreUntil mempty))
+         (fmap (,) times <@> evs0) $ \(time,ev) ->
+      case Query.noteExplicitOff ev of
+         Just (_chan, (_vel, pitch, True)) -> do
+            ignoreUntil <- AccState.get AccTuple.third3
+            if time <= ignoreUntil
+              then return []
+              else do
+                 pressd <- AccState.get AccTuple.second3
+                 let newPressd = pitch : pressd
+                 AccState.set AccTuple.second3 newPressd
+                 sets <- AccState.get AccTuple.first3
+                 case sets of
+                    (_, target) : rest ->
+                       if Match.lessOrEqualLength target newPressd
+                         then do
+                            AccState.set AccTuple.second3 []
+                            when (newPressd == List.reverse target) $
+                               AccState.set AccTuple.first3 rest
+                            (notes, newIgnoreUntil) <-
+                               fmap makeSeq $
+                               AccState.get AccTuple.first3
+                            AccState.set AccTuple.third3 $
+                               Time.inc newIgnoreUntil time
+                            return notes
+                         else return []
+                    _ -> return []
+         _ -> return []
diff --git a/src/Reactive/Banana/MIDI/Program.hs b/src/Reactive/Banana/MIDI/Program.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/MIDI/Program.hs
@@ -0,0 +1,135 @@
+module Reactive.Banana.MIDI.Program (
+   traverse, traverseSeek, next, seek, maybeNoteOn,
+   asBanks,
+   ) where
+
+import qualified Sound.MIDI.Message.Class.Query as Query
+import qualified Sound.MIDI.Message.Class.Construct as Construct
+
+import Sound.MIDI.Message.Channel (Channel, )
+import Sound.MIDI.Message.Channel.Voice (Program, fromProgram, toProgram, )
+
+import qualified Control.Monad.Trans.State as MS
+
+import qualified Data.Traversable as Trav
+import Control.Monad (join, mplus, )
+import Data.Tuple.HT (mapFst, mapSnd, )
+import Data.Maybe.HT (toMaybe, )
+
+
+next ::
+   (Construct.C msg) =>
+   Channel -> MS.State [Program] (Maybe msg)
+next chan =
+   MS.state $ \pgms ->
+   case pgms of
+      pgm:rest -> (Just $ Construct.program chan pgm, rest)
+      [] -> (Nothing, [])
+
+seek :: Int -> Program -> MS.State [Program] (Maybe msg)
+seek maxSeek pgm =
+   fmap (const Nothing) $
+   MS.modify $
+      uncurry (++) .
+      mapFst (dropWhile (pgm/=)) .
+      splitAt maxSeek
+
+
+{-
+Maybe we should use @Stream Program@ instead of @[Program]@.
+-}
+{- |
+Before every note switch to another instrument
+according to a list of programs given as state of the State monad.
+I do not know how to handle multiple channels in a reasonable way.
+Currently I just switch the instrument independent from the channel,
+and send the program switch to the same channel as the beginning note.
+-}
+traverse ::
+   (Query.C msg, Construct.C msg) =>
+   msg -> MS.State [Program] (Maybe msg)
+traverse =
+   fmap join . Trav.traverse next . maybeNoteOn
+
+{- |
+This function extends 'traverse'.
+It reacts on external program changes
+by seeking an according program in the list.
+This way we can reset the pointer into the instrument list.
+However the search must be limited in order to prevent an infinite loop
+if we receive a program that is not contained in the list.
+-}
+traverseSeek ::
+   (Query.C msg, Construct.C msg) =>
+   Int ->
+   msg -> MS.State [Program] (Maybe msg)
+traverseSeek maxSeek e =
+   fmap join $ Trav.sequence $
+   mplus
+      (fmap next $ maybeNoteOn e)
+      (fmap (seek maxSeek . snd) $ Query.program e)
+
+maybeNoteOn :: (Query.C msg) => msg -> Maybe Channel
+maybeNoteOn msg =
+   Query.noteExplicitOff msg >>= \(c, (_p, _v, on)) -> toMaybe on c
+
+
+
+{- |
+> > replace [1,2,3,4] 5 [10,11,12,13]
+> (True,[10,11,2,13])
+-}
+replace :: Real i => [i] -> i -> [i] -> (Bool, [i])
+replace (n:ns) pgm pt =
+   let (p,ps) =
+          case pt of
+             [] -> (0,[])
+             (x:xs) -> (x,xs)
+   in  if pgm<n
+         then (True, pgm:ps)
+         else mapSnd (p:) $
+              replace ns (pgm-n) ps
+replace [] _ ps = (False, ps)
+
+fromBanks :: Real i => [i] -> [i] -> i
+fromBanks ns ps =
+   foldr (\(n,p) s -> p+n*s) 0 $
+   zip ns ps
+
+{- |
+Interpret program changes as a kind of bank switches
+in order to increase the range of instruments
+that can be selected via a block of patch select buttons.
+
+@asBanks ns@ divides the first @sum ns@ instruments
+into sections of sizes @ns!!0, ns!!1, ...@.
+Each program in those sections is interpreted as a bank in a hierarchy,
+where the lower program numbers are the least significant banks.
+Programs from @sum ns@ on are passed through as they are.
+@product ns@ is the number of instruments
+that you can address using this trick.
+In order to avoid overflow it should be less than 128.
+
+E.g. @asBanks [n,m]@ interprets subsequent program changes to
+@a@ (@0<=a<n@) and @n+b@ (@0<=b<m@)
+as a program change to @b*n+a@.
+@asBanks [8,8]@ allows to select 64 instruments
+by 16 program change buttons,
+whereas @asBanks [8,4,4]@
+allows to address the full range of MIDI 128 instruments
+with the same number of buttons.
+-}
+asBanks ::
+   (Query.C msg, Construct.C msg) =>
+   [Int] ->
+   msg -> MS.State [Int] msg
+asBanks ns e =
+   maybe
+      (return e)
+      (\(chan,pgm) -> do
+          valid <- MS.state $ replace ns (fromProgram pgm)
+          fmap (Construct.program chan) $
+             if valid
+               then MS.gets (toProgram . fromBanks ns)
+               else return pgm) $
+   Query.program e
diff --git a/src/Reactive/Banana/MIDI/Time.hs b/src/Reactive/Banana/MIDI/Time.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/MIDI/Time.hs
@@ -0,0 +1,147 @@
+module Reactive.Banana.MIDI.Time where
+
+import qualified Reactive.Banana.MIDI.IndexedMonad as IxMonad
+import qualified Reactive.Banana.Frameworks as RBF
+
+import qualified Numeric.NonNegative.Class as NonNeg
+
+import Control.Applicative (Const(Const), )
+import Data.Monoid (Monoid, mempty, mappend, )
+import Data.Tuple.HT (mapPair, mapSnd, )
+import Data.Ord.HT (comparing, )
+import Data.Eq.HT (equating, )
+
+import Prelude hiding (div, )
+
+{- |
+The 'T' types are used instead of floating point types,
+because the latter ones caused unpredictable 'negative number' errors.
+There should be a common denominator to all involved numbers.
+This way we can prevent unlimited growth of denominators.
+-}
+-- the Const type helps us to avoid explicit kind signature extension
+newtype T m t a = Cons (Const a (m () t))
+
+instance Show a => Show (T m t a) where
+   showsPrec n x =
+      showParen (n>10) $
+         showString "Time.cons " . shows (decons x)
+
+instance Eq a => Eq (T m t a) where
+   (==)  =  equating decons
+
+instance Ord a => Ord (T m t a) where
+   compare  =  comparing decons
+
+cons :: a -> T m t a
+cons = Cons . Const
+
+decons :: T m t a -> a
+decons (Cons (Const a)) = a
+
+relative ::
+   (Ord a, Monoid a) =>
+   String -> a -> T m Relative a
+relative name t =
+   if t>=mempty
+     then cons t
+     else error $ name ++ ": negative time"
+
+
+data Absolute = Absolute
+data Relative = Relative
+
+newtype Seconds = Seconds {unSeconds :: Rational}
+   deriving (Show, Eq, Ord)
+
+newtype Ticks = Ticks {unTicks :: Integer}
+   deriving (Show, Eq, Ord)
+
+instance Monoid Seconds where
+   mempty = Seconds 0
+   mappend (Seconds x) (Seconds y) = Seconds $ x+y
+
+instance Monoid Ticks where
+   mempty = Ticks 0
+   mappend (Ticks x) (Ticks y) = Ticks $ x+y
+
+
+instance (Monoid a) => Monoid (T m t a) where
+   mempty = cons mempty
+   mappend x y = cons $ mappend (decons x) (decons y)
+
+
+class RelativeC t where
+instance RelativeC Relative where
+
+{- |
+Technically identical to NonNeg.C
+but without connotation of non-negativity.
+-}
+class (Ord a, Monoid a) => Split a where
+   split :: a -> a -> (a, (Bool, a))
+
+instance Split Seconds where
+   split = NonNeg.splitDefault unSeconds Seconds
+
+instance Split Ticks where
+   split = NonNeg.splitDefault unTicks Ticks
+
+
+instance (RelativeC t, Split a) => NonNeg.C (T m t a) where
+   split x y =
+      mapPair (cons, mapSnd cons) $ split (decons x) (decons y)
+
+
+class IxMonad.C m => Timed m where
+   ticksFromSeconds :: (RBF.Frameworks s) => T m t Seconds -> m s (T m t Ticks)
+
+class Quantity a where
+   ticksFromAny :: (Timed m, RBF.Frameworks s) => T m t a -> m s (T m t Ticks)
+
+instance Quantity Seconds where
+   ticksFromAny = ticksFromSeconds
+
+instance Quantity Ticks where
+   ticksFromAny = IxMonad.point
+
+
+consRel :: String -> Rational -> T m Relative Seconds
+consRel msg x =
+   if x>=0
+     then cons $ Seconds x
+     else error $ msg ++ ": negative number"
+
+inc ::
+   (Monoid a) =>
+   T m Relative a -> T m t a -> T m t a
+inc dt t = cons $ mappend (decons t) (decons dt)
+
+subSat ::
+   Split a => T m t a -> T m t a -> T m Relative a
+subSat t1 t0 =
+   let (b,d) = snd $ split (decons t0) (decons t1)
+   in  cons $ if b then d else mempty
+
+{- |
+'scale' could also be defined for 'Seconds',
+however, repeated application of 'scale'
+would yield unlimited growth of denominator.
+This applies e.g. to controlled beat generation.
+-}
+scale, scaleCeiling :: Double -> T m Relative Ticks -> T m Relative Ticks
+scale k t =
+   cons $ Ticks $ round $ toRational k * getTicks t
+
+scaleCeiling k t =
+   cons $ Ticks $ ceiling $ toRational k * getTicks t
+
+scaleInt :: Integral i => i -> T m Relative Ticks -> T m Relative Ticks
+scaleInt k t =
+   cons $ Ticks $ getTicks t * fromIntegral k
+
+div :: T m Relative Ticks -> T m Relative Ticks -> Double
+div dt1 dt0  =  getTicks dt1 / getTicks dt0
+
+getTicks :: Num a => T m Relative Ticks -> a
+getTicks = fromInteger . unTicks . decons
diff --git a/src/Reactive/Banana/MIDI/Training.hs b/src/Reactive/Banana/MIDI/Training.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/MIDI/Training.hs
@@ -0,0 +1,111 @@
+module Reactive.Banana.MIDI.Training (
+   all,
+   intervals,
+   twoNotes,
+   threeNotes,
+   reverseThreeNotes,
+   sortThreeNotes,
+   transposeTwoNotes,
+   ) where
+
+import qualified Reactive.Banana.MIDI.Pitch as Pitch
+import Reactive.Banana.MIDI.Common (pitch, )
+import Sound.MIDI.Message.Channel.Voice (Pitch, )
+
+import System.Random (RandomGen, Random, randomR, )
+import Control.Monad.Trans.State (State, state, evalState, )
+import Control.Monad (liftM2, )
+import Data.Maybe (mapMaybe, )
+import qualified Data.List as List
+import Prelude hiding (all, )
+
+
+{- | chose a random item from a list -}
+-- from htam
+randomItem :: (RandomGen g) => [a] -> State g a
+randomItem x = fmap (x!!) (randomRState (length x - 1))
+
+randomRState :: (RandomGen g, Random a, Num a) => a -> State g a
+randomRState upper = state (randomR (0, upper))
+
+
+baseKey :: Pitch
+baseKey = pitch 60
+
+notes :: [Pitch]
+notes =
+   mapMaybe (flip Pitch.increase baseKey)
+   [0, 12, 7, 5, 4, 2, 9, 11, 3, 10, 1, 6, 8]
+
+
+all :: RandomGen g => g -> [([Pitch], [Pitch])]
+all g =
+   intervals g ++ twoNotes g ++ threeNotes g ++
+   reverseThreeNotes g ++ sortThreeNotes g ++
+   transposeTwoNotes g
+
+-- | intervals within an octave, all starting with a C
+intervals :: RandomGen g => g -> [([Pitch], [Pitch])]
+intervals g =
+   flip evalState g $
+   mapM randomItem $
+   concat $ zipWith replicate [3,6..] $
+   drop 3 $ List.inits $
+   map (\p -> let ps = [baseKey, p] in (ps, ps)) $
+   notes
+
+-- | choose two arbitrary notes from an increasing set of notes
+twoNotes :: RandomGen g => g -> [([Pitch], [Pitch])]
+twoNotes g =
+   flip evalState g $
+   mapM (\ps ->
+      fmap (\pso -> (pso,pso)) $
+      mapM randomItem [ps,ps]) $
+   concat $ zipWith replicate [3,6..] $
+   drop 3 $ List.inits $
+   notes
+
+-- | choose three arbitrary notes from an increasing set of notes
+threeNotes :: RandomGen g => g -> [([Pitch], [Pitch])]
+threeNotes g =
+   flip evalState g $
+   mapM (\ps ->
+      fmap (\pso -> (pso,pso)) $
+      mapM randomItem [ps,ps,ps]) $
+   concat $ zipWith replicate [3,6..] $
+   drop 3 $ List.inits $
+   notes
+
+reverseThreeNotes :: RandomGen g => g -> [([Pitch], [Pitch])]
+reverseThreeNotes g =
+   flip evalState g $
+   mapM (\ps ->
+      fmap (\pso -> (pso, reverse pso)) $
+      mapM randomItem [ps,ps,ps]) $
+   concat $ zipWith replicate [3,6..] $
+   drop 3 $ List.inits $
+   notes
+
+sortThreeNotes :: RandomGen g => g -> [([Pitch], [Pitch])]
+sortThreeNotes g =
+   flip evalState g $
+   mapM (\ps ->
+      fmap (\pso -> (pso, List.sort pso)) $
+      mapM randomItem [ps,ps,ps]) $
+   concat $ zipWith replicate [3,6..] $
+   drop 3 $ List.inits $
+   notes
+
+-- | transpose an interval to begin with C
+transposeTwoNotes :: RandomGen g => g -> [([Pitch], [Pitch])]
+transposeTwoNotes g =
+   flip evalState g $
+   mapM (\ps ->
+      liftM2
+         (\p0 p1 ->
+            let pso = [p0,p1]
+            in  (pso, mapMaybe (Pitch.increase (Pitch.subtract p0 baseKey)) pso))
+         (randomItem ps) (randomItem ps)) $
+   concat $ zipWith replicate [3,6..] $
+   drop 3 $ List.inits $
+   notes
diff --git a/src/Reactive/Banana/MIDI/Trie.hs b/src/Reactive/Banana/MIDI/Trie.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/MIDI/Trie.hs
@@ -0,0 +1,44 @@
+{- |
+This module is only needed for DeBruijn sequence generation.
+-}
+module Reactive.Banana.MIDI.Trie where
+
+import qualified Data.List as List
+import Data.Maybe.HT (toMaybe, )
+import Data.Maybe (mapMaybe, )
+
+import Prelude hiding (null, lookup)
+
+
+data Trie a b = Leaf b | Branch [(a, Trie a b)]
+   deriving (Show)
+
+full :: b -> [a] -> Int -> Trie a b
+full b _ 0 = Leaf b
+full b as n =
+   Branch $
+   map (\a -> (a, full b as (n-1))) as
+
+null :: Trie a [b] -> Bool
+null (Branch []) = True
+null (Leaf []) = True
+null _ = False
+
+delete :: (Eq a, Eq b) => b -> [a] -> Trie a [b] -> Trie a [b]
+delete b [] (Leaf bs) = Leaf (List.delete b bs)
+delete b (a:as) (Branch subTries) =
+   Branch $ mapMaybe
+      (\(key,trie) ->
+         fmap ((,) key) $
+            if key==a
+              then let delTrie = delete b as trie
+                   in  toMaybe (not (null delTrie)) delTrie
+              else Just trie)
+      subTries
+delete _ _ _ = error "Trie.delete: key and trie depth mismatch"
+
+lookup :: (Eq a) => [a] -> Trie a b -> Maybe b
+lookup [] (Leaf b) = Just b
+lookup (a:as) (Branch subTries) =
+   List.lookup a subTries >>= lookup as
+lookup _ _ = error "Trie.lookup: key and trie depth mismatch"
diff --git a/src/Reactive/Banana/MIDI/Utility.hs b/src/Reactive/Banana/MIDI/Utility.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/MIDI/Utility.hs
@@ -0,0 +1,54 @@
+-- basic reactive functions that could as well be in reactive-banana
+module Reactive.Banana.MIDI.Utility where
+
+import qualified Reactive.Banana.Combinators as RB
+
+import qualified Control.Monad.Trans.State as MS
+
+import Prelude hiding (sequence, )
+
+
+partition ::
+   (a -> Bool) -> RB.Event f a -> (RB.Event f a, RB.Event f a)
+partition p =
+   (\x ->
+      (fmap snd $ RB.filterE fst x,
+       fmap snd $ RB.filterE (not . fst) x)) .
+   fmap (\a -> (p a, a))
+
+mapMaybe ::
+   (a -> Maybe b) -> RB.Event f a -> RB.Event f b
+mapMaybe f = RB.filterJust . fmap f
+
+partitionMaybe ::
+   (a -> Maybe b) -> RB.Event f a -> (RB.Event f b, RB.Event f a)
+partitionMaybe f =
+   (\x ->
+      (mapMaybe fst x,
+       mapMaybe (\(mb,a) -> maybe (Just a) (const Nothing) mb) x)) .
+   fmap (\a -> (f a, a))
+
+bypass ::
+   (a -> Maybe b) ->
+   (RB.Event f a -> RB.Event f c) ->
+   (RB.Event f b -> RB.Event f c) ->
+   RB.Event f a -> RB.Event f c
+bypass p fa fb evs =
+   let (eb,ea) = partitionMaybe p evs
+   in  RB.union (fb eb) (fa ea)
+
+traverse ::
+   s -> (a -> MS.State s b) -> RB.Event f a ->
+   (RB.Event f b, RB.Behavior f s)
+traverse s f = sequence s . fmap f
+
+sequence ::
+   s -> RB.Event f (MS.State s a) ->
+   (RB.Event f a, RB.Behavior f s)
+sequence s =
+   RB.mapAccum s . fmap MS.runState
+
+
+mapAdjacent :: (a -> a -> b) -> a -> RB.Event f a -> RB.Event f b
+mapAdjacent f a0 =
+   fst . RB.mapAccum a0 . fmap (\new old -> (f old new, new))