streamed-0.1: src/Sound/MIDI/ALSA/Causal.hs
{-# 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)))