diff --git a/src/Sound/MIDI/ALSA/Causal.hs b/src/Sound/MIDI/ALSA/Causal.hs --- a/src/Sound/MIDI/ALSA/Causal.hs +++ b/src/Sound/MIDI/ALSA/Causal.hs @@ -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) diff --git a/src/Sound/MIDI/ALSA/CausalExample.hs b/src/Sound/MIDI/ALSA/CausalExample.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/ALSA/CausalExample.hs @@ -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] diff --git a/src/Sound/MIDI/ALSA/Common.hs b/src/Sound/MIDI/ALSA/Common.hs --- a/src/Sound/MIDI/ALSA/Common.hs +++ b/src/Sound/MIDI/ALSA/Common.hs @@ -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 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) diff --git a/src/Sound/MIDI/ALSA/EventList.hs b/src/Sound/MIDI/ALSA/EventList.hs --- a/src/Sound/MIDI/ALSA/EventList.hs +++ b/src/Sound/MIDI/ALSA/EventList.hs @@ -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 --} diff --git a/src/Sound/MIDI/ALSA/Guitar.hs b/src/Sound/MIDI/ALSA/Guitar.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/ALSA/Guitar.hs @@ -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)] diff --git a/src/Sound/MIDI/ALSA/Training.hs b/src/Sound/MIDI/ALSA/Training.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/ALSA/Training.hs @@ -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 diff --git a/streamed.cabal b/streamed.cabal --- a/streamed.cabal +++ b/streamed.cabal @@ -1,5 +1,5 @@ Name: streamed -Version: 0.1 +Version: 0.2 License: BSD3 License-File: LICENSE Author: Henning Thielemann @@ -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