diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,31 @@
+Copyright (c) 2010, 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/src/Sound/MIDI/ALSA/Causal.hs b/src/Sound/MIDI/ALSA/Causal.hs
new file mode 100644
--- /dev/null
+++ b/src/Sound/MIDI/ALSA/Causal.hs
@@ -0,0 +1,547 @@
+{-# LANGUAGE ExistentialQuantification #-}
+module Sound.MIDI.ALSA.Causal where
+
+import Sound.MIDI.ALSA.Common (Time, TimeAbs, )
+import qualified Sound.MIDI.ALSA.Common as Common
+
+import qualified Sound.ALSA.Sequencer.Address as Addr
+import qualified Sound.ALSA.Sequencer.Event as Event
+
+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 Sound.MIDI.ALSA (normalNoteFromEvent, )
+import Sound.MIDI.Message.Channel (Channel, )
+import Sound.MIDI.Message.Channel.Voice (Controller, Program, )
+
+import qualified Data.EventList.Relative.TimeBody as EventList
+import qualified Data.EventList.Relative.MixedBody as EventListMB
+import qualified Data.EventList.Absolute.TimeBody as EventListAbs
+
+import qualified Data.Accessor.Monad.Trans.State as AccM
+import qualified Data.Accessor.Tuple as AccTuple
+import qualified Data.Accessor.Basic as Acc
+import Data.Accessor.Basic ((^.), )
+
+import Data.Tuple.HT (mapFst, mapSnd, mapPair, )
+import Data.Ord.HT (limit, )
+import qualified Data.List as List
+
+import qualified Data.Map as Map
+
+import qualified Control.Category as Cat
+import qualified Control.Monad.Trans.State as State
+import qualified Control.Monad.Trans.Reader as Reader
+import Control.Monad.Trans.Reader (ReaderT, )
+import Control.Monad (guard, )
+
+import qualified Data.Monoid as Mn
+import qualified Data.List as List
+import Data.Word (Word8, )
+
+import Prelude hiding (init, map, filter, )
+
+
+{- |
+The returned event list must be finite.
+-}
+data T a b =
+   forall s c.
+   Cons
+      (TimeAbs -> Either c a ->
+       State.State s (Maybe b, EventList.T Time c))
+      s (EventList.T Time c)
+
+{-
+data T a b =
+   forall s c.
+   Cons (Time -> Either c a ->
+         State.State s (Maybe b, Maybe (Time,c)))
+-}
+{-
+This design allows to modify a trigger event until it fires.
+However, when can we ship it?
+We only know, if a later event comes in,
+that the trigger would have been shipped already.
+
+data T a b =
+   forall s c.
+   Cons (Time -> Either c a ->
+         State.State (s, Maybe (Time,c)) (Maybe b))
+-}
+{-
+data T a b =
+   forall s c.
+   Cons (Time -> Maybe a ->
+         State.State (s, EventList.T Time c) (Maybe b))
+-}
+
+
+map :: (a -> b) -> T a b
+map f = mapMaybe (Just . f)
+
+mapMaybe :: (a -> Maybe b) -> T a b
+mapMaybe f =
+   Cons
+      (\ _t ma ->
+         return (either (const Nothing) f ma, EventList.empty))
+      () EventList.empty
+
+compose :: T b c -> T a b -> T a c
+compose (Cons g sg tg) (Cons f sf tf) =
+   Cons (\t ma -> State.state $ \(sf0,sg0) ->
+      let ((mb,triggers), sf1) =
+             case ma of
+                Right a ->
+                   mapFst (mapFst (fmap Right)) $
+                   State.runState (f t (Right a)) sf0
+                Left (Left et) ->
+                   mapFst (mapFst (fmap Right)) $
+                   State.runState (f t (Left et)) sf0
+                Left (Right et) ->
+                   ((Just (Left et), EventList.empty), sf0)
+          etriggers = fmap Left triggers
+      in  mapSnd (\sg1 -> (sf1,sg1)) $
+          case mb of
+             Nothing ->
+                ((Nothing, etriggers), sg0)
+             Just b ->
+                mapFst (mapSnd
+                   (EventList.mergeBy (\_ _ -> False) etriggers . fmap Right)) $
+                State.runState (g t b) sg0)
+      (sf,sg)
+      (EventList.mergeBy (\_ _ -> False) (fmap Left tf) (fmap Right tg))
+
+{- |
+Run two stream processor in parallel.
+We cannot use the @Arrow@ method @&&&@
+since we cannot the @first@ method of the @Arrow@ class.
+Consider @first :: arrow a b -> arrow (c,a) (c,b)@
+and a trigger where @arrow a b@ generates an event of type @b@.
+How could we generate additionally an event of type @c@
+without having an input event?
+-}
+parallel ::
+   (Mn.Monoid b) =>
+   T a b -> T a b -> T a b
+parallel (Cons f sf tf) (Cons g sg tg) =
+   Cons (\t ma -> State.state $ \(sf0,sg0) ->
+      case ma of
+         Right a ->
+            let ((b0,triggers0), sf1) =
+                   State.runState (f t (Right a)) sf0
+                ((b1,triggers1), sg1) =
+                   State.runState (g t (Right a)) sg0
+            in  ((Mn.mappend b0 b1,
+                  EventList.mergeBy (\_ _ -> False)
+                     (fmap Left  triggers0)
+                     (fmap Right triggers1)),
+                 (sf1,sg1))
+         Left (Left et) ->
+            mapPair
+               (mapSnd (fmap Left),
+                \sf1 -> (sf1,sg0)) $
+            State.runState (f t (Left et)) sf0
+         Left (Right et) ->
+            mapPair
+               (mapSnd (fmap Right),
+                \sg1 -> (sf0,sg1)) $
+            State.runState (g t (Left et)) sg0)
+      (sf,sg)
+      (EventList.mergeBy (\_ _ -> False) (fmap Left tf) (fmap Right tg))
+
+
+instance Cat.Category T where
+   id = map id
+   (.) = compose
+
+
+traverse :: s -> (a -> State.State s b) -> T a b
+traverse s f =
+   Cons
+      (\ _t ma ->
+         fmap (\r -> (r, EventList.empty)) $
+         either (const $ return Nothing) (fmap Just . f) ma)
+      s EventList.empty
+
+
+process ::
+   T Event.Data Common.EventDataBundle ->
+   ReaderT Common.Handle IO ()
+process (Cons f s initTriggers) = do
+   Common.startQueue
+   Reader.ReaderT $ \h ->
+      {-
+      Triggers maintains a priority queue parallelly to the queue of ALSA.
+      We need this in order to associate Haskell values
+      with the incoming trigger events.
+      -}
+      let outputTriggers triggers =
+             EventListAbs.mapM_
+                (\t ->
+                   Event.output (Common.sequ h)
+                      (Common.makeEcho h (Common.deconsTime t) (Event.Custom 0 0 0))
+                    >> return ())
+                (const $ return ())
+                (EventList.toAbsoluteEventList 0 triggers)
+          go s0 (lastTime,triggers0) = do
+{-
+             print (realToFrac lastTime :: Double,
+                    List.map
+                       ((realToFrac :: TimeAbs -> Double) . Common.deconsTime) $
+                    EventList.getTimes triggers0)
+-}
+             ev <- Event.input (Common.sequ h)
+             let time =
+                    Common.deconsTime $
+                    Common.timeFromStamp (Event.timestamp ev)
+                 triggers1 =
+                    EventList.decreaseStart
+                       (Common.consTime "Causal.process.decreaseStart" (time-lastTime))
+                       triggers0
+                 (restTriggers1, ((mb,newTriggers), s1)) =
+                    case Event.body ev of
+                       Event.CustomEv Event.Echo _ ->
+                          case (Event.source ev ==
+                                   Addr.Cons (Common.client h) (Common.portOut h),
+                                EventList.viewL triggers1) of
+                             (True, Just ((_,c),restTriggers0)) ->
+                                (restTriggers0,
+                                 State.runState (f time (Left c)) s0)
+                             _ ->
+                                (EventList.empty,
+                                 ((Nothing, EventList.empty), s0))
+                       dat ->
+                          (triggers1,
+                           State.runState (f time (Right dat)) s0)
+
+             case mb of
+                Nothing -> return ()
+                Just dats ->
+                   flip mapM_ dats $ \(dt,dat) ->
+                      Event.output (Common.sequ h)
+                         (Common.makeEvent h (Common.incTime dt time) dat)
+             outputTriggers
+                (EventList.delay (Common.consTime "Causal.process.delay" time) $
+                 newTriggers)
+             Event.drainOutput (Common.sequ h)
+             go s1 (time,
+                    EventList.mergeBy (\_ _ -> False)
+                       restTriggers1 newTriggers)
+      in  outputTriggers initTriggers >>
+          Event.drainOutput (Common.sequ h) >>
+          go s (0,initTriggers)
+
+
+transposeBundle :: Int -> T Event.Data Common.EventDataBundle
+transposeBundle d =
+   map (maybe [] Common.singletonBundle . Common.transpose d)
+
+transpose :: Int -> T Event.Data Event.Data
+transpose d =
+   mapMaybe (Common.transpose d)
+
+delayAdd ::
+   Word8 -> Time -> T Event.Data Common.EventDataBundle
+delayAdd decay d =
+   map (Common.delayAdd decay d)
+
+
+pattern ::
+   (Common.Selector i, [i]) ->
+   Time ->
+   T Event.Data Common.EventDataBundle
+pattern (select, ixs) dur =
+   Cons
+      (\ _t ee ->
+         case ee of
+            Left (n:ns) ->
+               State.gets (\keys ->
+                  (Just (select n dur $ Map.toAscList keys),
+                   EventList.singleton dur ns))
+            Left [] ->
+               return (Nothing, EventList.empty)
+            Right e ->
+               fmap (\x -> (x, EventList.empty)) $
+               case e of
+                  Event.NoteEv notePart note -> do
+                     State.modify (Common.updateChord notePart note)
+                     return Nothing
+                  _ -> return $ Just $ Common.singletonBundle e)
+      Map.empty (EventList.singleton 0 ixs)
+
+updateChordDur ::
+   (Channel, Controller) ->
+   (Time, Time) ->
+   Event.Data ->
+   State.State
+      (Time, Common.KeySet)
+      (Maybe Common.EventDataBundle, EventList.T time body)
+updateChordDur chanCtrl minMaxDur e =
+   case e of
+      Event.NoteEv notePart note -> do
+         AccM.modify AccTuple.second (Common.updateChord notePart note)
+         return (Nothing, EventList.empty)
+      Event.CtrlEv Event.Controller param |
+            uncurry Common.controllerMatch chanCtrl param -> do
+         AccM.set AccTuple.first (Common.updateDur param minMaxDur)
+         return (Nothing, EventList.empty)
+      _ -> return
+         (Just (Common.singletonBundle e), EventList.empty)
+
+patternTempo ::
+   (Common.Selector i, [i]) ->
+   ((Channel,Controller), (Time,Time,Time)) ->
+   T Event.Data Common.EventDataBundle
+patternTempo (select, ixs) ((chan,ctrl), (minDur, defltDur, maxDur)) =
+   Cons
+      (\ _t ee ->
+         case ee of
+            Left (n:ns) ->
+               State.gets (\(dur,keys) ->
+                  (Just (select n dur $ Map.toAscList keys),
+                   EventList.singleton dur ns))
+            Left [] ->
+               return (Nothing, EventList.empty)
+            Right e ->
+               updateChordDur (chan,ctrl) (minDur,maxDur) e)
+      (defltDur, Map.empty)
+      (EventList.singleton 0 ixs)
+
+patternMultiTempo ::
+   (Common.Selector i, EventList.T Int [Common.IndexNote i]) ->
+   ((Channel,Controller), (Time,Time,Time)) ->
+   T Event.Data Common.EventDataBundle
+patternMultiTempo (select, ixs) ((chan,ctrl), (minDur, defltDur, maxDur)) =
+   let next dur rest =
+          EventList.switchL
+             EventList.empty
+             (\(t,_) _ ->
+                EventList.singleton (fromIntegral t * dur) rest)
+             rest
+   in  Cons
+          (\ _t ee ->
+             case ee of
+                Left nt ->
+                   EventList.switchL
+                      (return (Nothing, EventList.empty))
+                      (\(_,is) rest ->
+                         State.gets (\(dur,keys) ->
+                            (Just $
+                             do Common.IndexNote d i <- is
+                                select i (fromIntegral d * dur) $
+                                   Map.toAscList keys,
+                             next dur rest)))
+                      nt
+                Right e ->
+                   updateChordDur (chan,ctrl) (minDur,maxDur) e)
+          (defltDur, Map.empty)
+          (next defltDur ixs)
+
+
+updateSerialChord ::
+   Int ->
+   Event.NoteEv -> Event.Note ->
+   Common.KeyQueue -> Common.KeyQueue
+updateSerialChord maxNum notePart note chord =
+   let key =
+          (note ^. MALSA.notePitch,
+           note ^. MALSA.noteChannel)
+   in  case normalNoteFromEvent notePart note of
+          (Event.NoteOn, vel) -> take maxNum $ (key, vel) : chord
+          _ -> chord
+
+updateSerialChordDur ::
+   Int ->
+   (Channel, Controller) ->
+   (Time, Time) ->
+   Event.Data ->
+   State.State
+      (Time, Common.KeyQueue)
+      (Maybe Common.EventDataBundle, EventList.T time body)
+updateSerialChordDur maxNum chanCtrl minMaxDur e =
+   case e of
+      Event.NoteEv notePart note -> do
+         AccM.modify AccTuple.second (updateSerialChord maxNum notePart note)
+         return (Nothing, EventList.empty)
+      Event.CtrlEv Event.Controller param |
+            uncurry Common.controllerMatch chanCtrl param -> do
+         AccM.set AccTuple.first (Common.updateDur param minMaxDur)
+         return (Nothing, EventList.empty)
+      _ -> return
+         (Just (Common.singletonBundle e), EventList.empty)
+
+patternSerialTempo ::
+   Int ->
+   (Common.Selector i, [i]) ->
+   ((Channel,Controller), (Time,Time,Time)) ->
+   T Event.Data Common.EventDataBundle
+patternSerialTempo
+      maxNum (select, ixs) ((chan,ctrl), (minDur, defltDur, maxDur)) =
+   Cons
+      (\ _t ee ->
+         case ee of
+            Left (n:ns) ->
+               State.gets (\(dur,keys) ->
+                  (Just (select n dur keys),
+                   EventList.singleton dur ns))
+            Left [] ->
+               return (Nothing, EventList.empty)
+            Right e ->
+               updateSerialChordDur maxNum (chan,ctrl) (minDur,maxDur) e)
+      (defltDur, [])
+      (EventList.singleton 0 ixs)
+
+
+sweep ::
+   Channel ->
+   Time ->
+   (Controller, (Time,Time)) ->
+   Controller ->
+   Controller ->
+   (Double -> Double) ->
+   T Event.Data Common.EventDataBundle
+sweep chan dur (speedCtrl, (minSpeed, maxSpeed)) depthCtrl centerCtrl
+      wave =
+   Cons
+      (\ _t ee ->
+         case ee of
+            Left () -> do
+               ev <-
+                  State.gets (\s ->
+                     Event.CtrlEv Event.Controller $
+                     Event.Ctrl {
+                        Event.ctrlChannel = MALSA.fromChannel chan,
+                        Event.ctrlParam = MALSA.fromController centerCtrl,
+                        Event.ctrlValue =
+                           round $ limit (0,127) $
+                           Common.sweepCenter s + Common.sweepDepth s * wave (Common.sweepPhase s)
+                     })
+               State.modify (\s ->
+                  s{Common.sweepPhase = Common.fraction (Common.sweepPhase s + Common.sweepSpeed s)})
+               return $ (Just (Common.singletonBundle ev),
+                         EventList.singleton dur ())
+            Right e ->
+               fmap (\ev -> (ev, EventList.empty)) $
+               maybe (return $ Just $ Common.singletonBundle e)
+                     (\f -> State.modify f >> return Nothing) $ do
+                  Event.CtrlEv Event.Controller param <- Just e
+                  let c = param ^. MALSA.ctrlChannel
+                      ctrl = param ^. MALSA.ctrlController
+                      x :: Num a => a
+                      x = fromIntegral (Event.ctrlValue param)
+                  guard (c==chan)
+                  lookup ctrl $
+                     (speedCtrl,
+                      \s -> s{Common.sweepSpeed =
+                         realToFrac $ Common.deconsTime $ (dur *) $
+                         minSpeed + (maxSpeed-minSpeed) * x/127}) :
+                     (depthCtrl,  \s -> s{Common.sweepDepth = x}) :
+                     (centerCtrl, \s -> s{Common.sweepCenter = x}) :
+                     [])
+      (Common.SweepState {
+         Common.sweepSpeed =
+            realToFrac $ Common.deconsTime $
+            dur*(minSpeed+maxSpeed)/2,
+         Common.sweepDepth = 64,
+         Common.sweepCenter = 64,
+         Common.sweepPhase = 0
+       })
+      (EventList.singleton 0 ())
+
+partition :: (a -> Bool) -> T a (Maybe a, Maybe a)
+partition p =
+   map (\a -> if p a then (Just a, Nothing) else (Nothing, Just a))
+
+maybeIn :: T a b -> T (Maybe a) b
+maybeIn (Cons f s0 trig) =
+   Cons
+      (\t e -> State.state $ \s ->
+         case e of
+            Left c -> State.runState (f t $ Left c) s
+            Right (Just c) -> State.runState (f t $ Right c) s
+            Right _ -> ((Nothing, EventList.empty), s))
+      s0 trig
+
+guide ::
+   (Mn.Monoid b) =>
+   (a -> Bool) -> T a b -> T a b -> T a b
+guide p f g =
+   compose
+      (parallel
+         (compose (maybeIn f) (map fst))
+         (compose (maybeIn g) (map snd)))
+      (partition p)
+
+cyclePrograms :: [Program] -> T Event.Data Common.EventDataBundle
+cyclePrograms pgms =
+   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.
+-}
+cycleProgramsDefer :: Time -> [Program] -> T Event.Data Common.EventDataBundle
+cycleProgramsDefer defer pgms =
+   Cons
+      (\ _t ->
+         either
+            (\() -> do
+               AccM.set AccTuple.second False
+               return (Nothing, EventList.empty))
+            (\e -> do
+               block <- State.gets snd
+               case (block, e) of
+                  (False, Event.NoteEv notePart note) ->
+                     case fst $ normalNoteFromEvent notePart note of
+                        Event.NoteOn -> do
+                           AccM.set AccTuple.second True
+                           fmap (\r -> (Just r, EventList.singleton defer ())) $
+                              AccM.lift AccTuple.first $
+                              Common.traverseProgramsSeek (length pgms) e
+                        _ -> return (Just $ Common.singletonBundle e, EventList.empty)
+                  _ -> return (Just $ Common.singletonBundle e, EventList.empty)))
+      (cycle pgms, False) EventList.empty
+
+
+
+main :: IO ()
+main =
+   Common.with $ Common.connectLLVM >>
+   case 10::Int of
+      0 -> process (transposeBundle 12)
+      1 -> process (delayAdd 50 1)
+      2 -> process (pattern (Common.cycleUp 4) 0.12)
+      3 -> process (patternTempo (Common.cycleUp 4)
+              (Common.defaultTempoCtrl, (0.05, 0.12, 0.25)))
+      4 -> process (patternMultiTempo
+              (Common.selectFromLimittedChord, Common.examplePatternMultiTempo1)
+              (Common.defaultTempoCtrl, (0.05, 0.12, 0.25)))
+      5 -> process (sweep (ChannelMsg.toChannel 1)
+              0.01 (VoiceMsg.toController 72, (0.1, 1))
+              (VoiceMsg.toController 73) (VoiceMsg.toController 91)
+              (sin . (2*pi*)))
+      6 -> process
+              (guide
+                 (\e ->
+                     Common.checkPitch (VoiceMsg.toPitch 60 >) e ||
+                     Common.checkController (snd Common.defaultTempoCtrl ==) e)
+                 (patternTempo (Common.cycleUp 4)
+                     (Common.defaultTempoCtrl, (0.05, 0.12, 0.25))
+                  `compose`
+                  transpose 12)
+                 (map Common.singletonBundle))
+      7 -> process (patternSerialTempo 4 (Common.cycleUp 4)
+              (Common.defaultTempoCtrl, (0.05, 0.12, 0.25)))
+      8 -> process $ cyclePrograms $
+              List.map VoiceMsg.toProgram [16..20]
+      9 -> process $ cycleProgramsDefer 0.1 $
+              List.map VoiceMsg.toProgram [16..20]
+      _ -> process (patternMultiTempo Common.binaryLegato
+              (Common.defaultTempoCtrl, (0.05, 0.12, 0.25)))
diff --git a/src/Sound/MIDI/ALSA/Common.hs b/src/Sound/MIDI/ALSA/Common.hs
new file mode 100644
--- /dev/null
+++ b/src/Sound/MIDI/ALSA/Common.hs
@@ -0,0 +1,792 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Sound.MIDI.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 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 qualified Data.EventList.Relative.MixedBody as EventListMB
+import Data.EventList.Relative.MixedBody ((/.), (./), )
+
+import Data.Accessor.Basic ((^.), (^=), )
+
+import qualified Data.List.HT as ListHT
+import Data.Maybe.HT (toMaybe, )
+import Data.Tuple.HT (mapFst, mapSnd, )
+import qualified Data.List as List
+
+import qualified System.Random as Rnd
+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 Control.Monad (guard, )
+
+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, )
+
+
+-- * helper functions
+
+data Handle =
+   Handle {
+      sequ :: SndSeq.T SndSeq.DuplexMode,
+      client :: Client.T,
+      portIn, portOut :: 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
+   pout <-
+      Port.createSimple h "sender"
+         (Port.caps [Port.capRead, Port.capSubsRead])
+         Port.typeMidiGeneric
+   pin <-
+      Port.createSimple h "receiver"
+         (Port.caps [Port.capWrite, Port.capSubsWrite])
+         Port.typeMidiGeneric
+   q <- Queue.alloc h
+   let hnd = Handle h c pin pout 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) (portIn h)
+   Port.delete (sequ h) (portOut 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 "sender"
+         (Port.caps [Port.capRead, Port.capSubsRead])
+         Port.typeMidiGeneric $ \pout -> do
+   Port.withSimple h "receiver"
+         (Port.caps [Port.capWrite, Port.capSubsWrite])
+         Port.typeMidiGeneric $ \pin -> do
+   Queue.with h $ \q ->
+      flip Reader.runReaderT (Handle h c pin pout 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) (portIn h)
+   PortInfo.setTimestamping info True
+   PortInfo.setTimestampReal info True
+   PortInfo.setTimestampQueue info (queue h)
+   PortInfo.set (sequ h) (portIn 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) (portIn h) from
+   SndSeq.connectTo (sequ h) (portOut h) to
+
+connectTimidity :: ReaderT Handle IO ()
+connectTimidity =
+   connect "E-MU Xboard61" "TiMidity"
+
+connectLLVM :: ReaderT Handle IO ()
+connectLLVM =
+   connect "E-MU Xboard61" "Haskell-Synthesizer"
+
+
+
+-- * helper
+
+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
+
+
+
+-- * 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
+
+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
+
+
+-- * events
+
+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 =
+           Event.RealTime (RealTime.fromInteger (round (t*nano)))
+      , Event.source = Addr.Cons (client h) (portOut 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 =
+           Event.RealTime (RealTime.fromInteger (round (t*nano)))
+      , Event.source = Addr.Cons (client h) (portOut h)
+      , Event.dest   = Addr.Cons (client h) (portIn  h)
+      , Event.body   = Event.CustomEv Event.Echo c
+      }
+
+
+{- |
+The times are relative to the start time of the bundle
+and do not need to be ordered.
+-}
+type Bundle a = [(Time, a)]
+type EventDataBundle = Bundle Event.Data
+
+singletonBundle :: a -> Bundle a
+singletonBundle ev = [(0,ev)]
+
+
+timeFromStamp :: Event.TimeStamp -> Time
+timeFromStamp t =
+   case t of
+      Event.RealTime rt ->
+         consTime "time conversion" $
+         RealTime.toInteger rt % nano
+--      _ -> 0,
+      _ -> error "unsupported time stamp type"
+
+
+
+
+defaultTempoCtrl :: (Channel,Controller)
+defaultTempoCtrl =
+   (ChannelMsg.toChannel 0, VoiceMsg.toController 70)
+
+
+
+-- * 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
+
+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 Event.Controller ctrl ->
+         Event.CtrlEv Event.Controller $
+         (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] EventDataBundle
+nextProgram note =
+   State.state $ \pgms ->
+   case pgms of
+      pgm:rest ->
+         (singletonBundle $
+          Event.CtrlEv Event.PgmChange $
+          Event.Ctrl {
+             Event.ctrlChannel = Event.noteChannel note,
+             Event.ctrlParam = 0,
+             Event.ctrlValue = MALSA.fromProgram pgm},
+          rest)
+      [] -> ([],[])
+
+{- |
+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] EventDataBundle
+traversePrograms e =
+   fmap (++ singletonBundle e) $
+   case e of
+      Event.NoteEv notePart note ->
+         (case fst $ normalNoteFromEvent notePart note of
+             Event.NoteOn -> nextProgram note
+             _ -> return [])
+      _ -> return []
+
+{- |
+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] EventDataBundle
+traverseProgramsSeek maxSeek e =
+   fmap (++ singletonBundle e) $
+   case e of
+      Event.NoteEv notePart note ->
+         case fst $ normalNoteFromEvent notePart note of
+            Event.NoteOn -> nextProgram note
+            _ -> return []
+      Event.CtrlEv Event.PgmChange ctrl ->
+         let pgm = ctrl ^. MALSA.ctrlProgram
+         in  fmap (const []) $
+             State.modify $
+                uncurry (++) .
+                mapFst (dropWhile (pgm/=)) .
+                splitAt maxSeek
+      _ -> return []
+
+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 ->
+         [(d, Event.NoteEv notePart $
+              reduceNoteVelocity decay note)]
+      _ -> []
+
+
+
+simpleNote :: Channel -> Pitch -> Velocity -> Event.Note
+simpleNote c p v =
+   Event.simpleNote
+      (MALSA.fromChannel c)
+      (MALSA.fromPitch p)
+      (MALSA.fromVelocity v)
+
+type KeySet   = Map.Map (Pitch, Channel) Velocity
+type KeyQueue = [((Pitch, Channel), Velocity)]
+
+eventsFromKey ::
+   Time -> ((Pitch, Channel), Velocity) -> 
+   EventDataBundle
+eventsFromKey dur ((pit,chan), vel) =
+   (0,   Event.NoteEv Event.NoteOn  $ simpleNote chan pit vel) :
+   (dur, Event.NoteEv Event.NoteOff $ simpleNote chan pit vel) :
+   []
+
+selectFromLimittedChord ::
+   Int ->
+   Time ->
+   KeyQueue ->
+   EventDataBundle
+selectFromLimittedChord n dur =
+   maybe [] (eventsFromKey dur) .
+   (!!n) . (++ repeat Nothing) . map Just
+
+{- |
+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 ::
+   Int ->
+   Time ->
+   KeyQueue ->
+   EventDataBundle
+selectFromOctaveChord d dur chord =
+   maybe [] (eventsFromKey dur) $ do
+      guard (not $ null chord)
+      let (q,r) = divMod d (fromIntegral $ length chord)
+          ((pit,chan), vel) = chord !! r
+      transPitch <- increasePitch (12*q) pit
+      return ((transPitch,chan), vel)
+
+selectFromChord ::
+   Integer ->
+   Time ->
+   KeyQueue ->
+   EventDataBundle
+selectFromChord d dur chord =
+   if null chord
+     then []
+     else
+       eventsFromKey dur $
+       chord !! fromInteger d
+
+selectFromChordRatio ::
+   Double ->
+   Time ->
+   KeyQueue ->
+   EventDataBundle
+selectFromChordRatio d dur chord =
+   if null chord
+     then []
+     else
+       eventsFromKey dur $
+       chord !! floor (d * fromIntegral (length chord))
+
+
+increasePitch :: Int -> Pitch -> Maybe Pitch
+increasePitch d p =
+   let pInt = d + VoiceMsg.fromPitch p
+   in  toMaybe
+          (VoiceMsg.fromPitch minBound <= pInt  &&
+           pInt <= VoiceMsg.fromPitch maxBound)
+          (VoiceMsg.toPitch pInt)
+
+
+selectInversion ::
+   Double ->
+   Time ->
+   KeyQueue ->
+   EventDataBundle
+selectInversion d dur chord =
+   let -- properFraction is useless for negative numbers
+       splitFraction x =
+          let n = floor x :: Int
+          in  (n, x - fromIntegral n)
+       makeNote octave ((pit,chan), vel) =
+          maybe []
+             (\pitchTrans -> eventsFromKey dur ((pitchTrans,chan), vel))
+             (increasePitch (octave*12) pit)
+       (oct,p) = splitFraction d
+       pivot = floor (p * fromIntegral (length chord))
+       (low,high) = splitAt pivot chord
+   in  concatMap (makeNote oct) high ++
+       concatMap (makeNote (oct+1)) low
+
+
+updateChord ::
+   Event.NoteEv -> Event.Note ->
+   KeySet -> KeySet
+updateChord notePart note =
+   let key =
+          (note ^. MALSA.notePitch,
+           note ^. MALSA.noteChannel)
+       (part, vel) =
+          normalNoteFromEvent notePart note
+   in  case part of
+          Event.NoteOn  -> Map.insert key vel
+          Event.NoteOff -> Map.delete key
+          _ -> id
+
+
+controllerMatch ::
+   Channel -> Controller -> Event.Ctrl -> Bool
+controllerMatch chan ctrl param =
+   Event.ctrlChannel param == MALSA.fromChannel chan &&
+   Event.ctrlParam   param == MALSA.fromController ctrl
+
+updateDur ::
+   Event.Ctrl -> (Time, Time) -> Time
+updateDur param (minDur, maxDur) =
+   minDur + (maxDur-minDur)
+      * fromIntegral (Event.ctrlValue param) / 127
+
+
+type Selector i = i -> Time -> KeyQueue -> EventDataBundle
+
+type Pattern i = (Selector i, [i])
+
+
+data IndexNote i = IndexNote Int i
+   deriving (Show, Eq, Ord)
+
+item :: i -> Int -> IndexNote i
+item i n = IndexNote n i
+
+type PatternMulti i = (Selector i, EventList.T Int [IndexNote i])
+
+
+
+fraction :: RealFrac a => a -> a
+fraction x =
+   let n = floor x
+   in  x - fromIntegral (n::Integer)
+
+
+data SweepState =
+   SweepState {
+      sweepSpeed, sweepDepth, sweepCenter, sweepPhase :: Double
+   }
+
+
+
+{-
+ctrlRange ::
+   (RealFrac b) =>
+   (b,b) -> (a -> b) -> (a -> Int)
+ctrlRange (l,u) f x =
+   round $
+   limit (0,127) $
+   127*(f x - l)/(u-l)
+-}
+
+-- * patterns
+
+{-
+  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]
+
+cycleUp, cycleDown, pingPong, crossSum ::
+   Int -> Pattern Int
+cycleUp   number =
+   (selectFromLimittedChord, cycle [0..(number-1)])
+cycleDown number =
+   (selectFromLimittedChord, cycle $ reverse [0..(number-1)])
+pingPong  number =
+   (selectFromLimittedChord,
+    cycle $ [0..(number-2)] ++ reverse [1..(number-1)])
+crossSum  number =
+   (selectFromLimittedChord, flipSeq number)
+
+cycleUpAuto, cycleDownAuto, pingPongAuto, crossSumAuto ::
+   Pattern Integer
+cycleUpAuto =
+   (\ d dur chord ->
+       selectFromChord (mod d (fromIntegral $ length chord)) dur chord,
+    [0..])
+cycleDownAuto =
+   (\ d dur chord ->
+       selectFromChord (mod d (fromIntegral $ length chord)) dur chord,
+    [0,(-1)..])
+pingPongAuto =
+   (\ 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 =
+   (\ 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 :: PatternMulti Int
+{-
+binary number pattern:
+   0
+   1
+   0 1
+   2
+   0 2
+   1 2
+   0 1 2
+   3
+-}
+binaryStaccato =
+   (selectFromLimittedChord,
+    EventList.fromPairList $
+    zip (0 : repeat 1) $
+    map
+       (map (IndexNote 1 . fst) .
+        List.filter ((/=0) . snd) .
+        zip [0..] .
+        decomposePositional 2)
+       [0..])
+
+binaryLegato =
+   (selectFromLimittedChord,
+    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 =
+   (selectFromLimittedChord,
+    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 ::
+   Int -> Pattern Int
+cycleUpOctave number =
+   (selectFromOctaveChord, cycle [0..(number-1)])
+
+random, randomInversions :: Pattern Double
+random =
+   (selectFromChordRatio, Rnd.randomRs (0,1) (Rnd.mkStdGen 42))
+
+randomInversions =
+   inversions $
+   map sum $
+   ListHT.sliceVertical 3 $
+   Rnd.randomRs (-0.5,0.5) $
+   Rnd.mkStdGen 42
+
+cycleUpInversions :: Int -> Pattern Double
+cycleUpInversions n =
+   inversions $ cycle $ take n $
+   map (\i -> fromInteger i / fromIntegral n) [0..]
+
+inversions :: [Double] -> Pattern Double
+inversions rs =
+   (selectInversion, rs)
+
+
+{-
+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.
+-}
+examplePatternMultiTempo0 ::
+   EventList.T Int [IndexNote Int]
+examplePatternMultiTempo0 =
+   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
+
+examplePatternMultiTempo1 ::
+   EventList.T Int [IndexNote Int]
+examplePatternMultiTempo1 =
+   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
+
+
+-- * predicates
+
+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 ctrl ->
+         p (ctrl ^. MALSA.ctrlController)
+      _ -> False
+
+checkProgram ::
+   (Program -> Bool) ->
+   (Event.Data -> Bool)
+checkProgram p e =
+   case e of
+      Event.CtrlEv Event.PgmChange ctrl ->
+         p (ctrl ^. MALSA.ctrlProgram)
+      _ -> False
diff --git a/src/Sound/MIDI/ALSA/EventList.hs b/src/Sound/MIDI/ALSA/EventList.hs
new file mode 100644
--- /dev/null
+++ b/src/Sound/MIDI/ALSA/EventList.hs
@@ -0,0 +1,750 @@
+module Sound.MIDI.ALSA.EventList where
+{-
+ToDo:
+controller mapping
+
+fix laziness issues in splitting and merging
+change pattern according to program change events
+-}
+
+import Sound.MIDI.ALSA.Common
+          (Bundle, EventDataBundle, Time, TimeAbs,
+           Handle, Pattern, PatternMulti, Selector,
+           sequ, with, incTime,
+           singletonBundle, checkController, checkChannel,
+           checkProgram, checkPitch,
+           SweepState, sweepSpeed, sweepPhase, sweepDepth, sweepCenter,
+           updateDur, updateChord, )
+import qualified Sound.MIDI.ALSA.Common as Common
+
+import qualified Sound.ALSA.Sequencer.Event as Event
+import qualified Sound.ALSA.Exception as Exc
+
+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 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 Data.EventList.Relative.MixedBody as EventListMB
+import qualified Data.EventList.Absolute.TimeBody as EventListAbs
+
+import qualified Data.Accessor.Basic as Acc
+import Data.Accessor.Basic ((^.), )
+
+import qualified Data.List.HT as ListHT
+import qualified Data.List.Match as Match
+import Data.Tuple.HT (mapFst, mapSnd, mapPair, )
+import Data.Ord.HT (limit, )
+import qualified Data.List as List
+import Data.Maybe (mapMaybe, )
+
+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 Control.Monad.IO.Class (liftIO, )
+import qualified Control.Applicative as App
+import Control.Monad (liftM2, guard, )
+import qualified Data.Foldable as Fold
+import qualified Data.Traversable as Trav
+
+import qualified Numeric.NonNegative.Class as NonNeg
+
+import Data.Int (Int32, )
+
+import System.IO.Unsafe (unsafeInterleaveIO, )
+
+import Prelude hiding (init, filter, )
+
+
+ioToLazyList :: IO a -> IO [a]
+ioToLazyList m =
+   let go = unsafeInterleaveIO $ liftM2 (:) m go
+   in  go
+
+
+inputEventsCore :: ReaderT Handle IO [Event.T]
+inputEventsCore =
+   Reader.ReaderT $ \h ->
+   ioToLazyList (Event.input (sequ h))
+
+inputEvents :: ReaderT Handle IO (EventList.T Time Event.Data)
+inputEvents =
+   fmap (EventList.fromAbsoluteEventList .
+         EventListAbs.fromPairList .
+         map (\ev -> (Common.timeFromStamp (Event.timestamp ev),
+                      Event.body ev))) $
+   inputEventsCore
+
+
+pairListFromRelativeEvents :: EventList.T Time a -> [(TimeAbs,a)]
+pairListFromRelativeEvents =
+   EventListAbs.toPairList .
+   EventListAbs.mapTime Common.deconsTime .
+   EventList.toAbsoluteEventList 0
+
+outputEvent :: TimeAbs -> Event.Data -> ReaderT Handle IO ()
+outputEvent t ev = Reader.ReaderT $ \h ->
+   Event.output (sequ h) (Common.makeEvent h t ev) >>
+   Event.drainOutput (sequ h) >>
+   return ()
+
+outputEvents :: EventList.T Time Event.Data -> ReaderT Handle IO ()
+outputEvents =
+   mapM_ (uncurry outputEvent) .
+   pairListFromRelativeEvents
+
+
+{- |
+Sends (drain) each event individually
+since the events in the bundle might be created in a lazy manner.
+-}
+outputEventBundles :: EventList.T Time EventDataBundle -> ReaderT Handle IO ()
+outputEventBundles =
+   mapM_
+      (\(t,evs) ->
+         flip mapM_ evs (\(dt,ev) ->
+            outputEvent (incTime dt t) ev)) .
+   pairListFromRelativeEvents
+
+outputEventBundled :: EventList.T Time EventDataBundle -> ReaderT Handle IO ()
+outputEventBundled =
+   mapM_
+      (\(t,evs) -> Reader.ReaderT $ \h ->
+         flip mapM_ evs (\(dt,ev) ->
+            Event.output (sequ h) (Common.makeEvent h (incTime dt t) ev)) >>
+         Event.drainOutput (sequ h) >>
+         return ()) .
+   pairListFromRelativeEvents
+
+
+data Trigger a =
+     Regular a
+   | Trigger
+
+instance Functor Trigger where
+   fmap f (Regular a) = Regular (f a)
+   fmap _ Trigger     = Trigger
+
+instance Fold.Foldable Trigger where
+   foldMap = Trav.foldMapDefault
+
+instance Trav.Traversable Trigger where
+   sequenceA (Regular a) = fmap Regular a
+   sequenceA Trigger     = App.pure Trigger
+
+
+type EventDataTrigger = Bundle (Trigger Event.Data)
+
+makeTriggerEvent :: Handle -> TimeAbs -> Trigger Event.Data -> Event.T
+makeTriggerEvent h t x =
+   case x of
+      Regular ev -> Common.makeEvent h t ev
+      Trigger -> Common.makeEcho h t (Event.Custom 0 0 0)
+
+makeTriggerEvents :: Handle -> TimeAbs -> EventDataTrigger -> [Event.T]
+makeTriggerEvents h t =
+   map (\(dt,ev) -> makeTriggerEvent h (incTime dt t) ev)
+
+{- |
+This function distinguishes between events from portIn
+and events that are generated by us.
+Our generated events must also send an echo to the input port
+in order to break 'event_input' and thus trigger their delivery.
+-}
+outputTriggerEvents ::
+   EventList.T Time EventDataTrigger ->
+   ReaderT Handle IO ()
+outputTriggerEvents =
+   mapM_
+      (\(t,ee) -> Reader.ReaderT $ \h ->
+         mapM_
+            (\e ->
+                Event.output (sequ h) e >>
+                Event.drainOutput (sequ h))
+            (makeTriggerEvents h t ee)
+          >> return ()) .
+   pairListFromRelativeEvents
+
+mergeGenerated ::
+   EventList.T Time (Bundle a) ->
+   EventList.T Time (Bundle a) ->
+   EventList.T Time (Bundle (Trigger a))
+mergeGenerated gens ins =
+   merge
+      (fmap (\t -> [(t, Trigger)]) $ EventList.fromPairList $
+       ListHT.mapAdjacent (,) (0 : EventList.getTimes gens))
+      (fmap (map (mapSnd Regular)) $
+       merge gens ins)
+
+
+{- ToDo: move to eventlist package -}
+equidistantEvents :: Time -> [a] -> EventList.T Time a
+equidistantEvents dur as =
+   case as of
+      [] -> EventList.empty
+      x:xs ->
+         EventList.cons 0 x $
+         EventList.fromPairList (map ((,) dur) xs)
+
+whirl :: EventList.T Time EventDataBundle
+whirl =
+   let dur = 0.125
+       notes =
+          cycle $ concat $ concatMap (replicate 4) $
+             [57, 59, 60, 64] :
+             [57, 59, 60, 65] :
+             [57, 62, 64, 65] :
+             [57, 59, 60, 64] :
+             []
+       ctrls =
+          map (\t -> round (80 + 47 * sin t)) (iterate (0.1+) (0::Double))
+       events =
+          zipWith (:)
+             (map
+                (\k -> (0, Event.CtrlEv Event.Controller (Event.Ctrl
+                   {Event.ctrlChannel = 0,
+                    Event.ctrlParam = 23,
+                    Event.ctrlValue = k})))
+                ctrls)
+             (map
+                (\k ->
+                   (0,   Event.NoteEv Event.NoteOn  $ Event.simpleNote 0 k 64) :
+                   (dur, Event.NoteEv Event.NoteOff $ Event.simpleNote 0 k 64) :
+                   [])
+                notes)
+
+   in  EventList.cons 0
+          [(0, Event.CtrlEv Event.PgmChange (Event.Ctrl
+                  {Event.ctrlChannel = 0,
+                   Event.ctrlParam = 0,
+                   Event.ctrlValue = 5}))] $
+       equidistantEvents dur events
+
+
+mergeGeneratedAtoms ::
+   (Time -> a) ->
+   EventList.T Time a ->
+   EventList.T Time a ->
+   EventList.T Time a
+mergeGeneratedAtoms trigger gens ins =
+   EventList.mergeBy (\_ _ -> True)
+      (fmap trigger $ EventList.fromPairList $
+       ListHT.mapAdjacent (,) (0 : EventList.getTimes gens))
+      (EventList.mergeBy (\_ _ -> True) gens ins)
+
+pattern ::
+   Selector i ->
+   [i] ->
+   Time ->
+   EventList.T Time Event.Data ->
+   EventList.T Time EventDataTrigger
+pattern select ixs dur ins =
+   flip State.evalState Map.empty $ Trav.sequenceA $
+   mergeGeneratedAtoms
+      (\dt -> return [(dt, Trigger)])
+      (fmap
+          (\n -> State.gets (map (mapSnd Regular) . select n dur . Map.toAscList))
+          (equidistantEvents dur ixs))
+      (fmap
+          (\e ->
+             case e of
+                Event.NoteEv notePart note -> do
+                   State.modify (updateChord notePart note)
+                   return []
+                _ -> return $ singletonBundle (Regular e))
+          ins)
+
+
+patternTempo ::
+   Selector i ->
+   [i] ->
+   ((Channel,Controller), (Time,Time,Time)) ->
+   EventList.T Time Event.Data ->
+   EventList.T Time EventDataTrigger
+patternTempo select ixs0 ((chan,ctrl), (minDur, defltDur, maxDur)) =
+   let recourse dur chord ixs =
+          EventList.switchL EventList.empty $ \(time,me) rest ->
+          uncurry (EventList.cons time) $
+          case me of
+             Nothing ->
+                case ixs of
+                   [] -> ([], recourse dur chord ixs rest)
+                   i:ir ->
+                      ((dur, Trigger) :
+                       map (mapSnd Regular) (select i dur $ Map.toAscList chord),
+                       recourse dur chord ir $
+                       EventList.insertBy (\_ _ -> True) dur Nothing rest)
+             Just e ->
+                case e of
+                   Event.NoteEv notePart note ->
+                      ([],
+                       recourse dur (updateChord notePart note chord) ixs rest)
+                   Event.CtrlEv Event.Controller param |
+                          Common.controllerMatch chan ctrl param ->
+                      ([],
+                       recourse
+                          (updateDur param (minDur,maxDur))
+                          chord ixs rest)
+                   _ -> (singletonBundle (Regular e),
+                         recourse dur chord ixs rest)
+   in  recourse defltDur Map.empty ixs0 .
+       EventList.insertBy (\_ _ -> True) defltDur Nothing .
+       fmap Just
+
+
+{- |
+This allows more complex patterns including pauses,
+notes of different lengths and simultaneous notes.
+-}
+patternMultiTempo ::
+   Selector i ->
+   EventList.T Int [Common.IndexNote i] ->
+   ((Channel,Controller), (Time,Time,Time)) ->
+   EventList.T Time Event.Data ->
+   EventList.T Time EventDataTrigger
+patternMultiTempo select ixs0 ((chan,ctrl), (minDur, defltDur, maxDur)) =
+   let recourse dur chord ixs =
+          EventList.switchL EventList.empty $ \(time,me) rest ->
+          uncurry (EventList.cons time) $
+          case me of
+             Nothing ->
+                EventList.switchL
+                   ([], recourse dur chord ixs rest)
+                   (\(t,is) ir0 ->
+                      let (notes,ir1) =
+                             if t>0
+                               then ([], EventList.cons (t-1) is ir0)
+                               else
+                                 (do Common.IndexNote d i <- is
+                                     evs <-
+                                        select i (fromIntegral d * dur) $
+                                        Map.toAscList chord
+                                     return (mapSnd Regular evs),
+                                  ir0)
+                      in  ((dur, Trigger) : notes,
+                           recourse dur chord ir1 $
+                           EventList.insertBy (\_ _ -> True) dur Nothing rest))
+                   ixs
+             Just e ->
+                case e of
+                   Event.NoteEv notePart note ->
+                      ([],
+                       recourse dur (updateChord notePart note chord) ixs rest)
+                   Event.CtrlEv Event.Controller param |
+                          Common.controllerMatch chan ctrl param ->
+                      ([],
+                       recourse
+                          (updateDur param (minDur,maxDur))
+                          chord ixs rest)
+                   _ -> (singletonBundle (Regular e),
+                         recourse dur chord ixs rest)
+   in  recourse defltDur Map.empty ixs0 .
+       EventList.insertBy (\_ _ -> True) defltDur Nothing .
+       fmap Just
+
+
+{- |
+Automatically changes the value of a MIDI controller
+every @period@ seconds according to a periodic wave.
+The wave function is a mapping
+from the phase in @[0,1)@
+to a controller value in the range @(-1,1)@.
+The generation of the wave is controlled by a speed controller
+(@minSpeed@ and @maxSpeed@ are in waves per second),
+the modulation depth and the center value.
+The center controller is also the one where we emit our wave.
+That is, when modulation depth is zero
+then this effect is almost the same
+as forwarding the controller without modification.
+The small difference is, that we emit a controller value at a regular pattern,
+whereas direct control would mean
+that only controller value changes are transfered.
+
+> sweep channel
+>    period (speedCtrl, (minSpeed, maxSpeed)) depthCtrl centerCtrl
+>    (ctrlRange (-1,1) (sin . (2*pi*)))
+
+We could use the nice Wave abstraction from the synthesizer package,
+but that's a heavy dependency because of multi-parameter type classes.
+-}
+sweep ::
+   Channel ->
+   Time ->
+   (Controller, (Time,Time)) ->
+   Controller ->
+   Controller ->
+   (Double -> Double) ->
+   EventList.T Time Event.Data ->
+   EventList.T Time EventDataTrigger
+sweep chan dur (speedCtrl, (minSpeed, maxSpeed)) depthCtrl centerCtrl
+      wave ins =
+   flip State.evalState
+       (Common.SweepState {
+          sweepSpeed =
+             realToFrac $ Common.deconsTime $
+             dur*(minSpeed+maxSpeed)/2,
+          sweepDepth = 64,
+          sweepCenter = 64,
+          sweepPhase = 0
+        }) $
+   Trav.sequenceA $
+   mergeGeneratedAtoms
+      (\dt -> return [(dt, Trigger)])
+      (fmap
+          (\() -> do
+              ev <-
+                 State.gets (\s ->
+                    Event.CtrlEv Event.Controller $
+                    Event.Ctrl {
+                       Event.ctrlChannel = MALSA.fromChannel chan,
+                       Event.ctrlParam = MALSA.fromController centerCtrl,
+                       Event.ctrlValue =
+                          round $ limit (0,127) $
+                          sweepCenter s + sweepDepth s * wave (sweepPhase s)
+                    })
+              State.modify (\s ->
+                 s{sweepPhase = Common.fraction (sweepPhase s + sweepSpeed s)})
+              return $ singletonBundle (Regular ev))
+          (equidistantEvents dur $ repeat ()))
+      (fmap
+          (\e ->
+             maybe (return $ singletonBundle (Regular e))
+                   (\f -> State.modify f >> return []) $ do
+                Event.CtrlEv Event.Controller param <- Just e
+                let c = param ^. MALSA.ctrlChannel
+                    ctrl = param ^. MALSA.ctrlController
+                    x :: Num a => a
+                    x = fromIntegral (Event.ctrlValue param)
+                guard (c==chan)
+                lookup ctrl $
+                   (speedCtrl,
+                    \s -> s{sweepSpeed =
+                       realToFrac $ Common.deconsTime $ (dur *) $
+                       minSpeed + (maxSpeed-minSpeed) * x/127}) :
+                   (depthCtrl,  \s -> s{sweepDepth = x}) :
+                   (centerCtrl, \s -> s{sweepCenter = x}) :
+                   [])
+          ins)
+
+
+-- * combinators
+
+{- |
+The function maintains empty bundles
+in order to maintain laziness breaks.
+These breaks are import for later merging of the streams.
+-}
+filter ::
+   (a -> Bool) ->
+   State.State
+      (EventList.T Time (Bundle a))
+      (EventList.T Time (Bundle a))
+filter p = State.state $
+   EventList.foldrPair
+      (\t evs ->
+         let (evsT,evsF) =
+                List.partition (p . snd) evs
+         in  mapPair
+                (EventList.cons t evsT,
+                 EventList.cons t evsF))
+      (EventList.empty, EventList.empty)
+
+filterSimple ::
+   (a -> Bool) ->
+   EventList.T Time (Bundle a) ->
+   EventList.T Time (Bundle a)
+filterSimple p =
+   EventList.foldrPair
+      (\t evs ->
+         EventList.cons t (List.filter (p . snd) evs))
+      EventList.empty
+
+{-
+merge ::
+   EventList.T Time (Bundle a) ->
+   EventList.T Time (Bundle a) ->
+   EventList.T Time (Bundle a)
+merge x y =
+{-
+   fmap concat $
+   EventList.collectCoincident $
+-}
+   EventList.mergeBy (\_ _ -> True) x y
+-}
+
+merge ::
+   EventList.T Time (Bundle a) ->
+   EventList.T Time (Bundle a) ->
+   EventList.T Time (Bundle a)
+merge x0 y0 =
+   flip (EventList.switchL y0) x0 $ \(tx,bx) rx ->
+   flip (EventList.switchL x0) y0 $ \(ty,by) ry ->
+      let (tz, ~(bz, rz)) =
+             mapSnd
+                (\ ~(b,d) ->
+                   if b
+                     then
+                       mapFst (bx++) $
+                       if d == NonNeg.zero
+                         then (by, merge rx ry)
+                         else ([], merge rx (EventList.cons d by ry))
+                     else
+                       (by, merge (EventList.cons d bx rx) ry)) $
+             NonNeg.split tx ty
+      in  EventList.cons tz bz rz
+
+
+-- * run filters
+
+process ::
+   (EventList.T Time Event.Data ->
+    EventList.T Time EventDataTrigger) ->
+   ReaderT Handle IO ()
+process f = do
+   Common.startQueue
+   outputTriggerEvents . f =<< inputEvents
+
+processSimple ::
+   (EventList.T Time Event.Data ->
+    EventList.T Time EventDataBundle) ->
+   ReaderT Handle IO ()
+processSimple f = do
+   Common.startQueue
+   outputEventBundles . f =<< inputEvents
+
+
+runWhirl :: ReaderT Handle IO ()
+runWhirl =
+   process
+      ({-
+       we must prepend the trigger event,
+       otherwise 'mergeGenerated' makes us wait for the first user event
+       -}
+       EventList.cons 0 [(0,Trigger)] .
+       mergeGenerated whirl .
+       fmap singletonBundle)
+
+runDelay :: ReaderT Handle IO ()
+runDelay =
+   processSimple (fmap (Common.delayAdd 50 0.3))
+
+runKeyboardSplit :: ReaderT Handle IO ()
+runKeyboardSplit =
+   processSimple $
+   uncurry merge .
+   State.runState (do
+      low <-
+         filter (\e ->
+            (checkChannel (ChannelMsg.toChannel 0 ==) e &&
+             checkPitch   (VoiceMsg.toPitch 60 >) e) ||
+             checkController (VoiceMsg.toController 91 ==) e ||
+             checkController (VoiceMsg.toController 93 ==) e)
+      return $
+         fmap (mapMaybe (\(t,p) -> fmap ((,) t) $ Common.transpose 12 p) .
+               map (mapSnd (Common.setChannel (ChannelMsg.toChannel 1)))) low) .
+   fmap singletonBundle
+
+runKeyboardSplitLow :: ReaderT Handle IO ()
+runKeyboardSplitLow =
+   processSimple $
+   fmap (mapMaybe (\(t,p) -> fmap ((,) t) $ Common.transpose 12 p) .
+         map (mapSnd (Common.setChannel (ChannelMsg.toChannel 1)))) .
+   filterSimple (\e ->
+      (checkChannel (ChannelMsg.toChannel 0 ==) e &&
+       checkPitch   (VoiceMsg.toPitch 60 >) e) ||
+      checkController (VoiceMsg.toController 91 ==) e ||
+      checkController (VoiceMsg.toController 93 ==) e) .
+   fmap singletonBundle
+
+runKeyboardSplitHigh :: ReaderT Handle IO ()
+runKeyboardSplitHigh =
+   processSimple $
+--   fmap (map (mapSnd (setChannel (ChannelMsg.toChannel 0)))) .
+   filterSimple (\e ->
+      (checkChannel (ChannelMsg.toChannel 0 ==) e &&
+       checkPitch   (VoiceMsg.toPitch 60 <=) e) ||
+      checkController (const True) e ||
+      checkProgram (const True) e) .
+   fmap singletonBundle
+
+{- this defers events occasionally
+   EventList.collectCoincident .
+   fmap ((,) 0)
+-}
+
+runNote :: Channel -> Time -> Velocity -> Pitch -> ReaderT Handle IO ()
+runNote chan dur vel pit =
+   let note =
+          Event.simpleNote
+             (MALSA.fromChannel chan)
+             (MALSA.fromPitch pit)
+             (MALSA.fromVelocity vel)
+   in  do outputEvent 0
+             (Event.NoteEv Event.NoteOn note)
+          outputEvent (incTime dur 0)
+             (Event.NoteEv Event.NoteOff note)
+
+runKey :: Channel -> Bool -> Velocity -> Pitch -> ReaderT Handle IO ()
+runKey chan noteOn vel pit =
+   outputEvent 0
+      (Event.NoteEv
+         (if noteOn then Event.NoteOn else Event.NoteOff)
+         (Event.simpleNote
+             (MALSA.fromChannel chan)
+             (MALSA.fromPitch pit)
+             (MALSA.fromVelocity vel)))
+
+runController :: Channel -> Controller -> Int -> ReaderT Handle IO ()
+runController chan ctrl val =
+   outputEvent 0
+      (Event.CtrlEv Event.Controller $
+       Event.Ctrl {
+          Event.ctrlChannel = MALSA.fromChannel chan,
+          Event.ctrlParam = MALSA.fromController ctrl,
+          Event.ctrlValue = fromIntegral val
+       })
+
+runProgram :: Channel -> Program -> ReaderT Handle IO ()
+runProgram chan pgm =
+   outputEvent 0
+      (Event.CtrlEv Event.PgmChange $
+       Event.Ctrl {
+          Event.ctrlChannel = MALSA.fromChannel chan,
+          Event.ctrlParam = 0,
+          Event.ctrlValue = MALSA.fromProgram pgm
+       })
+
+{- |
+> runCyclePrograms (map VoiceMsg.toProgram [8..12])
+-}
+runCyclePrograms :: [Program] -> ReaderT Handle IO ()
+runCyclePrograms pgms =
+   processSimple
+      (flip State.evalState (cycle pgms) .
+       Trav.traverse (Common.traverseProgramsSeek (length pgms)))
+
+{- |
+> runProgramsAsBanks [8,4,4]
+-}
+runProgramsAsBanks :: [Int32] -> ReaderT Handle IO ()
+runProgramsAsBanks ns =
+   processSimple
+      (fmap singletonBundle .
+       flip State.evalState (Match.replicate ns 0) .
+       Trav.traverse (Common.programsAsBanks ns))
+
+{- |
+> runPattern 0.12 (cycleUp 4)
+-}
+runPattern ::
+   Time ->
+   Pattern i ->
+   ReaderT Handle IO ()
+runPattern dur pat =
+   process (uncurry pattern pat dur)
+
+{- |
+> runPatternTempo 0.12 (cycleUp 4)
+
+> runPatternTempo 0.2 (selectFromOctaveChord, cycle [0,1,2,0,1,2,0,1])
+-}
+runPatternTempo ::
+   Time ->
+   Pattern i ->
+   ReaderT Handle IO ()
+runPatternTempo dur pat =
+   process
+      (uncurry patternTempo pat
+         (Common.defaultTempoCtrl, (0.5*dur, dur, 1.5*dur)))
+
+
+{- |
+> runPatternMultiTempo 0.1 (selectFromLimittedChord, let pat = [item 0 1] ./ 1 /. [item 1 1] ./ 2 /. [item 1 1] ./ 1 /. [item 0 1] ./ 2 /. pat in 0 /. pat)
+-}
+runPatternMultiTempo ::
+   Time ->
+   PatternMulti i ->
+   ReaderT Handle IO ()
+runPatternMultiTempo dur pat =
+   process
+      (uncurry patternMultiTempo pat
+         (Common.defaultTempoCtrl, (0.5*dur, dur, 1.5*dur)))
+
+
+runFilterSweep ::
+   ReaderT Handle IO ()
+runFilterSweep =
+   process
+      (sweep (ChannelMsg.toChannel 1)
+         0.01 (VoiceMsg.toController 72, (0.1, 1))
+         (VoiceMsg.toController 73) (VoiceMsg.toController 91)
+         (sin . (2*pi*)))
+
+
+
+
+main :: IO ()
+main = (with $ do
+   liftIO $ putStrLn "Please connect me to a synth"
+   liftIO $ getLine
+   Common.startQueue
+   liftIO . mapM_ print =<< inputEventsCore
+   outputEvents =<< inputEvents
+   outputEventBundles whirl
+   outputEvents . EventList.mapMaybe (Common.transpose 1) =<< inputEvents)
+
+  `Exc.catch` \e ->
+      putStrLn $ "alsa_exception: " ++ Exc.show e
+
+
+
+{-
+stateless map:
+   only send an output event if there was an input event
+   without maintaining a state
+
+   change channel, program, transposition
+   split stream according to channel, program, pitch
+   merge two streams
+
+   convert key-press events to controller changes
+      this way we can control the filter frequency of a resonant lowpass
+      or we can control an external analogue synthesizer
+   convert keypress intervals to a gate signal with according velocity
+      this way we can generate an envelope for the resonance of a lowpass
+      or we can control an external analogue synthesizer
+
+stateful map:
+   only send an output event if there was an input event
+   while maintaining a state
+
+   add a bass tone to a chord
+   hold a key or a chord until the next one is played
+   play something on releasing the keys
+      this way we could control Guitar strokes up and down
+   cycle through a set of instruments for each note played
+      This way we can play syllables of a word like To-ma-ten-sa-lat.
+
+pattern:
+   use a separate clock at which events can be scheduled
+   patterns can be implemented by applying a stateful map to a beat stream
+
+   play tones of current chord upwards, downwards, ping-pong or randomly
+   generate pattern consisting of the current tone and the tone one octave above it
+   generate repeated keystrokes for the key that is constantly pressed
+   play current chord repeatedly in randomly chosen inversions
+   patterns like parity of ones in binary numbers (cf. my Flip song)
+   record and replay events in a loop
+   generate MIDI controller events according to a function of time
+   generate MIDI controller events by a random pattern,
+      this may be used to control the cutoff frequency of a resonant filter
+   delay events
+   echo: play a note multiple times with a certain delay and decreasing velocity
+   use the last n played notes for a pattern
+      with lazy access to a list, we can simulate a queue
+-}
diff --git a/streamed.cabal b/streamed.cabal
new file mode 100644
--- /dev/null
+++ b/streamed.cabal
@@ -0,0 +1,83 @@
+Name:             streamed
+Version:          0.1
+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 event streams via ALSA
+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@, @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,
+   Echo simulation.
+
+   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 program that demonstrates various effects.
+Tested-With:      GHC==6.10.4
+Cabal-Version:    >=1.6
+Build-Type:       Simple
+Source-Repository head
+  type:     darcs
+  location: http://code.haskell.org/~thielema/streamed/
+
+Source-Repository this
+  type:     darcs
+  location: http://code.haskell.org/~thielema/streamed/
+  tag:      0.1
+
+Flag splitBase
+  description: Choose the new smaller, split-up base package.
+
+Flag buildExamples
+  description: Build example executables
+  default:     False
+
+Library
+  Build-Depends:
+    midi-alsa >=0.1 && <0.2,
+    midi >=0.1.5 && <0.2,
+    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,
+    bytestring >=0.9.0.1 && <0.10,
+    containers >=0.2 && <0.4,
+    transformers >=0.2 && <0.3
+  If flag(splitBase)
+    Build-Depends:
+      random >=1 && <2,
+      base >= 2 && <6
+  Else
+    Build-Depends:
+      base >= 1.0 && < 2
+
+  GHC-Options:      -Wall
+  Hs-Source-Dirs:   src
+  Exposed-Modules:
+    Sound.MIDI.ALSA.Causal
+    Sound.MIDI.ALSA.EventList
+    Sound.MIDI.ALSA.Common