diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,31 @@
+Copyright (c) 2012, 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-balsa.cabal b/reactive-balsa.cabal
new file mode 100644
--- /dev/null
+++ b/reactive-balsa.cabal
@@ -0,0 +1,87 @@
+Name:             reactive-balsa
+Version:          0.0
+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/MIDI
+Category:         Sound, Music
+Build-Type:       Simple
+Synopsis:         Programmatically edit MIDI events via ALSA and 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==6.12.3
+Cabal-Version:    >=1.6
+Build-Type:       Simple
+Source-Repository head
+  type:     darcs
+  location: http://code.haskell.org/~thielema/reactive-balsa/
+
+Source-Repository this
+  type:     darcs
+  location: http://code.haskell.org/~thielema/reactive-balsa/
+  tag:      0.0
+
+Flag splitBase
+  description: Choose the new smaller, split-up base package.
+
+Library
+  Build-Depends:
+    reactive-banana >=0.4.3 && <0.5,
+    midi-alsa >=0.2 && <0.3,
+    midi >=0.2 && <0.3,
+    alsa-seq >=0.5 && <0.6,
+    alsa-core >=0.5 && <0.6,
+    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.5,
+    transformers >=0.2 && <0.3
+  If flag(splitBase)
+    Build-Depends:
+      random >=1 && <2,
+      base >= 2 && <5
+  Else
+    Build-Depends:
+      base >= 1.0 && < 2
+
+  GHC-Options:      -Wall
+  Hs-Source-Dirs:   src
+  Exposed-Modules:
+    Reactive.Banana.ALSA.Sequencer
+    Reactive.Banana.ALSA.Example
+    Reactive.Banana.ALSA.KeySet
+    Reactive.Banana.ALSA.Pattern
+    Reactive.Banana.ALSA.Guitar
+    Reactive.Banana.ALSA.Training
+    Reactive.Banana.ALSA.Common
+  Other-Modules:
+    Reactive.Banana.ALSA.DeBruijn
+    Reactive.Banana.ALSA.Trie
diff --git a/src/Reactive/Banana/ALSA/Common.hs b/src/Reactive/Banana/ALSA/Common.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/ALSA/Common.hs
@@ -0,0 +1,745 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Reactive.Banana.ALSA.Common where
+
+import qualified Sound.ALSA.Sequencer as SndSeq
+import qualified Sound.ALSA.Sequencer.Address as Addr
+import qualified Sound.ALSA.Sequencer.Client as Client
+import qualified Sound.ALSA.Sequencer.Port as Port
+import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo
+import qualified Sound.ALSA.Sequencer.Queue as Queue
+import qualified Sound.ALSA.Sequencer.Event as Event
+import qualified Sound.ALSA.Sequencer.RealTime as RealTime
+
+import qualified Sound.MIDI.ALSA as MALSA
+import qualified Sound.MIDI.Message.Channel as ChannelMsg
+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
+import qualified Sound.MIDI.Message.Channel.Mode as Mode
+
+import Sound.MIDI.ALSA (normalNoteFromEvent, )
+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 Data.Accessor.Basic ((^.), (^=), )
+
+import Data.Maybe.HT (toMaybe, )
+import Data.Tuple.HT (mapFst, mapSnd, )
+
+import qualified Data.Map as Map
+
+import qualified Control.Monad.Trans.State as State
+import qualified Control.Monad.Trans.Reader as Reader
+import Control.Monad.Trans.Reader (ReaderT, )
+
+import qualified Numeric.NonNegative.Class as NonNeg
+
+import qualified Data.Monoid as Mn
+import Data.Ratio ((%), )
+import Data.Word (Word8, )
+import Data.Int (Int32, )
+
+import Prelude hiding (init, filter, reverse, )
+
+
+-- * helper functions
+
+data Handle =
+   Handle {
+      sequ :: SndSeq.T SndSeq.DuplexMode,
+      client :: Client.T,
+      portPublic, portPrivate :: Port.T,
+      queue :: Queue.T
+   }
+
+init :: IO Handle
+init = do
+   h <- SndSeq.open SndSeq.defaultName SndSeq.Block
+   Client.setName h "Haskell-Filter"
+   c <- Client.getId h
+   ppublic <-
+      Port.createSimple h "inout"
+         (Port.caps [Port.capRead, Port.capSubsRead,
+                     Port.capWrite, Port.capSubsWrite])
+         Port.typeMidiGeneric
+   pprivate <-
+      Port.createSimple h "private"
+         (Port.caps [Port.capRead, Port.capWrite])
+         Port.typeMidiGeneric
+   q <- Queue.alloc h
+   let hnd = Handle h c ppublic pprivate q
+   Reader.runReaderT setTimeStamping hnd
+   return hnd
+
+exit :: Handle -> IO ()
+exit h = do
+   _ <- Event.outputPending (sequ h)
+   Queue.free (sequ h) (queue h)
+   Port.delete (sequ h) (portPublic h)
+   Port.delete (sequ h) (portPrivate h)
+   SndSeq.close (sequ h)
+
+with :: ReaderT Handle IO a -> IO a
+with f =
+   SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do
+   Client.setName h "Haskell-Filter"
+   c <- Client.getId h
+   Port.withSimple h "inout"
+         (Port.caps [Port.capRead, Port.capSubsRead,
+                     Port.capWrite, Port.capSubsWrite])
+         Port.typeMidiGeneric $ \ppublic -> do
+   Port.withSimple h "private"
+         (Port.caps [Port.capRead, Port.capWrite])
+         Port.typeMidiGeneric $ \pprivate -> do
+   Queue.with h $ \q ->
+      flip Reader.runReaderT (Handle h c ppublic pprivate q) $
+      setTimeStamping >> f
+
+-- | make ALSA set the time stamps in incoming events
+setTimeStamping :: ReaderT Handle IO ()
+setTimeStamping = Reader.ReaderT $ \h -> do
+   info <- PortInfo.get (sequ h) (portPublic h)
+   PortInfo.setTimestamping info True
+   PortInfo.setTimestampReal info True
+   PortInfo.setTimestampQueue info (queue h)
+   PortInfo.set (sequ h) (portPublic h) info
+
+
+startQueue :: ReaderT Handle IO ()
+startQueue = Reader.ReaderT $ \h -> do
+   Queue.control (sequ h) (queue h) Event.QueueStart 0 Nothing
+   _ <- Event.drainOutput (sequ h)
+   return ()
+
+
+connect :: String -> String -> ReaderT Handle IO ()
+connect fromName toName = Reader.ReaderT $ \h -> do
+   from <- Addr.parse (sequ h) fromName
+   to   <- Addr.parse (sequ h) toName
+   SndSeq.connectFrom (sequ h) (portPublic h) from
+   SndSeq.connectTo (sequ h) (portPublic h) to
+
+connectTimidity :: ReaderT Handle IO ()
+connectTimidity =
+   connect "ReMOTE" "TiMidity"
+--   connect "E-MU Xboard61" "TiMidity"
+
+connectLLVM :: ReaderT Handle IO ()
+connectLLVM =
+--   connect "USB Midi Cable" "Haskell-LLVM-Synthesizer"
+   connect "E-MU Xboard61" "Haskell-LLVM-Synthesizer"
+--   connect "ReMOTE SL" "Haskell-LLVM-Synthesizer"
+--   connect "ReMOTE SL" "Haskell-Synthesizer"
+
+connectSuperCollider :: ReaderT Handle IO ()
+connectSuperCollider =
+   connect "E-MU Xboard61" "Haskell-Supercollider"
+
+
+
+-- * send single events
+
+sendNote :: Channel -> Time -> Velocity -> Pitch -> ReaderT Handle IO ()
+sendNote chan dur vel pit =
+   let note = simpleNote chan pit vel
+       t = incTime dur 0
+   in  do outputEvent 0 (Event.NoteEv Event.NoteOn note)
+          outputEvent t (Event.NoteEv Event.NoteOff note)
+
+sendKey :: Channel -> Bool -> Velocity -> Pitch -> ReaderT Handle IO ()
+sendKey chan noteOn vel pit =
+   outputEvent 0 $
+      Event.NoteEv
+         (if noteOn then Event.NoteOn else Event.NoteOff)
+         (simpleNote chan pit vel)
+
+sendController :: Channel -> Controller -> Int -> ReaderT Handle IO ()
+sendController chan ctrl val =
+   outputEvent 0 $
+      Event.CtrlEv Event.Controller $
+      MALSA.controllerEvent chan ctrl (fromIntegral val)
+
+sendProgram :: Channel -> Program -> ReaderT Handle IO ()
+sendProgram chan pgm =
+   outputEvent 0 $
+      Event.CtrlEv Event.PgmChange $
+      MALSA.programChangeEvent chan pgm
+
+sendMode :: Channel -> Mode.T -> ReaderT Handle IO ()
+sendMode chan mode =
+   outputEvent 0 $
+      Event.CtrlEv Event.Controller $
+      MALSA.modeEvent chan mode
+
+
+-- * 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 :: VoiceMsg.Velocity
+normalVelocity = VoiceMsg.normalVelocity
+
+
+
+-- * time
+
+{- |
+The 'Time' types are used instead of floating point types,
+because the latter ones caused unpredictable 'negative number' errors.
+The denominator must always be a power of 10,
+this way we can prevent unlimited grow of denominators.
+-}
+type TimeAbs = Rational
+newtype Time = Time {deconsTime :: Rational}
+   deriving (Show, Eq, Ord, Num, Fractional)
+
+consTime :: String -> Rational -> Time
+consTime msg x =
+   if x>=0
+     then Time x
+     else error $ msg ++ ": negative number"
+
+incTime :: Time -> TimeAbs -> TimeAbs
+incTime dt t = t + deconsTime dt
+
+scaleTimeCeiling :: Double -> Time -> Time
+scaleTimeCeiling k (Time t) =
+   Time $ ceiling (toRational k * t * nano) % nano
+
+nano :: Num a => a
+nano = 1000^(3::Int)
+
+instance Mn.Monoid Time where
+   mempty = Time 0
+   mappend (Time x) (Time y) = Time (x+y)
+
+instance NonNeg.C Time where
+   split = NonNeg.splitDefault deconsTime Time
+
+
+timeFromStamp :: Event.TimeStamp -> TimeAbs
+timeFromStamp t =
+   case t of
+      Event.RealTime rt ->
+         RealTime.toInteger rt % nano
+--      _ -> 0,
+      _ -> error "unsupported time stamp type"
+
+stampFromTime :: TimeAbs -> Event.TimeStamp
+stampFromTime t =
+   Event.RealTime (RealTime.fromInteger (round (t*nano)))
+
+
+
+defaultTempoCtrl :: (Channel,Controller)
+defaultTempoCtrl =
+   (ChannelMsg.toChannel 0, VoiceMsg.toController 16)
+
+
+
+-- * events
+
+{- |
+This class unifies several ways of handling multiple events at once.
+-}
+class Events ev where
+   flattenEvents :: ev -> [Future Event.Data]
+
+instance Events Event.Data where
+   flattenEvents ev = [Future 0 ev]
+
+instance Events ev => Events (Future ev) where
+   flattenEvents (Future dt ev) =
+      map (\(Future t e) -> Future (t+dt) e) $
+      flattenEvents ev
+
+instance Events ev => Events (Maybe ev) where
+   flattenEvents ev = maybe [] flattenEvents ev
+
+instance Events ev => Events [ev] where
+   flattenEvents = concatMap flattenEvents
+
+instance (Events ev0, Events ev1) => Events (ev0,ev1) where
+   flattenEvents (ev0,ev1) = flattenEvents ev0 ++ flattenEvents ev1
+
+instance (Events ev0, Events ev1, Events ev2) => Events (ev0,ev1,ev2) where
+   flattenEvents (ev0,ev1,ev2) =
+      flattenEvents ev0 ++ flattenEvents ev1 ++ flattenEvents ev2
+
+
+makeEvent :: Handle -> TimeAbs -> Event.Data -> Event.T
+makeEvent h t e =
+   Event.Cons
+      { Event.highPriority = False
+      , Event.tag = 0
+      , Event.queue = queue h
+      , Event.timestamp = stampFromTime t
+      , Event.source = Addr.Cons (client h) (portPublic h)
+      , Event.dest = Addr.subscribers
+      , Event.body = e
+      }
+
+makeEcho :: Handle -> TimeAbs -> Event.Custom -> Event.T
+makeEcho h t c =
+   Event.Cons
+      { Event.highPriority = False
+      , Event.tag = 0
+      , Event.queue = queue h
+      , Event.timestamp = stampFromTime t
+      , Event.source = Addr.Cons (client h) (portPrivate h)
+      , Event.dest   = Addr.Cons (client h) (portPrivate h)
+      , Event.body   = Event.CustomEv Event.Echo c
+      }
+
+
+outputEvent :: TimeAbs -> Event.Data -> ReaderT Handle IO ()
+outputEvent t ev = Reader.ReaderT $ \h ->
+   Event.output (sequ h) (makeEvent h t ev) >>
+   Event.drainOutput (sequ h) >>
+   return ()
+
+
+simpleNote :: Channel -> Pitch -> Velocity -> Event.Note
+simpleNote c p v =
+   Event.simpleNote
+      (MALSA.fromChannel c)
+      (MALSA.fromPitch p)
+      (MALSA.fromVelocity v)
+
+
+{- |
+The times are relative to the start time of the bundle
+and do not need to be ordered.
+-}
+data Future a = Future {futureTime :: Time, futureData :: a}
+type Bundle a = [Future a]
+type EventBundle = Bundle Event.T
+type EventDataBundle = Bundle Event.Data
+
+singletonBundle :: a -> Bundle a
+singletonBundle ev = [Future 0 ev]
+
+immediateBundle :: [a] -> Bundle a
+immediateBundle = map now
+
+now :: a -> Future a
+now = Future 0
+
+instance Functor Future where
+   fmap f (Future dt a) = Future dt $ f a
+
+
+-- * effects
+
+{- |
+Transpose 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 -> Event.Data -> Maybe Event.Data
+transpose d e =
+   case e of
+      Event.NoteEv notePart note ->
+         fmap (\p ->
+            Event.NoteEv notePart $
+            (MALSA.notePitch ^= p) note) $
+         increasePitch d $
+         note ^. MALSA.notePitch
+      _ -> Just e
+
+{- |
+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 ::
+   Event.Data -> Maybe Event.Data
+reverse e =
+   case e of
+      Event.NoteEv notePart note ->
+         fmap (\p ->
+            Event.NoteEv notePart $
+            (MALSA.notePitch ^= p) note) $
+         maybePitch $ (60+64 -) $ VoiceMsg.fromPitch $
+         note ^. MALSA.notePitch
+      _ -> Just e
+
+setChannel ::
+   Channel -> Event.Data -> Event.Data
+setChannel chan e =
+   case e of
+      Event.NoteEv notePart note ->
+         Event.NoteEv notePart $
+         (MALSA.noteChannel ^= chan) note
+      Event.CtrlEv ctrlPart ctrl ->
+         Event.CtrlEv ctrlPart $
+         (MALSA.ctrlChannel ^= chan) ctrl
+      _ -> e
+
+{- |
+> > replaceProgram [1,2,3,4] 5 [10,11,12,13]
+> (True,[10,11,2,13])
+-}
+replaceProgram :: [Int32] -> Int32 -> [Int32] -> (Bool, [Int32])
+replaceProgram (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:) $
+              replaceProgram ns (pgm-n) ps
+replaceProgram [] _ ps = (False, ps)
+
+programFromBanks :: [Int32] -> [Int32] -> Int32
+programFromBanks 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.
+
+@programAsBanks 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. @programAsBanks [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@.
+@programAsBanks [8,8]@ allows to select 64 instruments
+by 16 program change buttons,
+whereas @programAsBanks [8,4,4]@
+allows to address the full range of MIDI 128 instruments
+with the same number of buttons.
+-}
+programsAsBanks ::
+   [Int32] ->
+   Event.Data -> State.State [Int32] Event.Data
+programsAsBanks ns e =
+   case e of
+      Event.CtrlEv Event.PgmChange ctrl -> State.state $ \ps0 ->
+         let pgm = Event.ctrlValue ctrl
+             (valid, ps1) = replaceProgram ns pgm ps0
+         in  (Event.CtrlEv Event.PgmChange $
+              ctrl{Event.ctrlValue =
+                 if valid
+                   then programFromBanks ns ps1
+                   else pgm},
+              ps1)
+      _ -> return e
+
+
+nextProgram :: Event.Note -> State.State [Program] (Maybe Event.Data)
+nextProgram note =
+   State.state $ \pgms ->
+   case pgms of
+      pgm:rest ->
+        (Just $
+         Event.CtrlEv Event.PgmChange $
+         Event.Ctrl {
+            Event.ctrlChannel = Event.noteChannel note,
+            Event.ctrlParam = 0,
+            Event.ctrlValue = MALSA.fromProgram pgm},
+         rest)
+      [] -> (Nothing, [])
+
+seekProgram :: Int -> Program -> State.State [Program] (Maybe Event.Data)
+seekProgram maxSeek pgm =
+   fmap (const Nothing) $
+   State.modify $
+      uncurry (++) .
+      mapFst (dropWhile (pgm/=)) .
+      splitAt maxSeek
+
+
+{- |
+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.
+-}
+traversePrograms ::
+   Event.Data -> State.State [Program] (Maybe Event.Data)
+traversePrograms e =
+   case e of
+      Event.NoteEv notePart note ->
+         (case fst $ normalNoteFromEvent notePart note of
+             Event.NoteOn -> nextProgram note
+             _ -> return Nothing)
+      _ -> return Nothing
+
+{- |
+This function extends 'traversePrograms'.
+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.
+-}
+traverseProgramsSeek ::
+   Int ->
+   Event.Data -> State.State [Program] (Maybe Event.Data)
+traverseProgramsSeek maxSeek e =
+   case e of
+      Event.NoteEv notePart note ->
+         case fst $ normalNoteFromEvent notePart note of
+            Event.NoteOn -> nextProgram note
+            _ -> return Nothing
+      Event.CtrlEv Event.PgmChange ctrl ->
+         seekProgram maxSeek (ctrl ^. MALSA.ctrlProgram)
+      _ -> return Nothing
+
+reduceNoteVelocity ::
+   Word8 -> Event.Note -> Event.Note
+reduceNoteVelocity decay note =
+   note{Event.noteVelocity =
+      let vel = Event.noteVelocity note
+      in  if vel==0
+            then 0
+            else vel - min decay (vel-1)}
+
+delayAdd ::
+   Word8 -> Time -> Event.Data -> EventDataBundle
+delayAdd decay d e =
+   singletonBundle e ++
+   case e of
+      Event.NoteEv notePart note ->
+         [Future d $
+          Event.NoteEv notePart $
+          reduceNoteVelocity decay note]
+      _ -> []
+
+
+
+{- |
+Map NoteOn events to a controller value.
+This way you may play notes via the resonance frequency of a filter.
+-}
+controllerFromNote ::
+   (Int -> Int) ->
+   VoiceMsg.Controller ->
+   Event.Data -> Maybe Event.Data
+controllerFromNote f ctrl e =
+   case e of
+      Event.NoteEv notePart note ->
+         case fst $ normalNoteFromEvent notePart note of
+            Event.NoteOn ->
+               Just $
+               Event.CtrlEv Event.Controller $
+               MALSA.controllerEvent
+                  (note ^. MALSA.noteChannel)
+                  ctrl
+                  (fromIntegral $ f $
+                   fromIntegral $ VoiceMsg.fromPitch $
+                   note ^. MALSA.notePitch)
+            Event.NoteOff -> Nothing
+            _ -> Just e
+      _ -> Just e
+
+
+type KeySet   = Map.Map (Pitch, Channel) Velocity
+type KeyQueue = [((Pitch, Channel), Velocity)]
+
+eventsFromKey ::
+   Time -> Time -> ((Pitch, Channel), Velocity) ->
+   EventDataBundle
+eventsFromKey start dur ((pit,chan), vel) =
+   Future start (Event.NoteEv Event.NoteOn  $ simpleNote chan pit vel) :
+   Future (Mn.mappend start dur)
+                (Event.NoteEv Event.NoteOff $ simpleNote chan pit vel) :
+   []
+
+
+maybePitch :: Int -> Maybe Pitch
+maybePitch p =
+   toMaybe
+      (VoiceMsg.fromPitch minBound <= p  &&
+       p <= VoiceMsg.fromPitch maxBound)
+      (VoiceMsg.toPitch p)
+
+increasePitch :: Int -> Pitch -> Maybe Pitch
+increasePitch d p =
+   maybePitch $ d + VoiceMsg.fromPitch p
+
+subtractPitch :: Pitch -> Pitch -> Int
+subtractPitch p0 p1 =
+   VoiceMsg.fromPitch p1 - VoiceMsg.fromPitch p0
+
+
+-- | properFraction is useless for negative numbers
+splitFraction :: (RealFrac a) => a -> (Int, a)
+splitFraction x =
+   case floor x of
+      n -> (n, x - fromIntegral n)
+
+
+ctrlDur ::
+   (Time, Time) -> Int -> Time
+ctrlDur = ctrlDurExponential
+
+ctrlDurLinear ::
+   (Time, Time) -> Int -> Time
+ctrlDurLinear (minDur, maxDur) val =
+   minDur + (maxDur-minDur)
+      * fromIntegral val / 127
+
+ctrlDurExponential ::
+   (Time, Time) -> Int -> Time
+ctrlDurExponential (minDur, maxDur) val =
+   minDur *
+   Time
+      (powerRationalFromFloat 10 3
+         (fromRational $ deconsTime maxDur/deconsTime minDur :: Double)
+         (fromIntegral val / 127))
+
+{- |
+Compute @base ** expo@
+approximately to result type 'Rational'
+such that the result has a denominator which is a power of @digitBase@
+and a relative precision of numerator of @precision@ digits
+with respect to @digitBase@-ary numbers.
+-}
+powerRationalFromFloat ::
+   (Floating a, RealFrac a) =>
+   Int -> Int -> a -> a -> Rational
+powerRationalFromFloat digitBase precision base expo =
+   let digitBaseFloat = fromIntegral digitBase
+       {-
+       It would be nice, if properFraction would warrant @0<=x<1@.
+       Actually it can be @-1<x<=0@ in which case we lose one digit of precision.
+       -}
+       (n,x) = properFraction (logBase digitBaseFloat base * expo)
+       frac  = round (digitBaseFloat ** (x + fromIntegral precision))
+   in  fromInteger frac *
+       fromIntegral digitBase ^^ (n-precision)
+
+
+fraction :: RealFrac a => a -> a
+fraction x =
+   let n = floor x
+   in  x - fromIntegral (n::Integer)
+
+
+
+{-
+ctrlRange ::
+   (RealFrac b) =>
+   (b,b) -> (a -> b) -> (a -> Int)
+ctrlRange (l,u) f x =
+   round $
+   limit (0,127) $
+   127*(f x - l)/(u-l)
+-}
+
+
+-- * predicates - may be moved to midi-alsa package
+
+controllerMatch ::
+   Channel -> Controller -> Event.Ctrl -> Bool
+controllerMatch chan ctrl param =
+   Event.ctrlChannel param == MALSA.fromChannel chan &&
+   Event.ctrlParam   param == MALSA.fromController ctrl
+
+checkChannel ::
+   (Channel -> Bool) ->
+   (Event.Data -> Bool)
+checkChannel p e =
+   case e of
+      Event.NoteEv _notePart note ->
+         p (note ^. MALSA.noteChannel)
+      Event.CtrlEv Event.Controller ctrl ->
+         p (ctrl ^. MALSA.ctrlChannel)
+      _ -> False
+
+checkPitch ::
+   (Pitch -> Bool) ->
+   (Event.Data -> Bool)
+checkPitch p e =
+   case e of
+      Event.NoteEv _notePart note ->
+         p (note ^. MALSA.notePitch)
+      _ -> False
+
+checkController ::
+   (Controller -> Bool) ->
+   (Event.Data -> Bool)
+checkController p e =
+   case e of
+      Event.CtrlEv Event.Controller ctrlMode ->
+         case ctrlMode ^. MALSA.ctrlControllerMode of
+            MALSA.Controller ctrl _ -> p ctrl
+            _ -> False
+      _ -> False
+
+checkMode ::
+   (Mode.T -> Bool) ->
+   (Event.Data -> Bool)
+checkMode p e =
+   case e of
+      Event.CtrlEv Event.Controller ctrlMode ->
+         case ctrlMode ^. MALSA.ctrlControllerMode of
+            MALSA.Mode mode -> p mode
+            _ -> False
+      _ -> False
+
+checkProgram ::
+   (Program -> Bool) ->
+   (Event.Data -> Bool)
+checkProgram p e =
+   case e of
+      Event.CtrlEv Event.PgmChange ctrl ->
+         p (ctrl ^. MALSA.ctrlProgram)
+      _ -> False
+
+
+isAllNotesOff :: Event.Data -> Bool
+isAllNotesOff =
+   checkMode $ \mode ->
+      mode == Mode.AllSoundOff ||
+      mode == Mode.AllNotesOff
+
+
+
+-- * 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/ALSA/DeBruijn.hs b/src/Reactive/Banana/ALSA/DeBruijn.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/ALSA/DeBruijn.hs
@@ -0,0 +1,133 @@
+module Reactive.Banana.ALSA.DeBruijn where
+
+import qualified Reactive.Banana.ALSA.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 :: 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/ALSA/Example.hs b/src/Reactive/Banana/ALSA/Example.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/ALSA/Example.hs
@@ -0,0 +1,139 @@
+module Reactive.Banana.ALSA.Example where
+
+import qualified Reactive.Banana.ALSA.Training as Training
+import qualified Reactive.Banana.ALSA.Pattern as Pattern
+import qualified Reactive.Banana.ALSA.KeySet as KeySet
+import qualified Reactive.Banana.ALSA.Sequencer as Seq
+import qualified Reactive.Banana.ALSA.Common as Common
+import Reactive.Banana.ALSA.Common (program, channel, pitch, controller, )
+
+import qualified Reactive.Banana.Model as RB
+
+import qualified Sound.MIDI.ALSA as MALSA
+import Data.Accessor.Basic ((^.), )
+
+import qualified Sound.ALSA.Sequencer.Event as Event
+
+import qualified System.Random as Random
+
+import Control.Monad.Trans.Reader (ReaderT, )
+import Control.Monad (guard, )
+
+import Prelude hiding (reverse, )
+
+
+run, runLLVM, runTimidity :: ReaderT Common.Handle IO a -> IO a
+run = runTimidity
+runLLVM     x = Common.with $ Common.connectLLVM     >> x
+runTimidity x = Common.with $ Common.connectTimidity >> x
+
+
+pass,
+   transpose,
+   reverse,
+   latch,
+   groupLatch,
+   delay,
+   delayAdd,
+   delayTranspose,
+   cycleUp,
+   pingPong,
+--   binary,
+   crossSum,
+   bruijn,
+   random,
+   randomInversions,
+   serialCycleUp,
+   cyclePrograms,
+   sweep,
+   guitar :: ReaderT Common.Handle IO ()
+
+
+pass = Seq.run id
+transpose = Seq.run $ Seq.mapMaybe $ Common.transpose 2
+reverse = Seq.run $ Seq.mapMaybe $ Common.reverse
+latch = Seq.run (fst . Seq.latch)
+groupLatch = Seq.run (fst . Seq.pressed KeySet.groupLatch)
+delay = Seq.run (Seq.delay 0.2)
+delayAdd = Seq.run (Seq.delayAdd 0.2)
+delayTranspose = Seq.run $ \ evs ->
+   let proc p dt =
+          Seq.delay dt $
+          Seq.mapMaybe (Common.transpose p) evs
+       evs1 = proc  4 0.2
+       evs2 = proc  7 0.4
+       evs3 = proc 12 0.6
+   in foldl RB.union (fmap Common.now evs) [evs1, evs2, evs3]
+
+pattern ::
+   (KeySet.C set) =>
+   set -> Pattern.Mono set i -> ReaderT Common.Handle IO ()
+pattern set pat = Seq.runM $ \ _times evs -> do
+{-
+   let tempo = Seq.constant 0.2
+-}
+   let tempo =
+          uncurry Seq.tempoCtrl Common.defaultTempoCtrl 0.15 (0.5,0.05) evs
+   fmap (RB.union
+           (fmap Common.singletonBundle $
+            RB.filterE (not . Common.checkPitch (const True)) evs)) $
+      Seq.patternQuant 0.1 pat tempo (snd $ Seq.pressed set evs)
+
+serialCycleUp = pattern (KeySet.serialLatch 4) (Pattern.cycleUp 4)
+cycleUp  = pattern KeySet.groupLatch (Pattern.cycleUp 4)
+pingPong = pattern KeySet.groupLatch (Pattern.pingPong 4)
+-- binary   = pattern KeySet.groupLatch Pattern.binaryLegato
+crossSum = pattern KeySet.groupLatch (Pattern.crossSum 4)
+bruijn   = pattern KeySet.groupLatch (Pattern.bruijnPat 4 2)
+random   = pattern KeySet.groupLatch Pattern.random
+randomInversions
+         = pattern KeySet.groupLatch Pattern.randomInversions
+
+cyclePrograms = Seq.runM $ \times evs -> return $
+--   Seq.cyclePrograms (map program [13..17]) times evs
+   RB.union
+      (RB.filterJust $
+       Seq.cycleProgramsDefer 0.1 (map program [13..17]) times evs)
+      evs
+
+sweep =
+   Seq.runM $ \ _times evs ->
+      let c = channel 0
+          centerCC = controller 70
+          depthCC = controller 17
+          speedCC = controller 16
+      in  fmap (RB.union
+                   (RB.filterE (not. Common.checkController
+                                        (flip elem [centerCC, depthCC, speedCC])) evs) .
+                uncurry
+                   (Seq.makeControllerLinear c centerCC
+                      (Seq.controllerRaw c depthCC 64 evs)
+                      (Seq.controllerRaw c centerCC 64 evs)))
+          $
+          Seq.sweep
+             0.01 (sin . (2*pi*))
+             (Seq.controllerExponential c speedCC 0.3 (0.1, 1) evs)
+
+guitar =
+   Seq.run $ \ evs ->
+      let (trigger, keys) =
+             Seq.partitionMaybe
+                (\ev ->
+                   case ev of
+                      Event.NoteEv notePart note -> do
+                         guard $ (note ^. MALSA.notePitch) == pitch 84
+                         return $ notePart == Event.NoteOn
+                      _ -> Nothing)
+                evs
+      in  Seq.guitar 0.03 (snd $ Seq.pressed KeySet.groupLatch keys) trigger
+          `RB.union`
+          fmap Common.singletonBundle
+             (RB.filterE (not . Common.checkPitch (const True)) evs)
+
+trainer ::
+   (Random.RandomGen g) =>
+   g -> ReaderT Common.Handle IO ()
+trainer g =
+   Seq.runM $ \ times evs ->
+      fmap (RB.union (fmap Common.singletonBundle evs)) $
+      Seq.trainer (channel 0) 0.5 0.3 (Training.all g) times evs
diff --git a/src/Reactive/Banana/ALSA/Guitar.hs b/src/Reactive/Banana/ALSA/Guitar.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/ALSA/Guitar.hs
@@ -0,0 +1,37 @@
+-- cf. Haskore/Guitar
+module Reactive.Banana.ALSA.Guitar where
+
+import qualified Reactive.Banana.ALSA.Common as Common
+import Sound.MIDI.Message.Channel.Voice (Pitch, toPitch, )
+import Data.Maybe (mapMaybe, )
+
+
+class Transpose pitch where
+   getPitch :: pitch -> Pitch
+   transpose :: Int -> pitch -> Maybe pitch
+
+instance Transpose Pitch where
+   getPitch = id
+   transpose = Common.increasePitch
+
+
+mapChordToString ::
+   (Transpose pitch, Ord pitch) =>
+   [Pitch] -> [pitch] -> [pitch]
+mapChordToString strings chord =
+   mapMaybe (choosePitchForString chord) strings
+
+choosePitchForString ::
+   (Transpose pitch, Ord pitch) =>
+   [pitch] -> Pitch -> Maybe pitch
+choosePitchForString chord string =
+   let roundDown x d = x - mod x d
+       minAbove x =
+          transpose
+             (- roundDown (Common.subtractPitch string (getPitch x)) 12) x
+   in  maximum (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/ALSA/KeySet.hs b/src/Reactive/Banana/ALSA/KeySet.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/ALSA/KeySet.hs
@@ -0,0 +1,257 @@
+module Reactive.Banana.ALSA.KeySet where
+
+import qualified Reactive.Banana.ALSA.Common as Common
+
+import qualified Sound.ALSA.Sequencer.Event as Event
+
+import qualified Sound.MIDI.ALSA as MALSA
+import Sound.MIDI.ALSA (normalNoteFromEvent, )
+
+-- import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
+
+import Sound.MIDI.Message.Channel (Channel, )
+import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, )
+
+import qualified Data.Accessor.Monad.Trans.State as AccState
+-- import qualified Data.Accessor.Tuple as AccTuple
+import qualified Data.Accessor.Basic as Acc
+import Data.Accessor.Basic ((^.), (^=), )
+
+import qualified Control.Monad.Trans.State as MS
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import Data.Maybe (maybeToList, )
+
+
+{-
+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 [(Event.NoteEv, Event.Note)]
+   size :: set -> Int
+   toList :: set -> [((Pitch, Channel), Velocity)]
+   index :: Int -> set  -> Maybe ((Pitch, Channel), Velocity)
+   change ::
+      Event.NoteEv -> Event.Note ->
+      MS.State set [(Event.NoteEv, Event.Note)]
+
+
+
+newtype Pressed = Pressed {deconsPressed :: Map.Map (Pitch, Channel) Velocity}
+   deriving (Show)
+
+pressed :: Pressed
+pressed = Pressed Map.empty
+
+pressedAcc :: Acc.T Pressed (Map.Map (Pitch, Channel) Velocity)
+pressedAcc = Acc.fromWrapper Pressed deconsPressed
+
+instance C Pressed where
+   reset = AccState.lift pressedAcc releasePlayedKeys
+   size = Map.size . deconsPressed
+   toList = Map.toAscList . deconsPressed
+   index k (Pressed set) =
+      case drop k $ Map.toAscList set of
+         x:_ -> Just x
+         _ -> Nothing
+   change notePart note =
+      let key =
+             (note ^. MALSA.notePitch,
+              note ^. MALSA.noteChannel)
+      in  do
+             case normalNoteFromEvent notePart note of
+                (Event.NoteOn, vel) ->
+                   MS.modify $ Pressed . Map.insert key vel . deconsPressed
+                (Event.NoteOff,  _) ->
+                   MS.modify $ Pressed . Map.delete key . deconsPressed
+                _ -> return ()
+             return [(notePart, note)]
+
+
+
+newtype Latch = Latch {deconsLatch :: Map.Map (Pitch, Channel) Velocity}
+   deriving (Show)
+
+latch :: Latch
+latch = Latch Map.empty
+
+latchAcc :: Acc.T Latch (Map.Map (Pitch, Channel) Velocity)
+latchAcc = Acc.fromWrapper Latch deconsLatch
+
+latchChange ::
+   Event.NoteEv ->
+   Event.Note ->
+   MS.State Latch (Maybe (Event.NoteEv, Event.Note))
+latchChange notePart note =
+   case normalNoteFromEvent notePart note of
+      (Event.NoteOn, vel) -> do
+         let key =
+                (note ^. MALSA.notePitch,
+                 note ^. MALSA.noteChannel)
+             newNote =
+                (MALSA.noteVelocity ^= vel) note
+         isPressed <- MS.gets (Map.member key . deconsLatch)
+         if isPressed
+           then
+              MS.modify (Latch . Map.delete key . deconsLatch) >>
+              return (Just (Event.NoteOff, newNote))
+           else
+              MS.modify (Latch . Map.insert key vel . deconsLatch) >>
+              return (Just (Event.NoteOn, newNote))
+      (Event.NoteOff, _vel) ->
+         return Nothing
+      _ -> return Nothing
+
+instance C Latch where
+   reset = AccState.lift latchAcc releasePlayedKeys
+   size = Map.size . deconsLatch
+   toList = Map.toAscList . deconsLatch
+   index k (Latch set) =
+      case drop k $ Map.toAscList set of
+         x:_ -> Just x
+         _ -> Nothing
+   change notePart note =
+      fmap maybeToList $ latchChange notePart note
+
+
+
+data GroupLatch =
+   GroupLatch {
+      groupLatchPressed_ {- input -} :: Set.Set (Pitch, Channel),
+      groupLatchPlayed_ {- output -} :: Map.Map (Pitch, Channel) Velocity
+   } deriving (Show)
+
+groupLatch :: GroupLatch
+groupLatch = GroupLatch Set.empty Map.empty
+
+groupLatchPressed :: Acc.T GroupLatch (Set.Set (Pitch, Channel))
+groupLatchPressed =
+   Acc.fromSetGet
+      (\mp grp -> grp{groupLatchPressed_ = mp})
+      groupLatchPressed_
+
+groupLatchPlayed :: Acc.T GroupLatch (Map.Map (Pitch, Channel) Velocity)
+groupLatchPlayed =
+   Acc.fromSetGet
+      (\mp grp -> grp{groupLatchPlayed_ = mp})
+      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 = AccState.lift groupLatchPlayed releasePlayedKeys
+   size = Map.size . groupLatchPlayed_
+   toList = Map.toAscList . groupLatchPlayed_
+   index k set =
+      case drop k $ Map.toAscList $ groupLatchPlayed_ set of
+         x:_ -> Just x
+         _ -> Nothing
+   change notePart note =
+      let key =
+             (note ^. MALSA.notePitch,
+              note ^. MALSA.noteChannel)
+      in  case normalNoteFromEvent notePart note of
+             (Event.NoteOn, vel) -> do
+                pressd <- AccState.get groupLatchPressed
+                noteOffs <-
+                   if Set.null pressd
+                     then AccState.lift groupLatchPlayed 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 [(Event.NoteOn, note)]
+                return $
+                   noteOffs ++ noteOn
+             (Event.NoteOff, _vel) ->
+                AccState.modify groupLatchPressed (Set.delete key) >>
+                return []
+             _ -> return []
+
+
+
+data SerialLatch =
+   SerialLatch {
+      serialLatchSize_ :: Int,
+      serialLatchCursor_ :: Int,
+      serialLatchPlayed_ :: Map.Map Int ((Pitch, Channel), Velocity)
+   } deriving (Show)
+
+serialLatch :: Int -> SerialLatch
+serialLatch num = SerialLatch num 0 Map.empty
+
+serialLatchCursor :: Acc.T SerialLatch Int
+serialLatchCursor =
+   Acc.fromSetGet
+      (\mp grp -> grp{serialLatchCursor_ = mp})
+      serialLatchCursor_
+
+serialLatchPlayed :: Acc.T SerialLatch (Map.Map Int ((Pitch, Channel), Velocity))
+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)
+   size = serialLatchSize_
+   toList = Map.elems . serialLatchPlayed_
+   index k = Map.lookup k . serialLatchPlayed_
+   change notePart note =
+      let key =
+             (note ^. MALSA.notePitch,
+              note ^. MALSA.noteChannel)
+      in  case normalNoteFromEvent notePart note of
+             (Event.NoteOn, vel) -> 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)
+                          ++ [(notePart, note)]
+             (Event.NoteOff, _vel) -> return []
+             _ -> return [(notePart, note)]
+
+releasePlayedKeys ::
+   MS.State
+      (Map.Map (Pitch, Channel) Velocity)
+      [(Event.NoteEv, Event.Note)]
+releasePlayedKeys =
+   fmap (map (uncurry releaseKey) . Map.toList) $
+   AccState.getAndModify Acc.self (const Map.empty)
+
+releaseKey ::
+   (Pitch, Channel) ->
+   Velocity ->
+   (Event.NoteEv, Event.Note)
+releaseKey (p,c) vel =
+   (Event.NoteOff, Common.simpleNote c p vel)
diff --git a/src/Reactive/Banana/ALSA/Pattern.hs b/src/Reactive/Banana/ALSA/Pattern.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/ALSA/Pattern.hs
@@ -0,0 +1,291 @@
+module Reactive.Banana.ALSA.Pattern where
+
+import qualified Reactive.Banana.ALSA.KeySet as KeySet
+import qualified Reactive.Banana.ALSA.DeBruijn as DeBruijn
+
+import Reactive.Banana.ALSA.Common
+          (Time, EventDataBundle, eventsFromKey, splitFraction, increasePitch, )
+
+import qualified Data.EventList.Relative.TimeBody as EventList
+import Data.EventList.Relative.MixedBody ((/.), (./), )
+
+import qualified Data.List.HT as ListHT
+import qualified Data.List as List
+
+import qualified System.Random as Rnd
+
+import Control.Monad (guard, )
+
+import Prelude hiding (init, filter, reverse, )
+
+
+
+-- * selectors
+
+type Selector set i = i -> Time -> set -> EventDataBundle
+
+data Mono set i = Mono (Selector set i) [i]
+
+
+data IndexNote i = IndexNote Int i
+   deriving (Show, Eq, Ord)
+
+item :: i -> Int -> IndexNote i
+item i n = IndexNote n i
+
+data Poly set i = Poly (Selector set 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 =>
+   Selector set Int
+selectFromOctaveChord d dur chord =
+   maybe [] (eventsFromKey 0 dur) $ do
+      let size = KeySet.size chord
+      guard (size>0)
+      let (q,r) = divMod d size
+      ((pit,chan), vel) <- KeySet.index r chord
+      transPitch <- increasePitch (12*q) pit
+      return ((transPitch,chan), vel)
+
+selectFromChord ::
+   KeySet.C set =>
+   Selector set Int
+selectFromChord n dur chord =
+   maybe [] (eventsFromKey 0 dur) (KeySet.index n chord)
+
+selectFromChordRatio ::
+   KeySet.C set =>
+   Selector set Double
+selectFromChordRatio d dur chord =
+   selectFromChord (floor $ d * fromIntegral (KeySet.size chord)) dur chord
+
+
+selectInversion ::
+   KeySet.C set =>
+   Selector set Double
+selectInversion d dur chord =
+   let makeNote octave ((pit,chan), vel) =
+          maybe []
+             (\pitchTrans -> eventsFromKey 0 dur ((pitchTrans,chan), vel))
+             (increasePitch (octave*12) pit)
+       (oct,p) = splitFraction d
+       pivot = floor (p * fromIntegral (KeySet.size chord))
+       (low,high) = splitAt pivot $ KeySet.toList chord
+   in  concatMap (makeNote oct) high ++
+       concatMap (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]
+
+{- |
+@bruijn n k@ is a sequence with length n^k
+where @cycle (bruijn n k)@ contains all n-ary numbers with k digits as infixes.
+The function computes the lexicographically smallest of such sequences.
+-}
+bruijn :: Int -> Int -> [Int]
+bruijn n k  =  DeBruijn.lexLeast n k
+
+
+cycleUp, cycleDown, pingPong, crossSum ::
+   KeySet.C set =>
+   Int -> Mono set Int
+cycleUp   number =
+   Mono selectFromChord (cycle [0..(number-1)])
+cycleDown number =
+   Mono selectFromChord (cycle $ List.reverse [0..(number-1)])
+pingPong  number =
+   Mono selectFromChord $
+      cycle $ [0..(number-2)] ++ List.reverse [1..(number-1)]
+crossSum  number =
+   Mono selectFromChord (flipSeq number)
+
+bruijnPat ::
+   KeySet.C set =>
+   Int -> Int -> Mono set Int
+bruijnPat n k =
+   Mono selectFromChord $ cycle $ bruijn n k
+
+{-
+We should increment the index at each step and wrap around according to current chord.
+This way we avoid jumps in the pattern.
+
+cycleUpAuto, cycleDownAuto, pingPongAuto, crossSumAuto ::
+   KeySet.C set =>
+   Mono set Integer
+cycleUpAuto =
+   Mono
+      (\ d dur chord ->
+          selectFromChord (mod d (fromIntegral $ length chord)) dur chord)
+      [0..]
+cycleDownAuto =
+   Mono
+      (\ d dur chord ->
+          selectFromChord (mod d (fromIntegral $ length chord)) dur chord)
+      [0,(-1)..]
+pingPongAuto =
+   Mono
+      (\ d dur chord ->
+          let s = 2 * (fromIntegral (length chord) - 1)
+              m =
+                if s<=0
+                  then 0
+                  else min (mod d s) (mod (-d) s)
+          in  selectFromChord m dur chord)
+      [0..]
+crossSumAuto =
+   Mono
+      (\ d dur chord ->
+          let m = fromIntegral $ length chord
+              s =
+                if m <= 1
+                  then 0
+                  else sum $ decomposePositional m d
+          in  selectFromChord (mod s m) dur chord)
+      [0..]
+-}
+
+binaryStaccato, binaryLegato, binaryAccident ::
+   KeySet.C set => Poly set Int
+{-
+binary number Pattern.Mono:
+   0
+   1
+   0 1
+   2
+   0 2
+   1 2
+   0 1 2
+   3
+-}
+binaryStaccato =
+   Poly
+      selectFromChord
+      (EventList.fromPairList $
+       zip (0 : repeat 1) $
+       map
+          (map (IndexNote 1 . fst) .
+           List.filter ((/=0) . snd) .
+           zip [0..] .
+           decomposePositional 2)
+          [0..])
+
+binaryLegato =
+   Poly
+      selectFromChord
+      (EventList.fromPairList $
+       zip (0 : repeat 1) $
+       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 =
+   Poly
+      selectFromChord
+      (EventList.fromPairList $
+       zip (0 : repeat 1) $
+       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 =>
+   Int -> Mono set Int
+cycleUpOctave number =
+   Mono selectFromOctaveChord (cycle [0..(number-1)])
+
+random, randomInversions ::
+   KeySet.C set => Mono set Double
+random =
+   Mono selectFromChordRatio (Rnd.randomRs (0,1) (Rnd.mkStdGen 42))
+
+randomInversions =
+   inversions $
+   map sum $
+   ListHT.sliceVertical 3 $
+   Rnd.randomRs (-1,1) $
+   Rnd.mkStdGen 42
+
+cycleUpInversions :: KeySet.C set => Int -> Mono set Double
+cycleUpInversions n =
+   inversions $ cycle $ take n $
+   map (\i -> fromInteger i / fromIntegral n) [0..]
+
+inversions :: KeySet.C set => [Double] -> Mono set Double
+inversions rs =
+   Mono selectInversion rs
+
+
+
+-- * 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/ALSA/Sequencer.hs b/src/Reactive/Banana/ALSA/Sequencer.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/ALSA/Sequencer.hs
@@ -0,0 +1,714 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Reactive.Banana.ALSA.Sequencer where
+
+import qualified Reactive.Banana.ALSA.Common as Common
+import qualified Reactive.Banana.ALSA.Guitar as Guitar
+import qualified Reactive.Banana.ALSA.Pattern as Pattern
+import qualified Reactive.Banana.ALSA.KeySet as KeySet
+
+import qualified Reactive.Banana as RB
+import qualified Reactive.Banana.Model as RBM
+import qualified Reactive.Banana.Implementation as RBI
+import Reactive.Banana.Model ((<@>), )
+
+import qualified Sound.ALSA.Sequencer.Event as Event
+import qualified Sound.ALSA.Sequencer.Address as Addr
+
+import qualified Sound.MIDI.ALSA.Check as Check
+import qualified Sound.MIDI.ALSA as MALSA
+import Sound.MIDI.ALSA (normalNoteFromEvent, )
+
+import Sound.MIDI.Message.Channel (Channel, )
+import Sound.MIDI.Message.Channel.Voice
+          (Pitch, Controller, Velocity, Program, normalVelocity, )
+
+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 Data.Accessor.Basic ((^.), )
+
+import qualified Control.Monad.Trans.Class as MT
+import qualified Control.Monad.Trans.State as MS
+import qualified Control.Monad.Trans.Reader as MR
+import Control.Monad.Trans.Reader (ReaderT(ReaderT), )
+import Control.Monad.IO.Class (MonadIO, liftIO, )
+import Control.Monad.Fix (MonadFix, )
+import Control.Monad (forever, when, )
+import Control.Monad.HT ((<=<), )
+import Control.Applicative (Applicative, pure, (<*>), )
+import Data.Tuple.HT (mapPair, )
+import Data.Ord.HT (comparing, limit, )
+import Data.Maybe.HT (toMaybe, )
+import Data.Word (Word32, )
+
+import qualified Data.Map as Map
+import qualified Data.List as List
+import qualified Data.List.Match as Match
+
+import Prelude hiding (sequence, )
+
+
+
+-- * make ALSA reactive
+
+newtype Reactor a =
+   Reactor {
+      runReactor ::
+         MR.ReaderT
+            (RBI.AddHandler Event.T, Common.Handle)
+            (MS.StateT Schedule RBI.NetworkDescription)
+            a
+   } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
+
+newtype Schedule = Schedule Word32
+   deriving (Eq, Ord, Enum, Show)
+
+
+getHandle :: Reactor Common.Handle
+getHandle = Reactor $ MR.asks snd
+
+run ::
+   (Common.Events ev) =>
+   (RB.Event Event.Data -> RB.Event ev) ->
+   ReaderT Common.Handle IO ()
+run f =
+   runM (\ _ts xs -> return $ f xs)
+
+runM ::
+   (Common.Events ev) =>
+   (RB.Behavior Common.TimeAbs ->
+    RB.Event Event.Data -> Reactor (RB.Event ev)) ->
+   ReaderT Common.Handle IO ()
+runM f = do
+   Common.startQueue
+   MR.ReaderT $ \h -> do
+      (addEventHandler, runEventHandler) <- RBI.newAddHandler
+      (addEchoHandler,  runEchoHandler)  <- RBI.newAddHandler
+      (addTimeHandler,  runTimeHandler)  <- RBI.newAddHandler
+      RBI.actuate <=< RBI.compile $ do
+         time <-
+            fmap (RB.stepper 0) $
+            RBI.fromAddHandler addTimeHandler
+         evs <-
+            flip MS.evalStateT (Schedule 0)
+              . flip MR.runReaderT (addEchoHandler, h)
+              . runReactor
+              . f time
+              . fmap Event.body
+            =<< RBI.fromAddHandler addEventHandler
+         RBI.reactimate $
+            pure (outputEvents h) <*> time <@> evs
+      forever $ do
+         ev <- Event.input (Common.sequ h)
+         runTimeHandler $ Common.timeFromStamp $ Event.timestamp ev
+         if Event.dest ev == Addr.Cons (Common.client h) (Common.portPrivate h)
+           then debug "input: echo"  >> runEchoHandler ev
+           else debug "input: event" >> runEventHandler ev
+
+outputEvents ::
+   Common.Events evs =>
+   Common.Handle -> Common.TimeAbs -> evs -> IO ()
+outputEvents h time evs = do
+   mapM_ (Event.output (Common.sequ h)) $
+      map (\(Common.Future dt body) ->
+             Common.makeEvent h (Common.incTime dt time) body) $
+      Common.flattenEvents evs
+   _ <- Event.drainOutput (Common.sequ h)
+   return ()
+
+
+checkSchedule :: Schedule -> Event.T -> Bool
+checkSchedule (Schedule sched) echo =
+   maybe False (sched ==) $ do
+      Event.CustomEv Event.Echo s <- Just $ Event.body echo
+      let Event.Custom echoSchedule 0 0 = s
+      return echoSchedule
+
+scheduleData :: Schedule -> Event.Custom
+scheduleData (Schedule sched) =
+   Event.Custom sched 0 0
+
+reactimate :: RB.Event (IO ()) -> Reactor ()
+reactimate evs =
+   Reactor $ MT.lift $ MT.lift $ RB.reactimate evs
+
+sendEchos :: Common.Handle -> Schedule -> [Common.TimeAbs] -> IO ()
+sendEchos h sched echos = do
+   flip mapM_ echos $ \time ->
+      Event.output (Common.sequ h) $
+      Common.makeEcho h time (scheduleData sched)
+   _ <- Event.drainOutput (Common.sequ h)
+   debug "echos sent"
+
+reserveSchedule ::
+   Reactor (RB.Event Common.TimeAbs, [Common.TimeAbs] -> IO ())
+reserveSchedule = Reactor $ ReaderT $ \(addH,h) -> do
+   sched <- MS.get
+   MS.modify succ
+   eEcho <-
+      MT.lift $
+      fmap (fmap (Common.timeFromStamp . Event.timestamp) .
+            RB.filterE (checkSchedule sched)) $
+      RBI.fromAddHandler addH
+   return (eEcho, sendEchos h sched)
+
+
+scheduleQueue :: Show a =>
+   RB.Behavior Common.TimeAbs ->
+   RB.Event (Common.Bundle a) -> Reactor (RB.Event a)
+scheduleQueue times e = do
+   (eEcho, send) <- 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, debug $ "got echo for event: " ++ show x),
+                 ({- Common.incTime t lastTime -}
+                  echoTime, xs)))
+       add time new = do
+          MS.modify $ \(lastTime, old) ->
+             (time,
+              Common.mergeStable
+                 (EventList.fromAbsoluteEventList $
+                  EventListAbs.fromPairList $
+                  map (\(Common.Future dt a) -> (dt,a)) $
+                  List.sortBy (comparing Common.futureTime) new) $
+              EventList.decreaseStart
+                 (Common.consTime "Causal.process.decreaseStart"
+                     (time-lastTime)) old)
+          return (Nothing, send $ map (flip Common.incTime time . Common.futureTime) new)
+
+       -- (Queue that keeps track of events to schedule
+       -- , duration of the new alarm if applicable) 
+       (eEchoEvent, _bQueue) =
+          sequence (0, EventList.empty) $
+          RB.union (fmap remove eEcho) (pure add <*> times <@> e)
+
+   reactimate $ fmap snd eEchoEvent
+   return $ RB.filterJust $ fmap fst eEchoEvent
+
+
+debug :: String -> IO ()
+debug =
+   const $ return ()
+   -- putStrLn
+
+
+-- * utility functions
+
+mapMaybe ::
+   (RB.FRP f) => (a -> Maybe b) -> RBM.Event f a -> RBM.Event f b
+mapMaybe f = RB.filterJust . fmap f
+
+partitionMaybe ::
+   (RB.FRP f) =>
+   (a -> Maybe b) -> RBM.Event f a -> (RBM.Event f b, RBM.Event f a)
+partitionMaybe f =
+   (\x ->
+      (mapMaybe fst x,
+       mapMaybe (\(mb,a) -> maybe (Just a) (const Nothing) mb) x)) .
+   fmap (\a -> (f a, a))
+
+traverse ::
+   (RB.FRP f) =>
+   s -> (a -> MS.State s b) -> RBM.Event f a ->
+   (RBM.Event f b, RBM.Behavior f s)
+traverse s f = sequence s . fmap f
+
+sequence ::
+   (RB.FRP f) =>
+   s -> RBM.Event f (MS.State s a) ->
+   (RBM.Event f a, RBM.Behavior f s)
+sequence s =
+   RB.mapAccum s . fmap MS.runState
+
+constant ::
+   (RB.FRP f) =>
+   a -> RBM.Behavior f a
+constant a = RB.stepper a RB.never
+
+
+-- * examples
+
+{- |
+register pressed keys
+-}
+pressed ::
+   (RB.FRP f, KeySet.C set) =>
+   set ->
+   RBM.Event f Event.Data ->
+   (RBM.Event f [Event.Data], RBM.Behavior f set)
+pressed empty =
+   traverse empty
+      (\e ->
+         case e of
+            Event.NoteEv notePart note ->
+               fmap (map (uncurry Event.NoteEv)) $
+               KeySet.change notePart note
+            body ->
+               if Common.isAllNotesOff body
+                 then fmap (map (uncurry Event.NoteEv))
+                      KeySet.reset
+                 else return [e])
+
+latch ::
+   (RB.FRP f) =>
+   RBM.Event f Event.Data ->
+   (RBM.Event f Event.Data, RBM.Behavior f (Map.Map (Pitch, Channel) Velocity))
+latch =
+   mapPair (RB.filterJust, fmap KeySet.deconsLatch) .
+   traverse KeySet.latch
+      (\e -> do
+         _ <- case e of
+            Event.NoteEv notePart note ->
+               fmap (fmap (uncurry Event.NoteEv)) $
+               KeySet.latchChange notePart note
+            _ -> return Nothing
+         return $ Just e)
+
+{- |
+Demonstration of scheduleQueue,
+but for real use prefer 'delay',
+since this uses precisely timed delivery by ALSA.
+-}
+delaySchedule ::
+   Common.Time ->
+   RB.Behavior Common.TimeAbs ->
+   RB.Event Event.Data -> Reactor (RB.Event Event.Data)
+delaySchedule dt times =
+   scheduleQueue times .
+   fmap ((:[]) . Common.Future dt)
+
+delay ::
+   Common.Time ->
+   RB.Event ev -> RB.Event (Common.Future ev)
+delay dt =
+   fmap (Common.Future dt)
+
+delayAdd ::
+   Common.Time ->
+   RB.Event ev -> RB.Event (Common.Future ev)
+delayAdd dt evs =
+   RB.union (fmap Common.now evs) $ delay dt evs
+
+{- |
+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 ::
+   RB.Behavior Common.Time -> Reactor (RB.Event Common.TimeAbs)
+beat tempo = do
+   (eEcho, send) <- reserveSchedule
+
+   liftIO $ send [0]
+
+   let next dt time =
+          (time, send [Common.incTime dt time])
+
+       eEchoEvent =
+          RB.apply (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 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 ::
+   Common.Time ->
+   RB.Behavior Common.Time -> Reactor (RB.Event Common.TimeAbs)
+beatQuant maxDur tempo = do
+   (eEcho, send) <- reserveSchedule
+
+   liftIO $ send [0]
+
+   let next dt time = do
+          complete <- MS.gets (>=1)
+          when complete $ MS.modify (subtract 1)
+          portion <- MS.get
+          let dur = limit (0,maxDur) (Common.scaleTimeCeiling (1-portion) dt)
+          MS.modify (fromRational (Common.deconsTime dur / Common.deconsTime dt) +)
+          return
+             (toMaybe complete time,
+              send [Common.incTime dur time]
+              {- print (dur, time, dt, portion) -} )
+
+       eEchoEvent =
+          fst $ sequence 0 $ RB.apply (fmap next tempo) eEcho
+
+   reactimate $ fmap snd eEchoEvent
+   return $ RB.filterJust $ fmap fst eEchoEvent
+
+
+tempoCtrl ::
+   (Check.C ev) =>
+   Channel ->
+   Controller ->
+   Common.Time -> (Common.Time, Common.Time) ->
+   RB.Event ev -> RB.Behavior Common.Time
+tempoCtrl chan ctrl deflt (lower,upper) =
+   RB.stepper deflt .
+   RB.filterJust .
+   fmap (fmap (Common.ctrlDur (lower, upper))
+          . Check.controller chan ctrl)
+
+
+controllerRaw ::
+   (Check.C ev) =>
+   Channel ->
+   Controller ->
+   Int ->
+   RB.Event ev -> RB.Behavior Int
+controllerRaw chan ctrl deflt =
+   RB.stepper deflt . RB.filterJust .
+   fmap (Check.controller chan ctrl)
+
+controllerExponential ::
+   (Floating a, Check.C ev) =>
+   Channel ->
+   Controller ->
+   a -> (a,a) ->
+   RB.Event ev -> RB.Behavior a
+controllerExponential chan ctrl deflt (lower,upper) =
+   let k = log (upper/lower) / 127
+   in  RB.stepper deflt .
+       RB.filterJust .
+       fmap (fmap ((lower*) . exp . (k*) . fromIntegral)
+              . Check.controller chan ctrl)
+
+controllerLinear ::
+   (Fractional a, Check.C ev) =>
+   Channel ->
+   Controller ->
+   a -> (a,a) ->
+   RB.Event ev -> RB.Behavior a
+controllerLinear chan ctrl deflt (lower,upper) =
+   let k = (upper-lower) / 127
+   in  RB.stepper deflt .
+       RB.filterJust .
+       fmap (fmap ((lower+) . (k*) . fromIntegral)
+              . Check.controller chan ctrl)
+
+
+pattern ::
+   (KeySet.C set) =>
+   Pattern.Mono set i ->
+   RB.Behavior Common.Time ->
+   RB.Behavior set ->
+   Reactor (RB.Event Common.EventDataBundle)
+pattern pat tempo sets =
+   fmap (patternAux pat tempo sets) $
+   beat tempo
+
+patternQuant ::
+   (KeySet.C set) =>
+   Common.Time ->
+   Pattern.Mono set i ->
+   RB.Behavior Common.Time ->
+   RB.Behavior set ->
+   Reactor (RB.Event Common.EventDataBundle)
+patternQuant quant pat tempo sets =
+   fmap (patternAux pat tempo sets) $
+   beatQuant quant tempo
+
+patternAux ::
+   (KeySet.C set) =>
+   Pattern.Mono set i ->
+   RB.Behavior Common.Time ->
+   RB.Behavior set ->
+   RB.Event Common.TimeAbs ->
+   RB.Event Common.EventDataBundle
+patternAux (Pattern.Mono select ixs) tempo sets times =
+   pure
+      (\dur set i -> select i dur set)
+      <*> tempo
+      <*> sets
+      <@> (RB.filterJust $ fst $
+           RB.mapAccum ixs $
+           fmap (\ _time is ->
+              case is of
+                 [] -> (Nothing, is)
+                 i:rest -> (Just i, rest))
+           times)
+
+
+
+cyclePrograms ::
+   [Program] ->
+   RB.Event Event.Data -> RB.Event (Maybe Event.Data)
+cyclePrograms pgms =
+   fst .
+   traverse (cycle pgms)
+      (Common.traverseProgramsSeek (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 ::
+   Common.Time -> [Program] ->
+   RB.Behavior Common.TimeAbs ->
+   RB.Event Event.Data -> RB.Event (Maybe Event.Data)
+cycleProgramsDefer defer pgms times =
+   fst .
+   traverse (cycle pgms, 0)
+      (\(eventTime,e) ->
+         case e of
+            Event.CtrlEv Event.PgmChange ctrl ->
+               AccState.lift AccTuple.first $
+                  Common.seekProgram (length pgms) (ctrl ^. MALSA.ctrlProgram)
+            Event.NoteEv notePart note -> do
+               blockTime <- MS.gets snd
+               if eventTime < blockTime
+                 then return Nothing
+                 else
+                    case fst $ normalNoteFromEvent notePart note of
+                       Event.NoteOn -> do
+                          AccState.set AccTuple.second $
+                             Common.incTime defer eventTime
+                          AccState.lift AccTuple.first $
+                             Common.nextProgram note
+                       _ -> return Nothing
+            _ -> return Nothing) .
+   RB.apply (fmap (,) times)
+
+
+newtype PitchChannel =
+   PitchChannel ((Pitch, Channel), Velocity)
+   deriving (Show)
+
+instance Eq PitchChannel where
+   (PitchChannel ((p0,_), _)) == (PitchChannel ((p1,_), _)) =
+      p0 == p1
+
+instance Ord PitchChannel where
+   compare (PitchChannel ((p0,_), _)) (PitchChannel ((p1,_), _)) =
+      compare p0 p1
+
+instance Guitar.Transpose PitchChannel where
+   getPitch (PitchChannel ((p,_), _)) = p
+   transpose d (PitchChannel ((p,c),v)) = do
+      p' <- Common.increasePitch d p
+      return $ PitchChannel ((p',c), v)
+
+noteSequence ::
+   Common.Time ->
+   Event.NoteEv -> [Event.Note] ->
+   Common.EventDataBundle
+noteSequence stepTime onOff =
+   zipWith Common.Future (iterate (stepTime+) 0) .
+   map (Event.NoteEv onOff)
+
+{- |
+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 ::
+   (KeySet.C set) =>
+   Common.Time ->
+   RB.Behavior set ->
+   RB.Event Bool ->
+   RB.Event Common.EventDataBundle
+guitar stepTime pressd trigger =
+   fst $
+   traverse []
+      (\(set, on) -> do
+         played <- MS.get
+         let toPlay =
+                case KeySet.toList set of
+                   [] -> []
+                   list ->
+                      fmap (\(PitchChannel ((p,c),v)) ->
+                         MALSA.noteEvent c p v v 0) $
+                      Guitar.mapChordToString Guitar.stringPitches $
+                      fmap PitchChannel list
+         MS.put toPlay
+         return $
+            if on
+              then
+                 noteSequence stepTime Event.NoteOff
+                    (List.reverse played)
+                 ++
+                 noteSequence stepTime Event.NoteOn toPlay
+              else
+                 noteSequence stepTime Event.NoteOff played
+                 ++
+                 noteSequence stepTime Event.NoteOn
+                    (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 ::
+   Channel ->
+   Common.Time -> Common.Time ->
+   [([Pitch], [Pitch])] ->
+   RB.Behavior Common.TimeAbs ->
+   RB.Event Event.Data ->
+   Reactor (RB.Event Common.EventDataBundle)
+trainer chan pause duration sets0 times evs0 = do
+   let makeSeq sets =
+          case sets of
+             (target, _) : _ ->
+                (concat $
+                 zipWith
+                    (\t p ->
+                       Common.eventsFromKey t duration
+                          ((p,chan), normalVelocity))
+                    (iterate (duration+) pause) target,
+                 pause + duration * fromIntegral (length target))
+             [] -> ([], 0)
+
+   let (initial, initIgnoreUntil) = makeSeq sets0
+   getHandle >>= \h -> liftIO (outputEvents h 0 initial)
+
+   return $ fst $
+      flip (traverse (sets0, [], Common.incTime initIgnoreUntil 0))
+         (fmap (,) times <@> evs0) $ \(time,ev) ->
+      case ev of
+         Event.NoteEv notePart note ->
+            case fst $ normalNoteFromEvent notePart note of
+               Event.NoteOn -> do
+                  ignoreUntil <- AccState.get AccTuple.third3
+                  if time <= ignoreUntil
+                    then return []
+                    else do
+                       pressd <- AccState.get AccTuple.second3
+                       let newPressd = (note ^. MALSA.notePitch) : 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 $
+                                     Common.incTime newIgnoreUntil time
+                                  return notes
+                               else return []
+                          _ -> return []
+               _ -> return []
+         _ -> return []
+
+
+sweep ::
+   Common.Time ->
+   (Double -> Double) ->
+   RB.Behavior Double ->
+   Reactor (RB.Event Common.TimeAbs, RB.Behavior Double)
+sweep dur wave speed = do
+   bt <- beat $ constant dur
+   let durD = realToFrac $ Common.deconsTime dur
+   return
+      (bt,
+       fmap wave $ RB.accumB 0 $
+       fmap (\d _ phase -> Common.fraction (phase + durD * d)) speed <@> bt)
+
+makeControllerLinear ::
+   Channel -> Controller ->
+   RB.Behavior Int ->
+   RB.Behavior Int ->
+   RB.Event Common.TimeAbs -> RB.Behavior Double ->
+   RB.Event Event.Data
+makeControllerLinear chan cc depthCtrl centerCtrl bt ctrl =
+   pure
+      (\y depth center _time ->
+         Event.CtrlEv Event.Controller $
+         MALSA.controllerEvent chan cc $
+         round $ limit (0,127) $
+         fromIntegral center + fromIntegral depth * y)
+      <*> ctrl
+      <*> depthCtrl
+      <*> centerCtrl
+      <@> bt
diff --git a/src/Reactive/Banana/ALSA/Training.hs b/src/Reactive/Banana/ALSA/Training.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/ALSA/Training.hs
@@ -0,0 +1,110 @@
+module Reactive.Banana.ALSA.Training (
+   all,
+   intervals,
+   twoNotes,
+   threeNotes,
+   reverseThreeNotes,
+   sortThreeNotes,
+   transposeTwoNotes,
+   ) where
+
+import Reactive.Banana.ALSA.Common (pitch, increasePitch, subtractPitch, )
+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 increasePitch 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 (increasePitch (subtractPitch p0 baseKey)) pso))
+         (randomItem ps) (randomItem ps)) $
+   concat $ zipWith replicate [3,6..] $
+   drop 3 $ List.inits $
+   notes
diff --git a/src/Reactive/Banana/ALSA/Trie.hs b/src/Reactive/Banana/ALSA/Trie.hs
new file mode 100644
--- /dev/null
+++ b/src/Reactive/Banana/ALSA/Trie.hs
@@ -0,0 +1,44 @@
+{- |
+This module is only needed for DeBruijn sequence generation.
+-}
+module Reactive.Banana.ALSA.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"