streamed 0.1 → 0.2
raw patch · 7 files changed
+1975/−833 lines, 7 filesdep −bytestringdep ~basedep ~containersdep ~midi-alsa
Dependencies removed: bytestring
Dependency ranges changed: base, containers, midi-alsa
Files
- src/Sound/MIDI/ALSA/Causal.hs +1070/−546
- src/Sound/MIDI/ALSA/CausalExample.hs +232/−0
- src/Sound/MIDI/ALSA/Common.hs +457/−133
- src/Sound/MIDI/ALSA/EventList.hs +51/−143
- src/Sound/MIDI/ALSA/Guitar.hs +37/−0
- src/Sound/MIDI/ALSA/Training.hs +110/−0
- streamed.cabal +18/−11
src/Sound/MIDI/ALSA/Causal.hs view
@@ -1,547 +1,1071 @@ {-# 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)))+module Sound.MIDI.ALSA.Causal (+ T,+ lift,+ liftPoint,+ map,+ parallel,+ eitherIn,+ traverse,+ flatten,+ process,+ transpose,+ reverse,+ delayAdd,++ Pattern,+ patternMono,++ TempoControl,+ patternTempo,+ patternMonoTempo,+ patternPolyTempo,+ patternSerialTempo,++ sweep,+ partition,+ guide,+ guideWithMode,+ cyclePrograms,+ cycleProgramsDefer,+ latch,+ groupLatch,+ serialLatch,+ guitar,+ trainer,+ ) where++import Sound.MIDI.ALSA.Common (Time, TimeAbs, normalVelocity, )+import qualified Sound.MIDI.ALSA.Common as Common+import qualified Sound.MIDI.ALSA.Guitar as Guitar++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.Voice as VoiceMsg+import qualified Sound.MIDI.Message.Channel.Mode as ModeMsg++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.Absolute.TimeBody as EventListAbs++import qualified Data.Accessor.Monad.Trans.RWS as AccRWS+import qualified Data.Accessor.Monad.Trans.State as AccState+import qualified Data.Accessor.Tuple as AccTuple+import Data.Accessor.Basic ((^.), (^=), )++import Data.Tuple.HT (fst3, )+import Data.Ord.HT (limit, comparing, )+import Data.Maybe (maybeToList, )+import qualified Data.List.Match as Match+import qualified Data.List as List++import qualified Data.Map as Map+import qualified Data.Set as Set++import qualified Control.Category as Cat+import qualified Control.Applicative as App+import qualified Control.Monad.Trans.State as State+import qualified Control.Monad.Trans.Reader as Reader+import qualified Control.Monad.Trans.RWS as RWS+import qualified Control.Monad.Trans.Class as Trans+import qualified Data.Traversable as Trav+import Control.Category ((.), id, )+import Control.Monad.Trans.Reader (ReaderT, )+import Control.Monad (guard, when, )++import qualified Data.Monoid as Mn+import Data.Word (Word8, )++import Prelude hiding (init, map, filter, reverse, (.), id, )+++{- |+The list of scheduled triggers must be finite.++This process cannot drop an incoming event.+In order to do so, you must write something of type @T a (Maybe b)@.+For convenience you could wrap this in something like @Ext a b@.+-}+data T a b =+ forall s c.+ Cons+ (Either c a -> RWS.RWS TimeAbs (Triggers c) s b)+ s (Triggers c)+++newtype Triggers c = Triggers (EventList.T Time c)++instance Functor Triggers where+ fmap f (Triggers evs) = Triggers $ fmap f evs++instance Mn.Monoid (Triggers c) where+ mempty = Triggers $ EventList.empty+ mappend (Triggers x) (Triggers y) =+ Triggers (Common.mergeStable x y)++{-+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.+Alternatively we can always ship them via ALSA+and filter them out on arrival, when they were canceled in the meantime.+To this end we could attach a unique id to every Echo message+and on ALSA input we accept only the message with the most recent id.++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 trigger.+ Trigger trigger =>+ Cons (Time -> Maybe a ->+ State.State (s, trigger) (Maybe b))++'trigger' is a nested structure of time-stamped objects,+where each leaf object corresponds to a process in the chain.+E.g. (Maybe (Time, x), Maybe (Time, y))+In order to reduce recomputation,+there might be a special type for pairs that stores the minimum time stamp.+-}+{-+data T a b =+ forall s c.+ Cons (Time -> Maybe a ->+ State.State (s, EventList.T Time c) (Maybe b))+-}+++-- * combinators++{- |+Here we abuse the 'Applicative' constraint.+Actually we only need 'pure'.+-}+lift ::+ (App.Applicative t, Trav.Traversable t) =>+ T a b -> T (t a) (t b)+lift = liftPoint App.pure++{- |+Typical instance for the traversable type 't' are '[]' and 'Maybe'.+-}+liftPoint ::+ (Trav.Traversable t) =>+ (b -> t b) {- should be replaced by Pointed constraint -} ->+ T a b -> T (t a) (t b)+liftPoint pure (Cons f s cs0) =+ Cons+ (\ ea ->+ case ea of+ Left c ->+ fmap pure $ f $ Left c+ Right ta ->+ Trav.mapM (f . Right) ta)+ s cs0+++map :: (a -> b) -> T a b+map f =+ Cons+ {-+ In case of a trigger, we use the trigger data for output.+ Since there won't ever be a trigger,+ we never have to create an output object.+ -}+ (return . either id f)+ () Mn.mempty+++mergeEither :: Triggers a -> Triggers b -> Triggers (Either a b)+mergeEither (Triggers eva) (Triggers evb) =+ Triggers $ Common.mergeEither eva evb++compose :: T b c -> T a b -> T a c+compose (Cons g sg tg) (Cons f sf tf) =+ Cons+ (\ma -> do+ b <-+ routeLeft $+ case ma of+ Right a ->+ fmap Right $ f (Right a)+ Left (Left et) ->+ fmap Right $ f (Left et)+ Left (Right et) ->+ return $ Left et+ routeRight $ g b)+ (sf,sg)+ (mergeEither tf tg)++{- |+Run two stream processor in parallel.+We cannot use the @Arrow@ method @&&&@+since we cannot define 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 (\ea ->+ case ea of+ Right a ->+ App.liftA2+ Mn.mappend+ (routeLeft $ f $ Right a)+ (routeRight $ g $ Right a)+ Left (Left et) ->+ routeLeft $ f $ Left et+ Left (Right et) ->+ routeRight $ g $ Left et)+ (sf,sg)+ (mergeEither tf tg)++eitherIn ::+ T a c -> T b c -> T (Either a b) c+eitherIn (Cons f sf tf) (Cons g sg tg) =+ Cons (\ea ->+ case ea of+ Right (Left a) ->+ routeLeft $ f $ Right a+ Right (Right b) ->+ routeRight $ g $ Right b+ Left (Left et) ->+ routeLeft $ f $ Left et+ Left (Right et) ->+ routeRight $ g $ Left et)+ (sf,sg)+ (mergeEither tf tg)++routeLeft ::+ RWS.RWS r (Triggers w0) s0 a ->+ RWS.RWS r (Triggers (Either w0 w1)) (s0, s1) a+routeLeft =+ mapWriter (fmap Left) .+ AccRWS.lift AccTuple.first++routeRight ::+ RWS.RWS r (Triggers w1) s1 a ->+ RWS.RWS r (Triggers (Either w0 w1)) (s0, s1) a+routeRight =+ mapWriter (fmap Right) .+ AccRWS.lift AccTuple.second++scheduleSingleTrigger :: Time -> c -> RWS.RWS r (Triggers c) s ()+scheduleSingleTrigger t c =+ RWS.tell $ singleTrigger t c++singleTrigger :: Time -> c -> Triggers c+singleTrigger t c =+ Triggers $ EventList.singleton t c+++instance Cat.Category T where+ id = map id+ (.) = compose+++traverse :: s -> (a -> State.State s b) -> T a b+traverse s f =+ Cons+ (rwsFromState . either id f)+ s Mn.mempty++-- | input is most oftenly of type 'Common.EventDataBundle'+flatten :: T (Common.Bundle a) (Maybe a)+flatten = Cons+ (\e ->+ case e of+ Left ev -> return $ Just ev+ Right evs -> do+ RWS.tell $ Triggers $+ EventList.fromAbsoluteEventList $+ EventListAbs.fromPairList $+ List.sortBy (comparing fst) evs+ return Nothing)+ () Mn.mempty+++partition :: (a -> Bool) -> T a (Maybe a, Maybe a)+partition p =+ map (\a -> if p a then (Just a, Nothing) else (Nothing, Just a))+++_guideMonoid ::+ (Mn.Monoid b) =>+ (a -> Bool) -> T a b -> T a b -> T a b+_guideMonoid p f g =+ map (maybe Mn.mempty id)+ .+ parallel+ (lift f . map fst)+ (lift g . map snd)+ .+ partition p++guide ::+ (a -> Bool) -> T a b -> T a b -> T a b+guide p f g =+ eitherIn f g+ .+ map (\x -> if p x then Left x else Right x)++{-+In some cases where we would like to use 'guide',+channel mode messages like 'ModeMsg.AllNotesOff'+must be directed to both branches,+because they may end up in different MIDI channels.+-}+guideWithMode ::+ (Mn.Monoid b) =>+ (Event.Data -> Bool) ->+ T Event.Data b -> T Event.Data b -> T Event.Data b+guideWithMode p f g =+ map Mn.mconcat+ .+ parallel+ (map maybeToList . lift f . map fst)+ (map maybeToList . lift g . map snd)+ .+ map (\e ->+ if Common.checkMode (const True) e+ then (Just e, Just e)+ else if p e then (Just e, Nothing) else (Nothing, Just e))+++-- * driver++{- |+TODO:+We should allow the process to access and modify the ALSA port number.+-}+process ::+ T Event.Data Common.EventDataBundle ->+ ReaderT Common.Handle IO ()+process (Cons f s (Triggers 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, (dats, s1, Triggers newTriggers)) =+ case Event.body ev of+ Event.CustomEv Event.Echo _ ->+ case (Event.source ev ==+ Addr.Cons (Common.client h) (Common.portPrivate h),+ EventList.viewL triggers1) of+ (True, Just ((_,c),restTriggers0)) ->+ (restTriggers0,+ RWS.runRWS (f (Left c)) time s0)+ _ ->+ (EventList.empty, ([], s0, Mn.mempty))+ dat ->+ (triggers1,+ RWS.runRWS (f (Right dat)) time s0)++ 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,+ Common.mergeStable restTriggers1 newTriggers)+ in outputTriggers initTriggers >>+ Event.drainOutput (Common.sequ h) >>+ go s (0,initTriggers)+++-- * musical examples++transpose :: Int -> T Event.Data (Maybe Event.Data)+transpose d =+ map (Common.transpose d)++{- |+Swap order of keys.+This is a funny effect and a new challenge to playing a keyboard.+-}+reverse :: T Event.Data (Maybe Event.Data)+reverse =+ map Common.reverse++delayAdd ::+ Word8 -> Time -> T Event.Data Common.EventDataBundle+delayAdd decay d =+ map (Common.delayAdd decay d)+++patternMono ::+ Common.PatternMono i ->+ Time ->+ T Event.Data Common.EventDataBundle+patternMono (Common.PatternMono select ixs) dur =+ Cons+ (\ ee ->+ case ee of+ Left (n:ns) -> do+ keys <- RWS.get+ scheduleSingleTrigger dur ns+ return $ select n dur $ Map.toAscList keys+ Left [] ->+ return []+ Right e ->+ case e of+ Event.NoteEv notePart note -> do+ RWS.modify (Common.updateChord notePart note)+ return []+ _ -> return $ Common.singletonBundle e)+ Map.empty (singleTrigger 0 ixs)++updateChordDur ::+ (Channel, Controller) ->+ (Time, Time) ->+ Event.Data ->+ State.State+ (Time, Common.KeySet)+ (Common.EventDataBundle)+updateChordDur chanCtrl minMaxDur e =+ case e of+ Event.NoteEv notePart note -> do+ AccState.modify AccTuple.second (Common.updateChord notePart note)+ return []+ Event.CtrlEv Event.Controller param |+ uncurry Common.controllerMatch chanCtrl param -> do+ AccState.set AccTuple.first (Common.updateDur param minMaxDur)+ return []+ _ -> return $ Common.singletonBundle e+++type TempoControl = ((Channel,Controller), (Time,Time,Time))++patternMonoTempo ::+ Common.PatternMono i ->+ TempoControl ->+ T Event.Data Common.EventDataBundle+patternMonoTempo+ (Common.PatternMono select ixs)+ ((chan,ctrl), (minDur, defltDur, maxDur)) =+ Cons+ (\ ee ->+ case ee of+ Left (n:ns) -> do+ (dur,keys) <- RWS.get+ scheduleSingleTrigger dur ns+ return $ select n dur $ Map.toAscList keys+ Left [] ->+ return []+ Right e ->+ rwsFromState $+ updateChordDur (chan,ctrl) (minDur,maxDur) e)+ (defltDur, Map.empty)+ (singleTrigger 0 ixs)++patternPolyTempo ::+ Common.PatternPoly i ->+ TempoControl ->+ T Event.Data Common.EventDataBundle+patternPolyTempo+ (Common.PatternPoly 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+ (\ ee ->+ case ee of+ Left nt ->+ EventList.switchL+ (return [])+ (\(_,is) rest -> do+ (dur,keys) <- RWS.get+ RWS.tell $ Triggers $ next dur rest+ return $ do+ Common.IndexNote d i <- is+ select i (fromIntegral d * dur) $+ Map.toAscList keys)+ nt+ Right e ->+ rwsFromState $+ updateChordDur (chan,ctrl) (minDur,maxDur) e)+ (defltDur, Map.empty)+ (Triggers $ next defltDur ixs)+++class Pattern pat where+ patternTempo ::+ pat ->+ TempoControl ->+ T Event.Data Common.EventDataBundle++instance Pattern (Common.PatternMono i) where+ patternTempo = patternMonoTempo++instance Pattern (Common.PatternPoly i) where+ patternTempo = patternPolyTempo++++{-+TODO:+This should not prepend a new key to the queue,+but we should maintain an array of maxNum elements,+where the n-th key is put into the @mod n maxNum@ array element.+-}+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)+ (Common.EventDataBundle)+updateSerialChordDur maxNum chanCtrl minMaxDur e =+ case e of+ Event.NoteEv notePart note -> do+ AccState.modify AccTuple.second (updateSerialChord maxNum notePart note)+ return []+ Event.CtrlEv Event.Controller param |+ uncurry Common.controllerMatch chanCtrl param -> do+ AccState.set AccTuple.first (Common.updateDur param minMaxDur)+ return []+ _ -> return $+ Common.singletonBundle e++{-+TODO:+It should react on 'ModeMsg.AllNotesOff' and 'ModeMsg.AllSoundOff'.+Is there a way to merge it with 'serialLatch'?+-}+patternSerialTempo ::+ Int ->+ Common.PatternMono i ->+ TempoControl ->+ T Event.Data Common.EventDataBundle+patternSerialTempo+ maxNum (Common.PatternMono select ixs)+ ((chan,ctrl), (minDur, defltDur, maxDur)) =+ Cons+ (\ ee ->+ case ee of+ Left (n:ns) -> do+ (dur,keys) <- RWS.get+ scheduleSingleTrigger dur ns+ return $ select n dur keys+ Left [] ->+ return []+ Right e ->+ rwsFromState $+ updateSerialChordDur maxNum (chan,ctrl) (minDur,maxDur) e)+ (defltDur, [])+ (singleTrigger 0 ixs)+++sweep ::+ Channel ->+ Time ->+ (Controller, (Time,Time)) ->+ Controller ->+ Controller ->+ (Double -> Double) ->+ T Event.Data [Event.Data]+sweep chan dur (speedCtrl, (minSpeed, maxSpeed)) depthCtrl centerCtrl+ wave =+ Cons+ (\ ee ->+ case ee of+ Left () -> do+ ev <-+ RWS.gets $ \s ->+ Event.CtrlEv Event.Controller $+ MALSA.controllerEvent chan centerCtrl $+ round $ limit (0,127) $+ Common.sweepCenter s ++ Common.sweepDepth s * wave (Common.sweepPhase s)+ RWS.modify $ \s ->+ s{Common.sweepPhase =+ Common.fraction (Common.sweepPhase s + Common.sweepSpeed s)}+ scheduleSingleTrigger dur ()+ return [ev]+ Right e ->+ maybe (return [e])+ (\f -> RWS.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{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+ })+ (singleTrigger 0 ())++cyclePrograms :: [Program] -> T Event.Data [Event.Data]+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.+-}+{-+In the future we might also add a time-out:+After a certain time, where no key is pressed,+the program would be reset to the initial program.+-}+cycleProgramsDefer :: Time -> [Program] -> T Event.Data [Event.Data]+cycleProgramsDefer defer pgms =+ Cons+ (either+ (\() -> do+ AccRWS.set AccTuple.second False+ return [])+ (\e -> do+ -- FIXME: traverseProgramsSeek is not called, if a program change is received+ block <- RWS.gets snd+ case (block, e) of+ (False, Event.NoteEv notePart note) ->+ case fst $ normalNoteFromEvent notePart note of+ Event.NoteOn -> do+ AccRWS.set AccTuple.second True+ scheduleSingleTrigger defer ()+ AccRWS.lift AccTuple.first $ rwsFromState $+ Common.traverseProgramsSeek (length pgms) e+ _ -> return [e]+ _ -> return [e]))+ (cycle pgms, False) Mn.mempty+++latch :: T Event.Data (Maybe Event.Data)+latch =+ traverse Set.empty+ (\e ->+ case e of+ Event.NoteEv notePart note ->+ case normalNoteFromEvent notePart note of+ (Event.NoteOn, vel) -> do+ let key =+ (note ^. MALSA.notePitch,+ note ^. MALSA.noteChannel)+ newNote =+ (MALSA.noteVelocity ^= vel) note+ pressed <- State.gets (Set.member key)+ if pressed+ then+ State.modify (Set.delete key) >>+ return (Just (Event.NoteEv Event.NoteOff newNote))+ else+ State.modify (Set.insert key) >>+ return (Just (Event.NoteEv Event.NoteOn newNote))+ (Event.NoteOff, _vel) ->+ return Nothing+ _ -> return (Just e)+ _ -> return (Just e))++releaseKey ::+ VoiceMsg.Velocity ->+ (VoiceMsg.Pitch, Channel) ->+ Event.Data+releaseKey vel (p,c) =+ Event.NoteEv Event.NoteOff $+ Common.simpleNote c p vel++releasePlayedKeys ::+ VoiceMsg.Velocity ->+ State.State+ (a, Set.Set (VoiceMsg.Pitch, Channel))+ [Event.Data]+releasePlayedKeys vel =+ fmap (fmap (releaseKey vel) . Set.toList) $+ AccState.getAndModify AccTuple.second (const Set.empty)+++isAllNotesOff :: Event.Data -> Bool+isAllNotesOff =+ Common.checkMode $ \mode ->+ mode == ModeMsg.AllSoundOff ||+ mode == ModeMsg.AllNotesOff++{- |+All pressed keys are latched until a key is pressed after a pause+(i.e. all keys released).+For aborting the pattern you have to send+a 'ModeMsg.AllNotesOff' or 'ModeMsg.AllSoundOff' message.+-}+groupLatch :: T Event.Data [Event.Data]+groupLatch =+ traverse+ (Set.empty {- pressed keys (input) -},+ Set.empty {- played keys (output) -})+ (\e ->+ case e of+ Event.NoteEv notePart note ->+ let key =+ (note ^. MALSA.notePitch,+ note ^. MALSA.noteChannel)+ in case normalNoteFromEvent notePart note of+ (Event.NoteOn, vel) -> do+ pressed <- AccState.get AccTuple.first+ noteOffs <-+ if Set.null pressed+ then releasePlayedKeys vel+ else return []+ AccState.modify AccTuple.first (Set.insert key)+ played <- AccState.get AccTuple.second+ noteOn <-+ if Set.member key played+ then+ return []+ else do+ AccState.modify AccTuple.second (Set.insert key)+ return [Event.NoteEv Event.NoteOn note]+ return $+ noteOffs ++ noteOn+ (Event.NoteOff, _vel) ->+ AccState.modify AccTuple.first (Set.delete key) >>+ return []+ _ -> return [e]+ _ ->+ if isAllNotesOff e+ then releasePlayedKeys normalVelocity+ else return [e])++{- |+A key is hold until @n@ times further keys are pressed.+The @n@-th pressed key replaces the current one.+-}+serialLatch :: Int -> T Event.Data [Event.Data]+serialLatch n =+ traverse+ (0, Map.empty)+ (\e ->+ case e of+ Event.NoteEv notePart note ->+ let key =+ (note ^. MALSA.notePitch,+ note ^. MALSA.noteChannel)+ in case normalNoteFromEvent notePart note of+ (Event.NoteOn, vel) -> do+ k <- AccState.getAndModify AccTuple.first (flip mod n . (1+))+ oldKey <- fmap (Map.lookup k) $ AccState.get AccTuple.second+ AccState.modify AccTuple.second (Map.insert k key)+ return $+ maybeToList (fmap (releaseKey vel) oldKey) ++ [e]+ (Event.NoteOff, _vel) -> return []+ _ -> return [e]+ _ ->+ if isAllNotesOff e+ then+ fmap (fmap (releaseKey normalVelocity) . Map.elems) $+ AccState.getAndModify AccTuple.second (const Map.empty)+ else return [e])++++newtype PitchChannel =+ PitchChannel ((VoiceMsg.Pitch, Channel), VoiceMsg.Velocity)+ deriving (Show)++instance Eq PitchChannel where+ (PitchChannel ((p0,_), _)) == (PitchChannel ((p1,_), _)) =+ p0 == p1++instance Ord PitchChannel where+ compare (PitchChannel ((p0,_), _)) (PitchChannel ((p1,_), _)) =+ compare p0 p1++instance Guitar.Transpose PitchChannel where+ getPitch (PitchChannel ((p,_), _)) =+ VoiceMsg.fromPitch p+ transpose d (PitchChannel ((p,c),v)) = do+ p' <- Common.increasePitch d p+ return $ PitchChannel ((p',c), v)+++noteSequence ::+ (Num a) =>+ a -> Event.NoteEv -> [Event.Note] -> [(a, Event.Data)]+noteSequence stepTime onOff notes =+ zip (iterate (stepTime+) 0) $+ fmap (Event.NoteEv onOff) notes++{- |+Try for instance @guitar 0.05 0.03@.++This process simulates playing chords on a guitar.+If you press some keys like C, E, G on the keyboard,+then this process figures out what tones would be played on a guitar+and plays them one after another with short delays.+If you release the keys then the chord is played in reverse order.+This simulates the hand going up and down on the guitar strings.+Unfortunatley it is not possible to go up twice or go down twice this way.+The octaves of the pressed keys are ignored.++In detail calling @guitar collectTime stepTime@ means:+If a key is pressed,+then collect all key-press events for the next @collectTime@ seconds.+After this period, send out a guitar-like chord pattern for the pressed keys+with a delay of @stepTime@ between the notes.+Now wait until all keys are released.+Note that in the meantime keys could have been pressed or released.+They are registered, but not played.+If all keys are released then send out the reverse chord.++On an AllSoundOff message, release all played tones.++I don't know whether emitted key-events are always consistent.+-}+guitar :: Time -> Time -> T Event.Data Common.EventDataBundle+guitar collectTime stepTime = Cons+ (\ee ->+ case ee of+ Left () -> do+ pressed <- AccRWS.get AccTuple.first3+ played <- AccRWS.get AccTuple.second3+ let chord =+ fmap (\(PitchChannel ((p,c),v)) ->+ MALSA.noteEvent c p v v 0) $+ Guitar.mapChordToString Guitar.stringPitches $+ fmap PitchChannel $+ Map.toAscList pressed+ AccRWS.set AccTuple.second3 chord+ return $+ (noteSequence stepTime Event.NoteOff $+ List.reverse played)+ +++ noteSequence stepTime Event.NoteOn chord+ Right e ->+ case e of+ Event.NoteEv notePart note -> do+ let key =+ (note ^. MALSA.notePitch,+ note ^. MALSA.noteChannel)+ normalNote =+ normalNoteFromEvent notePart note+ case normalNote of+ (Event.NoteOn, vel) ->+ AccRWS.modify AccTuple.first3 (Map.insert key vel)+ (Event.NoteOff, _vel) ->+ AccRWS.modify AccTuple.first3 (Map.delete key)+ _ -> return ()++ down <- AccRWS.get AccTuple.third3+ if down+ then do+ allKeysReleased <-+ RWS.gets (Map.null . fst3)+ if allKeysReleased+ then do+ AccRWS.set AccTuple.third3 False+ played <- AccRWS.get AccTuple.second3+ return $+ noteSequence stepTime Event.NoteOff played+ +++ (noteSequence stepTime Event.NoteOn $+ List.reverse played)+ else return []+ else+ fmap (const []) $+ case fst normalNote of+ Event.NoteOn -> do+ scheduleSingleTrigger collectTime ()+ AccRWS.set AccTuple.third3 True+ _ -> return ()+ _ ->+ if isAllNotesOff e+ then do+ player <- AccRWS.getAndModify AccTuple.second3 (const [])+ return $ Common.immediateBundle $+ fmap (Event.NoteEv Event.NoteOff) player+ else return $ Common.singletonBundle e)+ (Map.empty {- pressed keys (input) -},+ [] {- played tones (output) -},+ False)+ Mn.mempty+++{- |+Audio perception trainer++Play sets of notes and+let the human player answer to them according to a given scheme.+Repeat playing the notes sets until the trainee answers correctly.+Then continue with other sequences, maybe more complicated ones.++possible tasks:++ - replay a sequence of pitches on the keyboard:+ single notes for training abolute pitches,+ intervals all with the same base notes,+ intervals with different base notes++ - transpose a set of pitches:+ tranpose to a certain base note,+ transpose by a certain interval++ - play a set of pitches in a different order:+ reversed order,+ in increasing pitch++ - replay a set of simultaneously pressed keys++The difficulty can be increased by not connecting+the keyboard directly with the sound generator.+This way, the trainee cannot verify,+how the pressed keys differ from the target keys.++Sometimes it seems that you are catched in an infinite loop.+This happens if there were too many keys pressed.+The trainer collects all key press events,+not only the ones that occur after the target set is played.+This way you can correct yourself immediately,+before the target is repeatedly played.+The downside is, that there may be key press events hanging around.+You can get rid of them by pressing a key again and again,+but slowly, until the target is played, again.+Then the queue of registered keys should be empty+and you can proceed training.+-}+trainer ::+ Channel ->+ Time -> Time -> [([VoiceMsg.Pitch], [VoiceMsg.Pitch])] ->+ T Event.Data Common.EventDataBundle+trainer chan pause duration sets0 = Cons+ (\ee ->+ case ee of+ Left () -> do+ sets <- AccRWS.get AccTuple.first+ return $+ case sets of+ (target, _) : _ ->+ concat $+ zipWith+ (\t p ->+ [(t, Event.NoteEv Event.NoteOn $+ Common.simpleNote chan p normalVelocity),+ (t+duration,+ Event.NoteEv Event.NoteOff $+ Common.simpleNote chan p normalVelocity)])+ (iterate (duration+) 0) target+ [] -> []+ Right (Event.NoteEv notePart note) ->+ case fst $ normalNoteFromEvent notePart note of+ Event.NoteOn -> do+ pressed <- AccRWS.get AccTuple.second+ let newPressed = (note ^. MALSA.notePitch) : pressed+ AccRWS.set AccTuple.second newPressed+ sets <- AccRWS.get AccTuple.first+ case sets of+ (_, target) : rest ->+ when (Match.lessOrEqualLength target newPressed) $ do+ AccRWS.set AccTuple.second []+ when (newPressed == List.reverse target) $+ AccRWS.set AccTuple.first rest+ scheduleSingleTrigger pause ()+ _ -> return ()+ return []+ _ -> return []+ _ -> return [])+ (sets0, [])+ (singleTrigger 0 ())++++-- * auxiliary functions for monad transformers++rwsFromState ::+ (Mn.Monoid w, Monad m) =>+ State.StateT s m a -> RWS.RWST r w s m a+rwsFromState act = do+ s0 <- RWS.get+ (a,s1) <- Trans.lift $ State.runStateT act s0+ RWS.put s1+ return a+++mapWriter ::+ (Mn.Monoid w0, Mn.Monoid w1, Monad m) =>+ (w0 -> w1) -> RWS.RWST r w0 s m a -> RWS.RWST r w1 s m a+mapWriter f act =+ RWS.RWST $ \r s0 -> do+ (a, s1, w) <- RWS.runRWST act r s0+ return (a, s1, f w)
+ src/Sound/MIDI/ALSA/CausalExample.hs view
@@ -0,0 +1,232 @@+module Sound.MIDI.ALSA.CausalExample where++import qualified Sound.MIDI.ALSA.Causal as Causal+import qualified Sound.MIDI.ALSA.Common as Common+import qualified Sound.MIDI.ALSA.Training as Training++import Sound.MIDI.ALSA.Causal+ (process, map, lift, guide, guideWithMode,+ patternTempo, transpose, )+import Sound.MIDI.ALSA.Common+ (channel, pitch, program, controller, velocity, )++import qualified Sound.MIDI.Controller as Ctrl+import qualified Sound.MIDI.Message.Channel.Mode as ModeMsg++import qualified System.Random as Random++import Data.Ord.HT (limit, )+import Data.Maybe (fromMaybe, )+import qualified Data.List as List++import Control.Category ((.), )+import Control.Monad.Trans.Reader (ReaderT, )++import Prelude hiding (init, map, filter, (.), id, reverse, )+++defaultTempo :: Causal.TempoControl+defaultTempo =+ (Common.defaultTempoCtrl, (0.25, 0.12, 0.05))+++run :: ReaderT Common.Handle IO a -> IO a+run x = Common.with $ Common.connectLLVM >> x+++pass,+ reverse,+ delay,+ cycleUp,+ cycleUpTempo,+ cycleUpPoly,+ sweep,+ split,+ splitPattern,+ serialPattern,+ serialLatch,+ cyclePrograms,+ cycleProgramsDefer,+ binary,+ crossSum,+ bruijn,+ latch,+ groupLatch,+ groupCycleUp,+ groupBinary,+ groupCrossSum,+ groupBruijn,+ groupRandom,+ groupRandomInversions,+ filterKey,+ guitar,+ sendProgram,+ sendMode,+ releaseAllKeys :: ReaderT Common.Handle IO ()++pass =+ process (map (maybe [] Common.singletonBundle) . transpose 12)++reverse =+ process (map (maybe [] Common.singletonBundle) . Causal.reverse)++delay =+ process (Causal.delayAdd 50 1)++cycleUp =+ process (Causal.patternMono (Common.cycleUp 4) 0.12)++cycleUpTempo =+ process (patternTempo (Common.cycleUp 4) defaultTempo)++cycleUpPoly =+ process (patternTempo+ (Common.PatternPoly+ Common.selectFromLimittedChord+ Common.examplePatternPolyTempo1)+ defaultTempo)++sweep =+ process+ (map Common.immediateBundle+ .+ Causal.sweep (channel 1)+ 0.01 (controller 16, (0.1, 1))+ (controller 17) (controller 94)+ (sin . (2*pi*)))++split =+ process+ (guideWithMode+ (\e ->+ (Common.checkChannel (channel 0 ==) e &&+ Common.checkPitch (pitch 60 >) e) ||+ Common.checkController (controller 94 ==) e ||+ Common.checkController (controller 95 ==) e)+ (map (maybe [] Common.singletonBundle)+ .+ transpose 12+ .+ map (Common.setChannel (channel 1)))+ (map (maybe [] Common.singletonBundle)+ .+ transpose 0))++splitPattern =+ process+ (guideWithMode+ (\e ->+ Common.checkPitch (pitch 60 >) e ||+ Common.checkController (snd Common.defaultTempoCtrl ==) e)+ (map concat+ .+ lift (patternTempo (Common.cycleUp 4) defaultTempo)+ .+ map (fromMaybe [])+ .+ lift Causal.groupLatch+ .+ transpose 12)+ (map Common.singletonBundle))++serialPattern =+ process (Causal.patternSerialTempo 4 (Common.cycleUp 4) defaultTempo)++serialLatch =+ process (map Common.immediateBundle . Causal.serialLatch 4)++cyclePrograms =+ process+ (map Common.immediateBundle .+ Causal.cyclePrograms (List.map program [16..20]))++cycleProgramsDefer =+ process+ (map Common.immediateBundle .+ Causal.cycleProgramsDefer 0.1+ (List.map program [16..20]))++binary =+ process (patternTempo Common.binaryLegato defaultTempo)++crossSum =+ process (patternTempo (Common.crossSum 4) defaultTempo)++bruijn =+ process (patternTempo (Common.bruijnPat 4 2) defaultTempo)++latch =+ process (map (maybe [] Common.singletonBundle) . Causal.latch)++groupLatch =+ process (map Common.immediateBundle . Causal.groupLatch)+++withGroup ::+ (Causal.Pattern pat) =>+ pat -> ReaderT Common.Handle IO ()+withGroup f =+ process+ (map concat+ .+ lift (patternTempo f defaultTempo)+ .+ Causal.groupLatch)++groupBinary =+ withGroup Common.binaryLegato++groupCrossSum =+ withGroup (Common.crossSum 4)++groupBruijn =+ withGroup (Common.bruijnPat 4 2)++groupCycleUp =+ withGroup (Common.cycleUp 4)++groupRandom =+ withGroup Common.random++groupRandomInversions =+ withGroup Common.randomInversions++filterKey =+ process+ (map (maybe [] Common.singletonBundle)+ .+ guide+ (Common.checkPitch (pitch 60 >))+ (transpose 12)+ (map (Common.controllerFromNote+ (\p ->+ {-+ A880 shall be mapped to the center of the controller,+ and the note intervals shall be mapped to according frequency ratios.+ It is adapted to the current configuration of LLVM synthesizer.+ -}+ limit (0,127) $ 2*(p-69)+64)+-- (controller 91))))+ (Ctrl.effect4Depth))))++guitar =+ process (Causal.guitar 0.05 0.03)+++trainer ::+ (Random.RandomGen g) =>+ g -> ReaderT Common.Handle IO ()+trainer g =+ process (Causal.trainer (channel 0) 0.5 0.3 (Training.all g))++sendProgram =+ Common.sendProgram (channel 0) (program 0) >>+ process (map Common.singletonBundle)++sendMode =+ Common.sendMode (channel 0) ModeMsg.AllNotesOff++releaseAllKeys =+ mapM_+ (Common.sendKey (channel 0) False (velocity 0))+ [minBound..maxBound]
src/Sound/MIDI/ALSA/Common.hs view
@@ -13,29 +13,35 @@ import qualified Sound.MIDI.ALSA as MALSA import qualified Sound.MIDI.Message.Channel as ChannelMsg import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Sound.MIDI.Message.Channel.Mode as Mode import Sound.MIDI.ALSA (normalNoteFromEvent, ) import Sound.MIDI.Message.Channel (Channel, ) import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, Controller, Program, ) import qualified Data.EventList.Relative.TimeBody as EventList-import qualified Data.EventList.Relative.MixedBody as EventListMB import Data.EventList.Relative.MixedBody ((/.), (./), ) import Data.Accessor.Basic ((^.), (^=), ) +import qualified Data.List.Match as Match import qualified Data.List.HT as ListHT+import qualified Data.List as List import Data.Maybe.HT (toMaybe, ) import Data.Tuple.HT (mapFst, mapSnd, )-import qualified Data.List as List+import Data.Maybe (mapMaybe, ) import qualified System.Random as Rnd import qualified Data.Map as Map+import qualified Data.Set as Set +import qualified Data.Bits as Bits+import Data.Bits ((.&.), )+ 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 Control.Monad (guard, replicateM, ) import qualified Numeric.NonNegative.Class as NonNeg @@ -44,7 +50,7 @@ import Data.Word (Word8, ) import Data.Int (Int32, ) -import Prelude hiding (init, filter, )+import Prelude hiding (init, filter, reverse, ) -- * helper functions@@ -53,7 +59,7 @@ Handle { sequ :: SndSeq.T SndSeq.DuplexMode, client :: Client.T,- portIn, portOut :: Port.T,+ portPublic, portPrivate :: Port.T, queue :: Queue.T } @@ -62,25 +68,26 @@ 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])+ ppublic <-+ Port.createSimple h "inout"+ (Port.caps [Port.capRead, Port.capSubsRead,+ Port.capWrite, Port.capSubsWrite]) Port.typeMidiGeneric- pin <-- Port.createSimple h "receiver"- (Port.caps [Port.capWrite, Port.capSubsWrite])+ pprivate <-+ Port.createSimple h "private"+ (Port.caps [Port.capRead, Port.capWrite]) Port.typeMidiGeneric q <- Queue.alloc h- let hnd = Handle h c pin pout q+ let hnd = Handle h c ppublic pprivate q Reader.runReaderT setTimeStamping hnd return hnd exit :: Handle -> IO () exit h = do- Event.outputPending (sequ h)+ _ <- Event.outputPending (sequ h) Queue.free (sequ h) (queue h)- Port.delete (sequ h) (portIn h)- Port.delete (sequ h) (portOut h)+ Port.delete (sequ h) (portPublic h)+ Port.delete (sequ h) (portPrivate h) SndSeq.close (sequ h) with :: ReaderT Handle IO a -> IO a@@ -88,30 +95,31 @@ 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+ Port.withSimple h "inout"+ (Port.caps [Port.capRead, Port.capSubsRead,+ Port.capWrite, Port.capSubsWrite])+ Port.typeMidiGeneric $ \ppublic -> do+ Port.withSimple h "private"+ (Port.caps [Port.capRead, Port.capWrite])+ Port.typeMidiGeneric $ \pprivate -> do Queue.with h $ \q ->- flip Reader.runReaderT (Handle h c pin pout q) $+ flip Reader.runReaderT (Handle h c ppublic pprivate q) $ setTimeStamping >> f -- | make ALSA set the time stamps in incoming events setTimeStamping :: ReaderT Handle IO () setTimeStamping = Reader.ReaderT $ \h -> do- info <- PortInfo.get (sequ h) (portIn h)+ info <- PortInfo.get (sequ h) (portPublic h) PortInfo.setTimestamping info True PortInfo.setTimestampReal info True PortInfo.setTimestampQueue info (queue h)- PortInfo.set (sequ h) (portIn h) info+ PortInfo.set (sequ h) (portPublic h) info startQueue :: ReaderT Handle IO () startQueue = Reader.ReaderT $ \h -> do Queue.control (sequ h) (queue h) Event.QueueStart 0 Nothing- Event.drainOutput (sequ h)+ _ <- Event.drainOutput (sequ h) return () @@ -119,8 +127,8 @@ 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+ SndSeq.connectFrom (sequ h) (portPublic h) from+ SndSeq.connectTo (sequ h) (portPublic h) to connectTimidity :: ReaderT Handle IO () connectTimidity =@@ -130,10 +138,49 @@ connectLLVM = connect "E-MU Xboard61" "Haskell-Synthesizer" +connectSuperCollider :: ReaderT Handle IO ()+connectSuperCollider =+ connect "E-MU Xboard61" "Haskell-Supercollider" --- * helper +-- * send single events++sendNote :: Channel -> Time -> Velocity -> Pitch -> ReaderT Handle IO ()+sendNote chan dur vel pit =+ let note = simpleNote chan pit vel+ t = incTime dur 0+ in do outputEvent 0 (Event.NoteEv Event.NoteOn note)+ outputEvent t (Event.NoteEv Event.NoteOff note)++sendKey :: Channel -> Bool -> Velocity -> Pitch -> ReaderT Handle IO ()+sendKey chan noteOn vel pit =+ outputEvent 0 $+ Event.NoteEv+ (if noteOn then Event.NoteOn else Event.NoteOff)+ (simpleNote chan pit vel)++sendController :: Channel -> Controller -> Int -> ReaderT Handle IO ()+sendController chan ctrl val =+ outputEvent 0 $+ Event.CtrlEv Event.Controller $+ MALSA.controllerEvent chan ctrl (fromIntegral val)++sendProgram :: Channel -> Program -> ReaderT Handle IO ()+sendProgram chan pgm =+ outputEvent 0 $+ Event.CtrlEv Event.PgmChange $+ MALSA.programChangeEvent chan pgm++sendMode :: Channel -> Mode.T -> ReaderT Handle IO ()+sendMode chan mode =+ outputEvent 0 $+ Event.CtrlEv Event.Controller $+ MALSA.modeEvent chan mode+++-- * constructors+ channel :: Int -> Channel channel = ChannelMsg.toChannel @@ -150,7 +197,12 @@ program = VoiceMsg.toProgram +normalVelocity :: VoiceMsg.Velocity+normalVelocity =+ VoiceMsg.toVelocity VoiceMsg.normalVelocity ++ -- * time {- |@@ -193,7 +245,7 @@ , Event.queue = queue h , Event.timestamp = Event.RealTime (RealTime.fromInteger (round (t*nano)))- , Event.source = Addr.Cons (client h) (portOut h)+ , Event.source = Addr.Cons (client h) (portPublic h) , Event.dest = Addr.subscribers , Event.body = e }@@ -206,12 +258,27 @@ , 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.source = Addr.Cons (client h) (portPrivate h)+ , Event.dest = Addr.Cons (client h) (portPrivate h) , Event.body = Event.CustomEv Event.Echo c } +outputEvent :: TimeAbs -> Event.Data -> ReaderT Handle IO ()+outputEvent t ev = Reader.ReaderT $ \h ->+ Event.output (sequ h) (makeEvent h t ev) >>+ Event.drainOutput (sequ h) >>+ return ()+++simpleNote :: Channel -> Pitch -> Velocity -> Event.Note+simpleNote c p v =+ Event.simpleNote+ (MALSA.fromChannel c)+ (MALSA.fromPitch p)+ (MALSA.fromVelocity v)++ {- | The times are relative to the start time of the bundle and do not need to be ordered.@@ -222,7 +289,10 @@ singletonBundle :: a -> Bundle a singletonBundle ev = [(0,ev)] +immediateBundle :: [a] -> Bundle a+immediateBundle = map ((,) 0) + timeFromStamp :: Event.TimeStamp -> Time timeFromStamp t = case t of@@ -237,7 +307,7 @@ defaultTempoCtrl :: (Channel,Controller) defaultTempoCtrl =- (ChannelMsg.toChannel 0, VoiceMsg.toController 70)+ (ChannelMsg.toChannel 0, VoiceMsg.toController 16) @@ -261,6 +331,24 @@ note ^. MALSA.notePitch _ -> Just e +{- |+Swap order of keys.+Non-note events are returned without modification.+If by reversing a note leaves the range of representable MIDI notes,+then we return Nothing.+-}+reverse ::+ Event.Data -> Maybe Event.Data+reverse e =+ case e of+ Event.NoteEv notePart note ->+ fmap (\p ->+ Event.NoteEv notePart $+ (MALSA.notePitch ^= p) note) $+ maybePitch $ (60+64 -) $ VoiceMsg.fromPitch $+ note ^. MALSA.notePitch+ _ -> Just e+ setChannel :: Channel -> Event.Data -> Event.Data setChannel chan e =@@ -268,8 +356,8 @@ Event.NoteEv notePart note -> Event.NoteEv notePart $ (MALSA.noteChannel ^= chan) note- Event.CtrlEv Event.Controller ctrl ->- Event.CtrlEv Event.Controller $+ Event.CtrlEv ctrlPart ctrl ->+ Event.CtrlEv ctrlPart $ (MALSA.ctrlChannel ^= chan) ctrl _ -> e @@ -334,17 +422,16 @@ _ -> return e -nextProgram :: Event.Note -> State.State [Program] EventDataBundle+nextProgram :: Event.Note -> State.State [Program] [Event.Data] nextProgram note = State.state $ \pgms -> case pgms of pgm:rest ->- (singletonBundle $- Event.CtrlEv Event.PgmChange $+ ([Event.CtrlEv Event.PgmChange $ Event.Ctrl { Event.ctrlChannel = Event.noteChannel note, Event.ctrlParam = 0,- Event.ctrlValue = MALSA.fromProgram pgm},+ Event.ctrlValue = MALSA.fromProgram pgm}], rest) [] -> ([],[]) @@ -356,9 +443,9 @@ and send the program switch to the same channel as the beginning note. -} traversePrograms ::- Event.Data -> State.State [Program] EventDataBundle+ Event.Data -> State.State [Program] [Event.Data] traversePrograms e =- fmap (++ singletonBundle e) $+ fmap (++ [e]) $ case e of Event.NoteEv notePart note -> (case fst $ normalNoteFromEvent notePart note of@@ -376,9 +463,9 @@ -} traverseProgramsSeek :: Int ->- Event.Data -> State.State [Program] EventDataBundle+ Event.Data -> State.State [Program] [Event.Data] traverseProgramsSeek maxSeek e =- fmap (++ singletonBundle e) $+ fmap (++ [e]) $ case e of Event.NoteEv notePart note -> case fst $ normalNoteFromEvent notePart note of@@ -414,13 +501,32 @@ -simpleNote :: Channel -> Pitch -> Velocity -> Event.Note-simpleNote c p v =- Event.simpleNote- (MALSA.fromChannel c)- (MALSA.fromPitch p)- (MALSA.fromVelocity v)+{- |+Map NoteOn events to a controller value.+This way you may play notes via the resonance frequency of a filter.+-}+controllerFromNote ::+ (Int -> Int) ->+ VoiceMsg.Controller ->+ Event.Data -> Maybe Event.Data+controllerFromNote f ctrl e =+ case e of+ Event.NoteEv notePart note ->+ case fst $ normalNoteFromEvent notePart note of+ Event.NoteOn ->+ Just $+ Event.CtrlEv Event.Controller $+ MALSA.controllerEvent+ (note ^. MALSA.noteChannel)+ ctrl+ (fromIntegral $ f $+ fromIntegral $ VoiceMsg.fromPitch $+ note ^. MALSA.notePitch)+ Event.NoteOff -> Nothing+ _ -> Just e+ _ -> Just e + type KeySet = Map.Map (Pitch, Channel) Velocity type KeyQueue = [((Pitch, Channel), Velocity)] @@ -484,13 +590,16 @@ chord !! floor (d * fromIntegral (length chord)) +maybePitch :: Int -> Maybe Pitch+maybePitch p =+ toMaybe+ (VoiceMsg.fromPitch minBound <= p &&+ p <= VoiceMsg.fromPitch maxBound)+ (VoiceMsg.toPitch p)+ increasePitch :: Int -> Pitch -> Maybe Pitch increasePitch d p =- let pInt = d + VoiceMsg.fromPitch p- in toMaybe- (VoiceMsg.fromPitch minBound <= pInt &&- pInt <= VoiceMsg.fromPitch maxBound)- (VoiceMsg.toPitch pInt)+ maybePitch $ d + VoiceMsg.fromPitch p selectInversion ::@@ -537,14 +646,48 @@ updateDur :: Event.Ctrl -> (Time, Time) -> Time-updateDur param (minDur, maxDur) =+updateDur = updateDurExponential++updateDurLinear ::+ Event.Ctrl -> (Time, Time) -> Time+updateDurLinear param (minDur, maxDur) = minDur + (maxDur-minDur) * fromIntegral (Event.ctrlValue param) / 127 +updateDurExponential ::+ Event.Ctrl -> (Time, Time) -> Time+updateDurExponential param (minDur, maxDur) =+ minDur *+ Time+ (powerRationalFromFloat 10 3+ (fromRational $ deconsTime maxDur/deconsTime minDur :: Double)+ (fromIntegral (Event.ctrlValue param) / 127)) +{- |+Compute @base ** expo@+approximately to result type 'Rational'+such that the result has a denominator which is a power of @digitBase@+and a relative precision of numerator of @precision@ digits+with respect to @digitBase@-ary numbers.+-}+powerRationalFromFloat ::+ (Floating a, RealFrac a) =>+ Int -> Int -> a -> a -> Rational+powerRationalFromFloat digitBase precision base expo =+ let digitBaseFloat = fromIntegral digitBase+ {-+ It would be nice, if properFraction would warrant @0<=x<1@.+ Actually it can be @-1<x<=0@ in which case we lose one digit of precision.+ -}+ (n,x) = properFraction (logBase digitBaseFloat base * expo)+ frac = round (digitBaseFloat ** (x + fromIntegral precision))+ in fromInteger frac *+ fromIntegral digitBase ^^ (n-precision)++ type Selector i = i -> Time -> KeyQueue -> EventDataBundle -type Pattern i = (Selector i, [i])+data PatternMono i = PatternMono (Selector i) [i] data IndexNote i = IndexNote Int i@@ -553,7 +696,7 @@ item :: i -> Int -> IndexNote i item i n = IndexNote n i -type PatternMulti i = (Selector i, EventList.T Int [IndexNote i])+data PatternPoly i = PatternPoly (Selector i) (EventList.T Int [IndexNote i]) @@ -582,7 +725,9 @@ -- * patterns -{-+{- |+See Haskore/FlipSong+ flipSeq m !! n = cross sum of the m-ary representation of n modulo m. For m=2 this yields@@ -591,54 +736,198 @@ 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)+ recourse y =+ let z = concatMap (flip incList y) [1 .. n-1]+ in z ++ recourse (y++z) in [0] ++ recourse [0] +{- |+@bruijn n k@ is a sequence with length n^k+where @cycle (bruijn n k)@ contains all n-ary numbers with k digits as infixes.+The function computes the lexicographically smallest of such sequences.+-}+bruijn :: Int -> Int -> [Int]+bruijn n k =+ head $ bruijnAllMap n k++{- |+All Bruijn sequences with a certain +-}+bruijnAll :: Int -> Int -> [[Int]]+bruijnAll n k =+ let start = replicate k 0+ go _ str 0 = do+ guard $ str==start+ return []+ go set str c = do+ d <- [0 .. n-1]+ let newStr = tail str ++ [d]+ guard $ Set.notMember newStr set+ rest <- go (Set.insert newStr set) newStr (c-1)+ return $ d:rest+ in map (ListHT.rotate (-k)) $+ go Set.empty start (n^k)++bruijnAllMap :: Int -> Int -> [[Int]]+bruijnAllMap n k =+ let start = replicate k 0+ delete d =+ Map.update (\set ->+ let newSet = Set.delete d set+ in toMaybe (not $ Set.null newSet) newSet)+ go [] _ = error "infixes must have positive length"+ go (_:str) todo =+ case Map.lookup str todo of+ Nothing -> do+ guard $ Map.null todo+ return []+ Just set -> do+ d <- Set.toList set+ rest <- go (str ++ [d]) $ delete d str todo+ return $ d:rest+ in map (take (n^k) . (start ++)) $+ go start $+ delete 0 (tail start) $+ Map.fromAscList $+ map (flip (,) $ Set.fromList [0 .. n-1]) $+ replicateM (k-1) [0 .. n-1]++testBruijn :: Int -> Int -> [Int] -> Bool+testBruijn n k xs =+ replicateM k [0 .. n-1]+ ==+ (List.sort $ Match.take xs $ map (take k) $ List.tails $ cycle xs)++testBruijnAll :: Int -> Int -> Bool+testBruijnAll n k =+ all (testBruijn n k) $ bruijnAllMap n k+++bruijnAllTrie :: Int -> Int -> [[Int]]+bruijnAllTrie n k =+ let start = replicate k 0+ go [] _ = error "infixes must have positive length"+ go (_:str) todo =+ case lookupWord str todo of+ Nothing -> do+ guard $ nullTrie todo+ return []+ Just set -> do+ d <- set+ rest <- go (str ++ [d]) $ deleteWord d str todo+ return $ d:rest+ in map (take (n^k) . (start ++)) $+ go start $+ deleteWord 0 (tail start) $+ fullTrie [0 .. n-1] [0 .. n-1] (k-1)++data Trie a b = Leaf b | Branch [(a, Trie a b)]+ deriving (Show)++fullTrie :: b -> [a] -> Int -> Trie a b+fullTrie b _ 0 = Leaf b+fullTrie b as n =+ Branch $+ map (\a -> (a, fullTrie b as (n-1))) as++nullTrie :: Trie a [b] -> Bool+nullTrie (Branch []) = True+nullTrie (Leaf []) = True+nullTrie _ = False++deleteWord :: (Eq a, Eq b) => b -> [a] -> Trie a [b] -> Trie a [b]+deleteWord b [] (Leaf bs) = Leaf (List.delete b bs)+deleteWord b (a:as) (Branch subTries) =+ Branch $ mapMaybe+ (\(key,trie) ->+ fmap ((,) key) $+ if key==a+ then let delTrie = deleteWord b as trie+ in toMaybe (not (nullTrie delTrie)) delTrie+ else Just trie)+ subTries+deleteWord _ _ _ = error "Trie.deleteWord: key and trie depth mismatch"++lookupWord :: (Eq a) => [a] -> Trie a b -> Maybe b+lookupWord [] (Leaf b) = Just b+lookupWord (a:as) (Branch subTries) =+ lookup a subTries >>= lookupWord as+lookupWord _ _ = error "Trie.lookupWord: key and trie depth mismatch"++++bruijnAllBits :: Int -> Int -> [[Int]]+bruijnAllBits n k =+ let go code todo =+ let shiftedCode = mod (code*n) (n^k)+ in case Bits.shiftR todo shiftedCode .&. (2^n-1) of+ 0 -> do+ guard $ todo == 0+ return []+ set -> do+ d <- [0 .. n-1]+ guard $ Bits.testBit set d+ rest <-+ let newCode = shiftedCode + d+ in go newCode $ Bits.clearBit todo newCode+ return $ d:rest+ in map (take (n^k) . (replicate k 0 ++)) $+ go 0 $ (2^n^k-2 :: Integer)+++ cycleUp, cycleDown, pingPong, crossSum ::- Int -> Pattern Int+ Int -> PatternMono Int cycleUp number =- (selectFromLimittedChord, cycle [0..(number-1)])+ PatternMono selectFromLimittedChord (cycle [0..(number-1)]) cycleDown number =- (selectFromLimittedChord, cycle $ reverse [0..(number-1)])+ PatternMono selectFromLimittedChord (cycle $ List.reverse [0..(number-1)]) pingPong number =- (selectFromLimittedChord,- cycle $ [0..(number-2)] ++ reverse [1..(number-1)])+ PatternMono selectFromLimittedChord $+ cycle $ [0..(number-2)] ++ List.reverse [1..(number-1)] crossSum number =- (selectFromLimittedChord, flipSeq number)+ PatternMono selectFromLimittedChord (flipSeq number) +bruijnPat :: Int -> Int -> PatternMono Int+bruijnPat n k =+ PatternMono selectFromLimittedChord $ cycle $ bruijn n k+ cycleUpAuto, cycleDownAuto, pingPongAuto, crossSumAuto ::- Pattern Integer+ PatternMono Integer cycleUpAuto =- (\ d dur chord ->- selectFromChord (mod d (fromIntegral $ length chord)) dur chord,- [0..])+ PatternMono+ (\ 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)..])+ PatternMono+ (\ 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..])+ PatternMono+ (\ 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..])+ PatternMono+ (\ 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+binaryStaccato, binaryLegato, binaryAccident :: PatternPoly Int {--binary number pattern:+binary number patternMono: 0 1 0 1@@ -649,43 +938,46 @@ 3 -} binaryStaccato =- (selectFromLimittedChord,- EventList.fromPairList $- zip (0 : repeat 1) $- map- (map (IndexNote 1 . fst) .- List.filter ((/=0) . snd) .- zip [0..] .- decomposePositional 2)- [0..])+ PatternPoly+ 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..])+ PatternPoly+ 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..])+ PatternPoly+ 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@@ -698,29 +990,29 @@ in recourse cycleUpOctave ::- Int -> Pattern Int+ Int -> PatternMono Int cycleUpOctave number =- (selectFromOctaveChord, cycle [0..(number-1)])+ PatternMono selectFromOctaveChord (cycle [0..(number-1)]) -random, randomInversions :: Pattern Double+random, randomInversions :: PatternMono Double random =- (selectFromChordRatio, Rnd.randomRs (0,1) (Rnd.mkStdGen 42))+ PatternMono selectFromChordRatio (Rnd.randomRs (0,1) (Rnd.mkStdGen 42)) randomInversions = inversions $ map sum $ ListHT.sliceVertical 3 $- Rnd.randomRs (-0.5,0.5) $+ Rnd.randomRs (-1,1) $ Rnd.mkStdGen 42 -cycleUpInversions :: Int -> Pattern Double+cycleUpInversions :: Int -> PatternMono Double cycleUpInversions n = inversions $ cycle $ take n $ map (\i -> fromInteger i / fromIntegral n) [0..] -inversions :: [Double] -> Pattern Double+inversions :: [Double] -> PatternMono Double inversions rs =- (selectInversion, rs)+ PatternMono selectInversion rs {-@@ -728,18 +1020,18 @@ which is incompatible to a Body-Body list, even if the end is never reached. -}-examplePatternMultiTempo0 ::+examplePatternPolyTempo0 :: EventList.T Int [IndexNote Int]-examplePatternMultiTempo0 =+examplePatternPolyTempo0 = 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 ::+examplePatternPolyTempo1 :: EventList.T Int [IndexNote Int]-examplePatternMultiTempo1 =+examplePatternPolyTempo1 = let pat = [item 0 1] ./ 1 /. [item 2 1, item 3 1, item 4 1] ./ 1 /.@@ -778,10 +1070,23 @@ (Event.Data -> Bool) checkController p e = case e of- Event.CtrlEv Event.Controller ctrl ->- p (ctrl ^. MALSA.ctrlController)+ Event.CtrlEv Event.Controller ctrlMode ->+ case ctrlMode ^. MALSA.ctrlControllerMode of+ MALSA.Controller ctrl _ -> p ctrl+ _ -> False _ -> False +checkMode ::+ (Mode.T -> Bool) ->+ (Event.Data -> Bool)+checkMode p e =+ case e of+ Event.CtrlEv Event.Controller ctrlMode ->+ case ctrlMode ^. MALSA.ctrlControllerMode of+ MALSA.Mode mode -> p mode+ _ -> False+ _ -> False+ checkProgram :: (Program -> Bool) -> (Event.Data -> Bool)@@ -790,3 +1095,22 @@ Event.CtrlEv Event.PgmChange ctrl -> p (ctrl ^. MALSA.ctrlProgram) _ -> False+++-- * event list support++mergeStable ::+ (NonNeg.C time) =>+ EventList.T time body ->+ EventList.T time body ->+ EventList.T time body+mergeStable =+ EventList.mergeBy (\_ _ -> True)++mergeEither ::+ (NonNeg.C time) =>+ EventList.T time a ->+ EventList.T time b ->+ EventList.T time (Either a b)+mergeEither xs ys =+ mergeStable (fmap Left xs) (fmap Right ys)
src/Sound/MIDI/ALSA/EventList.hs view
@@ -1,15 +1,14 @@ module Sound.MIDI.ALSA.EventList where {- ToDo:-controller mapping- fix laziness issues in splitting and merging-change pattern according to program change events+Maybe this cannot be fixed at all.+In the Causal module this problem is solved. -} import Sound.MIDI.ALSA.Common (Bundle, EventDataBundle, Time, TimeAbs,- Handle, Pattern, PatternMulti, Selector,+ Handle, PatternMono, PatternPoly, sequ, with, incTime, singletonBundle, checkController, checkChannel, checkProgram, checkPitch,@@ -25,13 +24,11 @@ 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 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.Basic as Acc import Data.Accessor.Basic ((^.), ) import qualified Data.List.HT as ListHT@@ -87,15 +84,9 @@ 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) .+ mapM_ (uncurry Common.outputEvent) . pairListFromRelativeEvents @@ -108,7 +99,7 @@ mapM_ (\(t,evs) -> flip mapM_ evs (\(dt,ev) ->- outputEvent (incTime dt t) ev)) .+ Common.outputEvent (incTime dt t) ev)) . pairListFromRelativeEvents outputEventBundled :: EventList.T Time EventDataBundle -> ReaderT Handle IO ()@@ -232,18 +223,17 @@ EventList.T Time a -> EventList.T Time a mergeGeneratedAtoms trigger gens ins =- EventList.mergeBy (\_ _ -> True)+ Common.mergeStable (fmap trigger $ EventList.fromPairList $ ListHT.mapAdjacent (,) (0 : EventList.getTimes gens))- (EventList.mergeBy (\_ _ -> True) gens ins)+ (Common.mergeStable gens ins) -pattern ::- Selector i ->- [i] ->+patternMono ::+ PatternMono i -> Time -> EventList.T Time Event.Data -> EventList.T Time EventDataTrigger-pattern select ixs dur ins =+patternMono (Common.PatternMono select ixs) dur ins = flip State.evalState Map.empty $ Trav.sequenceA $ mergeGeneratedAtoms (\dt -> return [(dt, Trigger)])@@ -260,13 +250,14 @@ ins) -patternTempo ::- Selector i ->- [i] ->+patternMonoTempo ::+ PatternMono i -> ((Channel,Controller), (Time,Time,Time)) -> EventList.T Time Event.Data -> EventList.T Time EventDataTrigger-patternTempo select ixs0 ((chan,ctrl), (minDur, defltDur, maxDur)) =+patternMonoTempo+ (Common.PatternMono select ixs0)+ ((chan,ctrl), (minDur, defltDur, maxDur)) = let recourse dur chord ixs = EventList.switchL EventList.empty $ \(time,me) rest -> uncurry (EventList.cons time) $@@ -301,13 +292,14 @@ This allows more complex patterns including pauses, notes of different lengths and simultaneous notes. -}-patternMultiTempo ::- Selector i ->- EventList.T Int [Common.IndexNote i] ->+patternPolyTempo ::+ PatternPoly i -> ((Channel,Controller), (Time,Time,Time)) -> EventList.T Time Event.Data -> EventList.T Time EventDataTrigger-patternMultiTempo select ixs0 ((chan,ctrl), (minDur, defltDur, maxDur)) =+patternPolyTempo+ (Common.PatternPoly select ixs0)+ ((chan,ctrl), (minDur, defltDur, maxDur)) = let recourse dur chord ixs = EventList.switchL EventList.empty $ \(time,me) rest -> uncurry (EventList.cons time) $@@ -348,6 +340,20 @@ fmap Just +class Pattern pat where+ patternTempo ::+ pat ->+ ((Channel,Controller), (Time,Time,Time)) ->+ EventList.T Time Event.Data ->+ EventList.T Time EventDataTrigger++instance Pattern (PatternMono i) where+ patternTempo = patternMonoTempo++instance Pattern (PatternPoly i) where+ patternTempo = patternPolyTempo++ {- | Automatically changes the value of a MIDI controller every @period@ seconds according to a periodic wave.@@ -361,7 +367,7 @@ 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,+The small difference is, that we emit a controller value at a regular patternMono, whereas direct control would mean that only controller value changes are transfered. @@ -474,7 +480,7 @@ fmap concat $ EventList.collectCoincident $ -}- EventList.mergeBy (\_ _ -> True) x y+ Common.mergeStable x y -} merge ::@@ -542,8 +548,8 @@ filter (\e -> (checkChannel (ChannelMsg.toChannel 0 ==) e && checkPitch (VoiceMsg.toPitch 60 >) e) ||- checkController (VoiceMsg.toController 91 ==) e ||- checkController (VoiceMsg.toController 93 ==) 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) .@@ -577,55 +583,15 @@ 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) .+ (fmap Common.immediateBundle .+ flip State.evalState (cycle pgms) . Trav.traverse (Common.traverseProgramsSeek (length pgms))) {- |@@ -643,37 +609,27 @@ -} runPattern :: Time ->- Pattern i ->+ PatternMono i -> ReaderT Handle IO () runPattern dur pat =- process (uncurry pattern pat dur)+ process (patternMono pat dur) {- | > runPatternTempo 0.12 (cycleUp 4) -> runPatternTempo 0.2 (selectFromOctaveChord, cycle [0,1,2,0,1,2,0,1])+> runPatternTempo 0.2 (PatternMono selectFromOctaveChord (cycle [0,1,2,0,1,2,0,1]))++> runPatternTempo 0.1 (PatternPoly selectFromLimittedChord (let pat = [item 0 1] ./ 1 /. [item 1 1] ./ 2 /. [item 1 1] ./ 1 /. [item 0 1] ./ 2 /. pat in 0 /. pat)) -} runPatternTempo ::+ Pattern pat => Time ->- Pattern i ->+ pat -> 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)))+ (patternTempo pat+ (Common.defaultTempoCtrl, (1.5*dur, dur, 0.5*dur))) runFilterSweep ::@@ -691,7 +647,7 @@ main :: IO () main = (with $ do liftIO $ putStrLn "Please connect me to a synth"- liftIO $ getLine+ _ <- liftIO $ getLine Common.startQueue liftIO . mapM_ print =<< inputEventsCore outputEvents =<< inputEvents@@ -700,51 +656,3 @@ `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--}
+ src/Sound/MIDI/ALSA/Guitar.hs view
@@ -0,0 +1,37 @@+-- cf. Haskore/Guitar+module Sound.MIDI.ALSA.Guitar where++import qualified Sound.MIDI.ALSA.Common as Common+import Sound.MIDI.Message.Channel.Voice (Pitch, toPitch, fromPitch, )+import Data.Maybe (mapMaybe, )+++class Transpose pitch where+ getPitch :: pitch -> Int+ transpose :: Int -> pitch -> Maybe pitch++instance Transpose Pitch where+ getPitch = fromPitch+ transpose = Common.increasePitch+++mapChordToString ::+ (Transpose pitch, Ord pitch) =>+ [Pitch] -> [pitch] -> [pitch]+mapChordToString strings chord =+ mapMaybe (choosePitchForString chord) strings++choosePitchForString ::+ (Transpose pitch, Ord pitch) =>+ [pitch] -> Pitch -> Maybe pitch+choosePitchForString chord string =+ let roundDown x d = x - mod x d+ minAbove x =+ transpose+ (- roundDown (getPitch x - fromPitch string) 12) x+ in maximum (map minAbove chord)++stringPitches :: [Pitch]+stringPitches =+ reverse $ map toPitch [40, 45, 50, 55, 59, 64]+-- reverse [(-2,E), (-2,A), (-1,D), (-1,G), (-1,B), (0,E)]
+ src/Sound/MIDI/ALSA/Training.hs view
@@ -0,0 +1,110 @@+module Sound.MIDI.ALSA.Training (+ all,+ intervals,+ twoNotes,+ threeNotes,+ reverseThreeNotes,+ sortThreeNotes,+ transposeTwoNotes,+ ) where++import System.Random (RandomGen, Random, randomR, )+import Control.Monad.Trans.State (State, state, evalState, )+import Sound.MIDI.ALSA.Common (pitch, increasePitch, )+import Sound.MIDI.Message.Channel.Voice (Pitch, fromPitch, )+import Control.Monad (liftM2, )+import Data.Maybe (mapMaybe, )+import qualified Data.List as List+import Prelude hiding (all, )+++{- | chose a random item from a list -}+-- from htam+randomItem :: (RandomGen g) => [a] -> State g a+randomItem x = fmap (x!!) (randomRState (length x - 1))++randomRState :: (RandomGen g, Random a, Num a) => a -> State g a+randomRState upper = state (randomR (0, upper))+++baseKey :: Pitch+baseKey = pitch 60++notes :: [Pitch]+notes =+ mapMaybe (flip increasePitch baseKey)+ [0, 12, 7, 5, 4, 2, 9, 11, 3, 10, 1, 6, 8]+++all :: RandomGen g => g -> [([Pitch], [Pitch])]+all g =+ intervals g ++ twoNotes g ++ threeNotes g +++ reverseThreeNotes g ++ sortThreeNotes g +++ transposeTwoNotes g++-- | intervals within an octave, all starting with a C+intervals :: RandomGen g => g -> [([Pitch], [Pitch])]+intervals g =+ flip evalState g $+ mapM randomItem $+ concat $ zipWith replicate [3,6..] $+ drop 3 $ List.inits $+ map (\p -> let ps = [baseKey, p] in (ps, ps)) $+ notes++-- | choose two arbitrary notes from an increasing set of notes+twoNotes :: RandomGen g => g -> [([Pitch], [Pitch])]+twoNotes g =+ flip evalState g $+ mapM (\ps ->+ fmap (\pso -> (pso,pso)) $+ mapM randomItem [ps,ps]) $+ concat $ zipWith replicate [3,6..] $+ drop 3 $ List.inits $+ notes++-- | choose three arbitrary notes from an increasing set of notes+threeNotes :: RandomGen g => g -> [([Pitch], [Pitch])]+threeNotes g =+ flip evalState g $+ mapM (\ps ->+ fmap (\pso -> (pso,pso)) $+ mapM randomItem [ps,ps,ps]) $+ concat $ zipWith replicate [3,6..] $+ drop 3 $ List.inits $+ notes++reverseThreeNotes :: RandomGen g => g -> [([Pitch], [Pitch])]+reverseThreeNotes g =+ flip evalState g $+ mapM (\ps ->+ fmap (\pso -> (pso, reverse pso)) $+ mapM randomItem [ps,ps,ps]) $+ concat $ zipWith replicate [3,6..] $+ drop 3 $ List.inits $+ notes++sortThreeNotes :: RandomGen g => g -> [([Pitch], [Pitch])]+sortThreeNotes g =+ flip evalState g $+ mapM (\ps ->+ fmap (\pso -> (pso, List.sort pso)) $+ mapM randomItem [ps,ps,ps]) $+ concat $ zipWith replicate [3,6..] $+ drop 3 $ List.inits $+ notes++-- | transpose an interval to begin with C+transposeTwoNotes :: RandomGen g => g -> [([Pitch], [Pitch])]+transposeTwoNotes g =+ flip evalState g $+ mapM (\ps ->+ liftM2+ (\p0 p1 ->+ let pso = [p0,p1]+ d = fromPitch baseKey - fromPitch p0+ in (pso, mapMaybe (increasePitch d) pso))+ (randomItem ps) (randomItem ps)) $+ concat $ zipWith replicate [3,6..] $+ drop 3 $ List.inits $+ notes
streamed.cabal view
@@ -1,5 +1,5 @@ Name: streamed-Version: 0.1+Version: 0.2 License: BSD3 License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -9,6 +9,9 @@ Build-Type: Simple Synopsis: Programmatically edit MIDI event streams via ALSA Description:+ Please note:+ This package shall be replaced by @reactive-balsa@ in the future.+ . 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.@@ -18,23 +21,24 @@ 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@+ @synthesizer-alsa@, @synthesizer-llvm@, @supercollider-midi@,+ @hsc3@, @YampaSynth@ or the C packages @fluidsynth@ and @Timidity@.-+ . Applications include: Remapping of channels, controller, instruments, keys, Keyboard splitting, Conversion from notes to controllers, Latch mode, Convert parallel chords to serial patterns, Automated change of MIDI controllers, 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+ However we provide an example module that demonstrates various effects.+Tested-With: GHC==6.10.4, GHC==6.12.3 Cabal-Version: >=1.6 Build-Type: Simple Source-Repository head@@ -44,7 +48,7 @@ Source-Repository this type: darcs location: http://code.haskell.org/~thielema/streamed/- tag: 0.1+ tag: 0.2 Flag splitBase description: Choose the new smaller, split-up base package.@@ -55,7 +59,7 @@ Library Build-Depends:- midi-alsa >=0.1 && <0.2,+ midi-alsa >=0.1.1 && <0.2, midi >=0.1.5 && <0.2, alsa-seq >=0.5 && <0.6, alsa-core >=0.5 && <0.6,@@ -64,13 +68,12 @@ 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,+ containers >=0.2 && <0.5, transformers >=0.2 && <0.3 If flag(splitBase) Build-Depends: random >=1 && <2,- base >= 2 && <6+ base >= 2 && <5 Else Build-Depends: base >= 1.0 && < 2@@ -79,5 +82,9 @@ Hs-Source-Dirs: src Exposed-Modules: Sound.MIDI.ALSA.Causal+ Sound.MIDI.ALSA.CausalExample Sound.MIDI.ALSA.EventList+ Sound.MIDI.ALSA.Guitar+ Sound.MIDI.ALSA.Training+-- Other-Modules: Sound.MIDI.ALSA.Common