streamed (empty) → 0.1
raw patch · 6 files changed
+2206/−0 lines, 6 filesdep +alsa-coredep +alsa-seqdep +basesetup-changed
Dependencies added: alsa-core, alsa-seq, base, bytestring, containers, data-accessor, data-accessor-transformers, event-list, midi, midi-alsa, non-negative, random, transformers, utility-ht
Files
- LICENSE +31/−0
- Setup.lhs +3/−0
- src/Sound/MIDI/ALSA/Causal.hs +547/−0
- src/Sound/MIDI/ALSA/Common.hs +792/−0
- src/Sound/MIDI/ALSA/EventList.hs +750/−0
- streamed.cabal +83/−0
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ src/Sound/MIDI/ALSA/Causal.hs view
@@ -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)))
+ src/Sound/MIDI/ALSA/Common.hs view
@@ -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
+ src/Sound/MIDI/ALSA/EventList.hs view
@@ -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+-}
+ streamed.cabal view
@@ -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