reactive-balsa-0.0: src/Reactive/Banana/ALSA/Sequencer.hs
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Reactive.Banana.ALSA.Sequencer where
import qualified Reactive.Banana.ALSA.Common as Common
import qualified Reactive.Banana.ALSA.Guitar as Guitar
import qualified Reactive.Banana.ALSA.Pattern as Pattern
import qualified Reactive.Banana.ALSA.KeySet as KeySet
import qualified Reactive.Banana as RB
import qualified Reactive.Banana.Model as RBM
import qualified Reactive.Banana.Implementation as RBI
import Reactive.Banana.Model ((<@>), )
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Sound.ALSA.Sequencer.Address as Addr
import qualified Sound.MIDI.ALSA.Check as Check
import qualified Sound.MIDI.ALSA as MALSA
import Sound.MIDI.ALSA (normalNoteFromEvent, )
import Sound.MIDI.Message.Channel (Channel, )
import Sound.MIDI.Message.Channel.Voice
(Pitch, Controller, Velocity, Program, normalVelocity, )
import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Data.EventList.Absolute.TimeBody as EventListAbs
import qualified Data.Accessor.Monad.Trans.State as AccState
import qualified Data.Accessor.Tuple as AccTuple
import Data.Accessor.Basic ((^.), )
import qualified Control.Monad.Trans.Class as MT
import qualified Control.Monad.Trans.State as MS
import qualified Control.Monad.Trans.Reader as MR
import Control.Monad.Trans.Reader (ReaderT(ReaderT), )
import Control.Monad.IO.Class (MonadIO, liftIO, )
import Control.Monad.Fix (MonadFix, )
import Control.Monad (forever, when, )
import Control.Monad.HT ((<=<), )
import Control.Applicative (Applicative, pure, (<*>), )
import Data.Tuple.HT (mapPair, )
import Data.Ord.HT (comparing, limit, )
import Data.Maybe.HT (toMaybe, )
import Data.Word (Word32, )
import qualified Data.Map as Map
import qualified Data.List as List
import qualified Data.List.Match as Match
import Prelude hiding (sequence, )
-- * make ALSA reactive
newtype Reactor a =
Reactor {
runReactor ::
MR.ReaderT
(RBI.AddHandler Event.T, Common.Handle)
(MS.StateT Schedule RBI.NetworkDescription)
a
} deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
newtype Schedule = Schedule Word32
deriving (Eq, Ord, Enum, Show)
getHandle :: Reactor Common.Handle
getHandle = Reactor $ MR.asks snd
run ::
(Common.Events ev) =>
(RB.Event Event.Data -> RB.Event ev) ->
ReaderT Common.Handle IO ()
run f =
runM (\ _ts xs -> return $ f xs)
runM ::
(Common.Events ev) =>
(RB.Behavior Common.TimeAbs ->
RB.Event Event.Data -> Reactor (RB.Event ev)) ->
ReaderT Common.Handle IO ()
runM f = do
Common.startQueue
MR.ReaderT $ \h -> do
(addEventHandler, runEventHandler) <- RBI.newAddHandler
(addEchoHandler, runEchoHandler) <- RBI.newAddHandler
(addTimeHandler, runTimeHandler) <- RBI.newAddHandler
RBI.actuate <=< RBI.compile $ do
time <-
fmap (RB.stepper 0) $
RBI.fromAddHandler addTimeHandler
evs <-
flip MS.evalStateT (Schedule 0)
. flip MR.runReaderT (addEchoHandler, h)
. runReactor
. f time
. fmap Event.body
=<< RBI.fromAddHandler addEventHandler
RBI.reactimate $
pure (outputEvents h) <*> time <@> evs
forever $ do
ev <- Event.input (Common.sequ h)
runTimeHandler $ Common.timeFromStamp $ Event.timestamp ev
if Event.dest ev == Addr.Cons (Common.client h) (Common.portPrivate h)
then debug "input: echo" >> runEchoHandler ev
else debug "input: event" >> runEventHandler ev
outputEvents ::
Common.Events evs =>
Common.Handle -> Common.TimeAbs -> evs -> IO ()
outputEvents h time evs = do
mapM_ (Event.output (Common.sequ h)) $
map (\(Common.Future dt body) ->
Common.makeEvent h (Common.incTime dt time) body) $
Common.flattenEvents evs
_ <- Event.drainOutput (Common.sequ h)
return ()
checkSchedule :: Schedule -> Event.T -> Bool
checkSchedule (Schedule sched) echo =
maybe False (sched ==) $ do
Event.CustomEv Event.Echo s <- Just $ Event.body echo
let Event.Custom echoSchedule 0 0 = s
return echoSchedule
scheduleData :: Schedule -> Event.Custom
scheduleData (Schedule sched) =
Event.Custom sched 0 0
reactimate :: RB.Event (IO ()) -> Reactor ()
reactimate evs =
Reactor $ MT.lift $ MT.lift $ RB.reactimate evs
sendEchos :: Common.Handle -> Schedule -> [Common.TimeAbs] -> IO ()
sendEchos h sched echos = do
flip mapM_ echos $ \time ->
Event.output (Common.sequ h) $
Common.makeEcho h time (scheduleData sched)
_ <- Event.drainOutput (Common.sequ h)
debug "echos sent"
reserveSchedule ::
Reactor (RB.Event Common.TimeAbs, [Common.TimeAbs] -> IO ())
reserveSchedule = Reactor $ ReaderT $ \(addH,h) -> do
sched <- MS.get
MS.modify succ
eEcho <-
MT.lift $
fmap (fmap (Common.timeFromStamp . Event.timestamp) .
RB.filterE (checkSchedule sched)) $
RBI.fromAddHandler addH
return (eEcho, sendEchos h sched)
scheduleQueue :: Show a =>
RB.Behavior Common.TimeAbs ->
RB.Event (Common.Bundle a) -> Reactor (RB.Event a)
scheduleQueue times e = do
(eEcho, send) <- reserveSchedule
let -- maintain queue and generate Echo events
remove echoTime =
MS.state $ uncurry $ \_lastTime ->
EventList.switchL
(error "scheduleQueue: received more events than sent")
(\(_t,x) xs ->
((Just x, debug $ "got echo for event: " ++ show x),
({- Common.incTime t lastTime -}
echoTime, xs)))
add time new = do
MS.modify $ \(lastTime, old) ->
(time,
Common.mergeStable
(EventList.fromAbsoluteEventList $
EventListAbs.fromPairList $
map (\(Common.Future dt a) -> (dt,a)) $
List.sortBy (comparing Common.futureTime) new) $
EventList.decreaseStart
(Common.consTime "Causal.process.decreaseStart"
(time-lastTime)) old)
return (Nothing, send $ map (flip Common.incTime time . Common.futureTime) new)
-- (Queue that keeps track of events to schedule
-- , duration of the new alarm if applicable)
(eEchoEvent, _bQueue) =
sequence (0, EventList.empty) $
RB.union (fmap remove eEcho) (pure add <*> times <@> e)
reactimate $ fmap snd eEchoEvent
return $ RB.filterJust $ fmap fst eEchoEvent
debug :: String -> IO ()
debug =
const $ return ()
-- putStrLn
-- * utility functions
mapMaybe ::
(RB.FRP f) => (a -> Maybe b) -> RBM.Event f a -> RBM.Event f b
mapMaybe f = RB.filterJust . fmap f
partitionMaybe ::
(RB.FRP f) =>
(a -> Maybe b) -> RBM.Event f a -> (RBM.Event f b, RBM.Event f a)
partitionMaybe f =
(\x ->
(mapMaybe fst x,
mapMaybe (\(mb,a) -> maybe (Just a) (const Nothing) mb) x)) .
fmap (\a -> (f a, a))
traverse ::
(RB.FRP f) =>
s -> (a -> MS.State s b) -> RBM.Event f a ->
(RBM.Event f b, RBM.Behavior f s)
traverse s f = sequence s . fmap f
sequence ::
(RB.FRP f) =>
s -> RBM.Event f (MS.State s a) ->
(RBM.Event f a, RBM.Behavior f s)
sequence s =
RB.mapAccum s . fmap MS.runState
constant ::
(RB.FRP f) =>
a -> RBM.Behavior f a
constant a = RB.stepper a RB.never
-- * examples
{- |
register pressed keys
-}
pressed ::
(RB.FRP f, KeySet.C set) =>
set ->
RBM.Event f Event.Data ->
(RBM.Event f [Event.Data], RBM.Behavior f set)
pressed empty =
traverse empty
(\e ->
case e of
Event.NoteEv notePart note ->
fmap (map (uncurry Event.NoteEv)) $
KeySet.change notePart note
body ->
if Common.isAllNotesOff body
then fmap (map (uncurry Event.NoteEv))
KeySet.reset
else return [e])
latch ::
(RB.FRP f) =>
RBM.Event f Event.Data ->
(RBM.Event f Event.Data, RBM.Behavior f (Map.Map (Pitch, Channel) Velocity))
latch =
mapPair (RB.filterJust, fmap KeySet.deconsLatch) .
traverse KeySet.latch
(\e -> do
_ <- case e of
Event.NoteEv notePart note ->
fmap (fmap (uncurry Event.NoteEv)) $
KeySet.latchChange notePart note
_ -> return Nothing
return $ Just e)
{- |
Demonstration of scheduleQueue,
but for real use prefer 'delay',
since this uses precisely timed delivery by ALSA.
-}
delaySchedule ::
Common.Time ->
RB.Behavior Common.TimeAbs ->
RB.Event Event.Data -> Reactor (RB.Event Event.Data)
delaySchedule dt times =
scheduleQueue times .
fmap ((:[]) . Common.Future dt)
delay ::
Common.Time ->
RB.Event ev -> RB.Event (Common.Future ev)
delay dt =
fmap (Common.Future dt)
delayAdd ::
Common.Time ->
RB.Event ev -> RB.Event (Common.Future ev)
delayAdd dt evs =
RB.union (fmap Common.now evs) $ delay dt evs
{- |
Generate a beat according to the tempo control.
The input signal specifies the period between two beats.
The output events hold the times, where they occur.
-}
beat ::
RB.Behavior Common.Time -> Reactor (RB.Event Common.TimeAbs)
beat tempo = do
(eEcho, send) <- reserveSchedule
liftIO $ send [0]
let next dt time =
(time, send [Common.incTime dt time])
eEchoEvent =
RB.apply (fmap next tempo) eEcho
reactimate $ fmap snd eEchoEvent
return $ fmap fst eEchoEvent
{- |
Similar to 'beat' but warrants a maximum reaction time to tempo changes.
This way you can alter slow tempos to faster one more quickly.
-}
{-
Instead of this we could use the reciprocal of Time, that is frequency,
and integrate that.
But integration of a piecewise constant function means a linear function.
This cannot be represented in FRP.
The approach we use here samples the tempo signal
and thus may miss some tempo changes.
-}
beatQuant ::
Common.Time ->
RB.Behavior Common.Time -> Reactor (RB.Event Common.TimeAbs)
beatQuant maxDur tempo = do
(eEcho, send) <- reserveSchedule
liftIO $ send [0]
let next dt time = do
complete <- MS.gets (>=1)
when complete $ MS.modify (subtract 1)
portion <- MS.get
let dur = limit (0,maxDur) (Common.scaleTimeCeiling (1-portion) dt)
MS.modify (fromRational (Common.deconsTime dur / Common.deconsTime dt) +)
return
(toMaybe complete time,
send [Common.incTime dur time]
{- print (dur, time, dt, portion) -} )
eEchoEvent =
fst $ sequence 0 $ RB.apply (fmap next tempo) eEcho
reactimate $ fmap snd eEchoEvent
return $ RB.filterJust $ fmap fst eEchoEvent
tempoCtrl ::
(Check.C ev) =>
Channel ->
Controller ->
Common.Time -> (Common.Time, Common.Time) ->
RB.Event ev -> RB.Behavior Common.Time
tempoCtrl chan ctrl deflt (lower,upper) =
RB.stepper deflt .
RB.filterJust .
fmap (fmap (Common.ctrlDur (lower, upper))
. Check.controller chan ctrl)
controllerRaw ::
(Check.C ev) =>
Channel ->
Controller ->
Int ->
RB.Event ev -> RB.Behavior Int
controllerRaw chan ctrl deflt =
RB.stepper deflt . RB.filterJust .
fmap (Check.controller chan ctrl)
controllerExponential ::
(Floating a, Check.C ev) =>
Channel ->
Controller ->
a -> (a,a) ->
RB.Event ev -> RB.Behavior a
controllerExponential chan ctrl deflt (lower,upper) =
let k = log (upper/lower) / 127
in RB.stepper deflt .
RB.filterJust .
fmap (fmap ((lower*) . exp . (k*) . fromIntegral)
. Check.controller chan ctrl)
controllerLinear ::
(Fractional a, Check.C ev) =>
Channel ->
Controller ->
a -> (a,a) ->
RB.Event ev -> RB.Behavior a
controllerLinear chan ctrl deflt (lower,upper) =
let k = (upper-lower) / 127
in RB.stepper deflt .
RB.filterJust .
fmap (fmap ((lower+) . (k*) . fromIntegral)
. Check.controller chan ctrl)
pattern ::
(KeySet.C set) =>
Pattern.Mono set i ->
RB.Behavior Common.Time ->
RB.Behavior set ->
Reactor (RB.Event Common.EventDataBundle)
pattern pat tempo sets =
fmap (patternAux pat tempo sets) $
beat tempo
patternQuant ::
(KeySet.C set) =>
Common.Time ->
Pattern.Mono set i ->
RB.Behavior Common.Time ->
RB.Behavior set ->
Reactor (RB.Event Common.EventDataBundle)
patternQuant quant pat tempo sets =
fmap (patternAux pat tempo sets) $
beatQuant quant tempo
patternAux ::
(KeySet.C set) =>
Pattern.Mono set i ->
RB.Behavior Common.Time ->
RB.Behavior set ->
RB.Event Common.TimeAbs ->
RB.Event Common.EventDataBundle
patternAux (Pattern.Mono select ixs) tempo sets times =
pure
(\dur set i -> select i dur set)
<*> tempo
<*> sets
<@> (RB.filterJust $ fst $
RB.mapAccum ixs $
fmap (\ _time is ->
case is of
[] -> (Nothing, is)
i:rest -> (Just i, rest))
times)
cyclePrograms ::
[Program] ->
RB.Event Event.Data -> RB.Event (Maybe Event.Data)
cyclePrograms pgms =
fst .
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 ::
Common.Time -> [Program] ->
RB.Behavior Common.TimeAbs ->
RB.Event Event.Data -> RB.Event (Maybe Event.Data)
cycleProgramsDefer defer pgms times =
fst .
traverse (cycle pgms, 0)
(\(eventTime,e) ->
case e of
Event.CtrlEv Event.PgmChange ctrl ->
AccState.lift AccTuple.first $
Common.seekProgram (length pgms) (ctrl ^. MALSA.ctrlProgram)
Event.NoteEv notePart note -> do
blockTime <- MS.gets snd
if eventTime < blockTime
then return Nothing
else
case fst $ normalNoteFromEvent notePart note of
Event.NoteOn -> do
AccState.set AccTuple.second $
Common.incTime defer eventTime
AccState.lift AccTuple.first $
Common.nextProgram note
_ -> return Nothing
_ -> return Nothing) .
RB.apply (fmap (,) times)
newtype PitchChannel =
PitchChannel ((Pitch, Channel), 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,_), _)) = p
transpose d (PitchChannel ((p,c),v)) = do
p' <- Common.increasePitch d p
return $ PitchChannel ((p',c), v)
noteSequence ::
Common.Time ->
Event.NoteEv -> [Event.Note] ->
Common.EventDataBundle
noteSequence stepTime onOff =
zipWith Common.Future (iterate (stepTime+) 0) .
map (Event.NoteEv onOff)
{- |
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.
Call it like @guitar stepTime chords triggers@.
@stepTime@ is the delay between to successive notes.
A good value is 0.03 (seconds).
The chords to be played are passed in by @chords@.
This should be the output of 'pressed'.
Further on the function needs events
that trigger playing the chord in @trigger@ argument.
The trigger consists of the trigger time
and the direction to be played
('True' = down from high to low pitches,
'False' = up from low to high pitches).
The trigger may be derived from a specific key that is pressed and released,
or two keys, one for each direction.
-}
guitar ::
(KeySet.C set) =>
Common.Time ->
RB.Behavior set ->
RB.Event Bool ->
RB.Event Common.EventDataBundle
guitar stepTime pressd trigger =
fst $
traverse []
(\(set, on) -> do
played <- MS.get
let toPlay =
case KeySet.toList set of
[] -> []
list ->
fmap (\(PitchChannel ((p,c),v)) ->
MALSA.noteEvent c p v v 0) $
Guitar.mapChordToString Guitar.stringPitches $
fmap PitchChannel list
MS.put toPlay
return $
if on
then
noteSequence stepTime Event.NoteOff
(List.reverse played)
++
noteSequence stepTime Event.NoteOn toPlay
else
noteSequence stepTime Event.NoteOff played
++
noteSequence stepTime Event.NoteOn
(List.reverse toPlay)) $
pure (,) <*> pressd <@> trigger
{- |
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.
-}
{-
The Reactor monad is only needed for sending the initial notes.
-}
trainer ::
Channel ->
Common.Time -> Common.Time ->
[([Pitch], [Pitch])] ->
RB.Behavior Common.TimeAbs ->
RB.Event Event.Data ->
Reactor (RB.Event Common.EventDataBundle)
trainer chan pause duration sets0 times evs0 = do
let makeSeq sets =
case sets of
(target, _) : _ ->
(concat $
zipWith
(\t p ->
Common.eventsFromKey t duration
((p,chan), normalVelocity))
(iterate (duration+) pause) target,
pause + duration * fromIntegral (length target))
[] -> ([], 0)
let (initial, initIgnoreUntil) = makeSeq sets0
getHandle >>= \h -> liftIO (outputEvents h 0 initial)
return $ fst $
flip (traverse (sets0, [], Common.incTime initIgnoreUntil 0))
(fmap (,) times <@> evs0) $ \(time,ev) ->
case ev of
Event.NoteEv notePart note ->
case fst $ normalNoteFromEvent notePart note of
Event.NoteOn -> do
ignoreUntil <- AccState.get AccTuple.third3
if time <= ignoreUntil
then return []
else do
pressd <- AccState.get AccTuple.second3
let newPressd = (note ^. MALSA.notePitch) : pressd
AccState.set AccTuple.second3 newPressd
sets <- AccState.get AccTuple.first3
case sets of
(_, target) : rest ->
if Match.lessOrEqualLength target newPressd
then do
AccState.set AccTuple.second3 []
when (newPressd == List.reverse target) $
AccState.set AccTuple.first3 rest
(notes, newIgnoreUntil) <-
fmap makeSeq $
AccState.get AccTuple.first3
AccState.set AccTuple.third3 $
Common.incTime newIgnoreUntil time
return notes
else return []
_ -> return []
_ -> return []
_ -> return []
sweep ::
Common.Time ->
(Double -> Double) ->
RB.Behavior Double ->
Reactor (RB.Event Common.TimeAbs, RB.Behavior Double)
sweep dur wave speed = do
bt <- beat $ constant dur
let durD = realToFrac $ Common.deconsTime dur
return
(bt,
fmap wave $ RB.accumB 0 $
fmap (\d _ phase -> Common.fraction (phase + durD * d)) speed <@> bt)
makeControllerLinear ::
Channel -> Controller ->
RB.Behavior Int ->
RB.Behavior Int ->
RB.Event Common.TimeAbs -> RB.Behavior Double ->
RB.Event Event.Data
makeControllerLinear chan cc depthCtrl centerCtrl bt ctrl =
pure
(\y depth center _time ->
Event.CtrlEv Event.Controller $
MALSA.controllerEvent chan cc $
round $ limit (0,127) $
fromIntegral center + fromIntegral depth * y)
<*> ctrl
<*> depthCtrl
<*> centerCtrl
<@> bt