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.KeySet as KeySet
import qualified Reactive.Banana.ALSA.Time as Time
import qualified Reactive.Banana.ALSA.Utility as RBU
import qualified Reactive.Banana.Combinators as RB
import qualified Reactive.Banana.Frameworks as RBF
import qualified Reactive.Banana.Switch as RBS
import Reactive.Banana.Combinators ((<@>), )
import qualified Sound.ALSA.Sequencer.Event.RemoveMonad as Remove
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,
fromPitch, toPitch, )
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, liftM2, guard, )
import Control.Applicative (Applicative, pure, liftA2, (<*>), )
import Data.Monoid (mempty, mappend, )
import Data.Bool.HT (if', )
import Data.Tuple.HT (mapPair, mapFst, )
import Data.Ord.HT (comparing, limit, )
import Data.Maybe.HT (toMaybe, )
import Data.Maybe (catMaybes, )
import qualified Data.Map as Map
import qualified Data.List as List
import qualified Data.List.Key as Key
import qualified Data.List.Match as Match
import Prelude hiding (sequence, )
newtype Reactor t a =
Reactor {
runReactor ::
MR.ReaderT
(RBF.AddHandler Event.T, Common.Handle)
(MS.StateT Schedule (RBS.Moment t))
a
} deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
liftNetworkDescription :: RBS.Moment t a -> Reactor t a
liftNetworkDescription act =
Reactor $ MT.lift $ MT.lift act
type Schedule = Event.Tag
startSchedule :: Schedule
startSchedule = Event.Tag 1
nextSchedule :: Schedule -> Schedule
nextSchedule (Event.Tag s) =
if s == maxBound
then error $ "maximum number of schedules " ++ show s ++ " reached"
else Event.Tag $ succ s
getHandle :: Reactor t Common.Handle
getHandle = Reactor $ MR.asks snd
run ::
(Common.Events ev) =>
(forall t.
(RBF.Frameworks t) =>
RB.Event t Event.Data -> RB.Event t ev) ->
ReaderT Common.Handle IO ()
run f =
runM (\ _ts xs -> return $ f xs)
runM ::
(Common.Events ev) =>
(forall t.
(RBF.Frameworks t) =>
RB.Behavior t Time.Abs ->
RB.Event t Event.Data -> Reactor t (RB.Event t ev)) ->
ReaderT Common.Handle IO ()
runM f = do
Common.startQueue
MR.ReaderT $ \h -> do
(addEventHandler, runEventHandler) <- RBF.newAddHandler
(addEchoHandler, runEchoHandler) <- RBF.newAddHandler
(addTimeHandler, runTimeHandler) <- RBF.newAddHandler
RBF.actuate =<< RBF.compile (do
time <-
fmap (RB.stepper 0) $
RBF.fromAddHandler addTimeHandler
evs <-
flip MS.evalStateT startSchedule
. flip MR.runReaderT (addEchoHandler, h)
. runReactor
. f time
. fmap Event.body
=<< RBF.fromAddHandler addEventHandler
RBF.reactimate $
pure (outputEvents h) <*> time <@> evs)
forever $ do
ev <- Event.input (Common.sequ h)
runTimeHandler $ Time.fromEvent 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 -> Time.Abs -> evs -> IO ()
outputEvents h time evs = do
mapM_ (Event.output (Common.sequ h)) $
map (\(Common.Future dt body) ->
Common.makeEvent h (Time.inc dt time) body) $
Common.flattenEvents evs
_ <- Event.drainOutput (Common.sequ h)
return ()
checkSchedule :: Schedule -> Event.T -> Bool
checkSchedule sched echo =
maybe False (sched ==) $ do
Event.CustomEv Event.Echo _ <- Just $ Event.body echo
return $ Event.tag echo
reactimate ::
(RBF.Frameworks t) =>
RB.Event t (IO ()) -> Reactor t ()
reactimate evs =
Reactor $ MT.lift $ MT.lift $ RBF.reactimate evs
sendEchos :: Common.Handle -> Schedule -> [Time.Abs] -> IO ()
sendEchos h sched echos = do
flip mapM_ echos $ \time ->
Event.output (Common.sequ h) $
(Common.makeEcho h time)
{ Event.tag = sched }
_ <- Event.drainOutput (Common.sequ h)
debug "echos sent"
cancelEchos :: Common.Handle -> Schedule -> IO ()
cancelEchos h sched =
Remove.run (Common.sequ h) $ do
Remove.setOutput
Remove.setEventType Event.Echo
Remove.setTag sched
reserveSchedule ::
(RBF.Frameworks t) =>
Reactor t (RB.Event t Time.Abs, [Time.Abs] -> IO (), IO ())
reserveSchedule = Reactor $ ReaderT $ \(addH,h) -> do
sched <- MS.get
MS.modify nextSchedule
eEcho <-
MT.lift $
fmap (fmap Time.fromEvent .
RB.filterE (checkSchedule sched)) $
RBF.fromAddHandler addH
return (eEcho, sendEchos h sched, cancelEchos h sched)
scheduleQueue ::
(RBF.Frameworks t, Show a) =>
RB.Behavior t Time.Abs ->
RB.Event t (Common.Bundle a) -> Reactor t (RB.Event t a)
scheduleQueue times e = do
(eEcho, send, _) <- reserveSchedule
let
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),
(
echoTime, xs)))
add time new = do
MS.modify $ \(lastTime, old) ->
(time,
Common.mergeStable
(EventList.mapTime (Time.cons "scheduleQueue") $
EventList.fromAbsoluteEventList $
EventListAbs.fromPairList $
map (\(Common.Future dt a) -> (Time.decons dt, a)) $
List.sortBy (comparing Common.futureTime) new) $
EventList.decreaseStart
(Time.cons "Causal.process.decreaseStart"
(timelastTime)) old)
return (Nothing, send $ map (flip Time.inc time . Common.futureTime) new)
(eEchoEvent, _bQueue) =
RBU.sequence (0, EventList.empty) $
RB.union (fmap remove eEcho) (pure add <*> times <@> e)
reactimate $ fmap snd eEchoEvent
return $ RBU.mapMaybe fst eEchoEvent
debug :: String -> IO ()
debug =
const $ return ()
bypass ::
(Common.Events a, Common.Events c) =>
(a -> Maybe b) ->
(RB.Event f b -> RB.Event f c) ->
RB.Event f a -> RB.Event f [Common.Future Event.Data]
bypass p f =
RBU.bypass p (fmap Common.flattenEvents) (fmap Common.flattenEvents . f)
pressed ::
(KeySet.C set) =>
set ->
RB.Event f Common.NoteBoundaryExt ->
(RB.Event f [Common.NoteBoundary], RB.Behavior f set)
pressed empty =
RBU.traverse empty
(\e ->
case e of
Common.NoteBoundaryExt bnd -> KeySet.change bnd
Common.AllNotesOff -> KeySet.reset)
latch ::
RB.Event f Common.NoteBoundary ->
(RB.Event f Common.NoteBoundary,
RB.Behavior f (Map.Map (Pitch, Channel) Velocity))
latch =
mapPair (RB.filterJust, fmap KeySet.deconsLatch) .
RBU.traverse KeySet.latch KeySet.latchChange
delaySchedule ::
(RBF.Frameworks t) =>
Time.T ->
RB.Behavior t Time.Abs ->
RB.Event t Event.Data -> Reactor t (RB.Event t Event.Data)
delaySchedule dt times =
scheduleQueue times .
fmap ((:[]) . Common.Future dt)
delay ::
Time.T ->
RB.Event t ev -> RB.Event t (Common.Future ev)
delay dt =
fmap (Common.Future dt)
delayAdd ::
Time.T ->
RB.Event t ev -> RB.Event t (Common.Future ev)
delayAdd dt evs =
RB.union (fmap Common.now evs) $ delay dt evs
beat ::
(RBF.Frameworks t) =>
RB.Behavior t Time.T -> Reactor t (RB.Event t Time.Abs)
beat tempo = do
(eEcho, send, _) <- reserveSchedule
liftIO $ send [0]
let next dt time =
(time, send [Time.inc dt time])
eEchoEvent = fmap next tempo <@> eEcho
reactimate $ fmap snd eEchoEvent
return $ fmap fst eEchoEvent
beatQuant ::
(RBF.Frameworks t) =>
Time.T ->
RB.Behavior t Time.T -> Reactor t (RB.Event t Time.Abs)
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 (mempty,maxDur) (Time.scaleCeiling (1portion) dt)
MS.modify (Time.div dur dt +)
return
(toMaybe complete time,
send [Time.inc dur time]
)
eEchoEvent =
fst $ RBU.sequence 0 $ fmap next tempo <@> eEcho
reactimate $ fmap snd eEchoEvent
return $ RBU.mapMaybe fst eEchoEvent
beatVar ::
(RBF.Frameworks t) =>
RB.Behavior t Time.Abs ->
RB.Behavior t Time.T ->
Reactor t (RB.Event t Time.Abs)
beatVar time tempo = do
(eEcho, send, cancel) <- reserveSchedule
liftIO $ send [0]
(tempoInit, tempoChanges) <-
Reactor $ MT.lift $ MT.lift $
liftM2 (,) (RBF.initial tempo) (RBF.changes tempo)
let change ::
Time.T -> Time.Abs ->
MS.State
(Time.Abs, Double, Time.T)
(Maybe Time.Abs, IO ())
next _t = do
(t0,r,p) <- MS.get
let t1 = Time.inc (Time.scale r p) t0
MS.put (t1,1,p)
return (Just t1, send [Time.inc p t1])
change p1 t1 = do
(t0,r0,p0) <- MS.get
let r1 = max 0 $ r0 Time.div (Time.subSat t1 t0) p0
MS.put (t1,r1,p1)
return
(Nothing,
cancel >>
send [Time.inc (Time.scale r1 p1) t1])
eEchoEvent =
fst $ RBU.sequence (0, 0, tempoInit) $
RB.union
(fmap next eEcho)
(fmap (flip change) time <@> tempoChanges)
reactimate $ fmap snd eEchoEvent
return $ RBU.mapMaybe fst eEchoEvent
tempoCtrl ::
(Check.C ev) =>
Channel ->
Controller ->
Time.T -> (Time.T, Time.T) ->
RB.Event t ev -> (RB.Behavior t Time.T, RB.Event t ev)
tempoCtrl chan ctrl deflt (lower,upper) =
mapFst (RB.stepper deflt) .
RBU.partitionMaybe
(fmap (Common.ctrlDur (lower, upper))
. Check.controller chan ctrl)
controllerRaw ::
(Check.C ev) =>
Channel ->
Controller ->
Int ->
RB.Event t ev -> RB.Behavior t Int
controllerRaw chan ctrl deflt =
RB.stepper deflt .
RBU.mapMaybe (Check.controller chan ctrl)
controllerExponential ::
(Floating a, Check.C ev) =>
Channel ->
Controller ->
a -> (a,a) ->
RB.Event t ev -> RB.Behavior t a
controllerExponential chan ctrl deflt (lower,upper) =
let k = log (upper/lower) / 127
in RB.stepper deflt .
RBU.mapMaybe
(fmap ((lower*) . exp . (k*) . fromIntegral)
. Check.controller chan ctrl)
controllerLinear ::
(Fractional a, Check.C ev) =>
Channel ->
Controller ->
a -> (a,a) ->
RB.Event t ev -> RB.Behavior t a
controllerLinear chan ctrl deflt (lower,upper) =
let k = (upperlower) / 127
in RB.stepper deflt .
RBU.mapMaybe
(fmap ((lower+) . (k*) . fromIntegral)
. Check.controller chan ctrl)
cyclePrograms ::
[Program] ->
RB.Event t Event.Data -> RB.Event t (Maybe Event.Data)
cyclePrograms pgms =
fst .
RBU.traverse (cycle pgms)
(Common.traverseProgramsSeek (length pgms))
cycleProgramsDefer ::
Time.T -> [Program] ->
RB.Behavior t Time.Abs ->
RB.Event t Event.Data -> RB.Event t (Maybe Event.Data)
cycleProgramsDefer defer pgms times =
fst .
RBU.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 $
Time.inc 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 ::
Time.T ->
Event.NoteEv -> [Event.Note] ->
Common.EventDataBundle
noteSequence stepTime onOff =
zipWith Common.Future (iterate (mappend stepTime) mempty) .
map (Event.NoteEv onOff)
guitar ::
(KeySet.C set) =>
Time.T ->
RB.Behavior t set ->
RB.Event t Bool ->
RB.Event t Common.EventDataBundle
guitar stepTime pressd trigger =
fst $
RBU.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
trainer ::
(RBF.Frameworks t) =>
Channel ->
Time.T -> Time.T ->
[([Pitch], [Pitch])] ->
RB.Behavior t Time.Abs ->
RB.Event t Event.Data ->
Reactor t (RB.Event t 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 (mappend duration) pause) target,
mappend pause $ Time.scaleInt (length target) duration)
[] -> ([], mempty)
let (initial, initIgnoreUntil) = makeSeq sets0
getHandle >>= \h -> liftIO (outputEvents h 0 initial)
return $ fst $
flip (RBU.traverse (sets0, [], Time.inc 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 $
Time.inc newIgnoreUntil time
return notes
else return []
_ -> return []
_ -> return []
_ -> return []
sweep ::
(RBF.Frameworks t) =>
Time.T ->
(Double -> Double) ->
RB.Behavior t Double ->
Reactor t (RB.Event t Time.Abs, RB.Behavior t Double)
sweep dur wave speed = do
bt <- beat $ pure dur
let durD = realToFrac $ Time.decons dur
return
(bt,
fmap wave $ RB.accumB 0 $
fmap (\d _ phase -> Common.fraction (phase + durD * d)) speed <@> bt)
makeControllerLinear ::
Channel -> Controller ->
RB.Behavior t Int ->
RB.Behavior t Int ->
RB.Event t Time.Abs -> RB.Behavior t Double ->
RB.Event t 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
snapSelect ::
(RBF.Frameworks t, KeySet.C set) =>
RB.Behavior t set ->
RB.Behavior t Int ->
Reactor t (RB.Event t [Event.Data])
snapSelect set ctrl =
liftNetworkDescription $
fmap (fst . RB.mapAccum Nothing .
fmap (\newNote oldNote ->
(guard (newNote/=oldNote) >>
catMaybes [fmap (Event.NoteEv Event.NoteOff .
uncurry (uncurry Common.simpleNote)) oldNote,
fmap (Event.NoteEv Event.NoteOn .
uncurry (uncurry Common.simpleNote)) newNote],
newNote))) $
RBF.changes $
liftA2
(\s x ->
toMaybe (not $ null s) $
Key.minimum (\((_c,p), _v) -> abs (fromPitch p x)) $
map (\((p,c), v) -> ((c, transposeToClosestOctave x p), v)) s)
(fmap KeySet.toList set) ctrl
transposeToClosestOctave :: Int -> Pitch -> Pitch
transposeToClosestOctave target sourceClass =
let t = target
s = fromPitch sourceClass
x = mod (s t + 6) 12 + t 6
in toPitch $
if' (x<0) (x+12) $
if' (x>127) (x12) x
uniqueChanges ::
(RBF.Frameworks t, Eq a) =>
RB.Behavior t a -> Reactor t (RB.Event t a)
uniqueChanges x = liftNetworkDescription $ do
x0 <- RBF.initial x
xs <- RBF.changes x
return $ RB.filterJust $ fst $
RB.mapAccum x0 $ fmap (\new old -> (toMaybe (new/=old) new, new)) xs