]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Layer/Board.hs
New README and name change.
[tmp/julm/arpeggigon.git] / src / RMCA / Layer / Board.hs
1 {-# LANGUAGE Arrows, TupleSections #-}
2
3 module RMCA.Layer.Board where
4
5 import qualified Data.IntMap as M
6 import Data.List ((\\))
7 import FRP.Yampa
8 import RMCA.Auxiliary
9 import RMCA.Global.Clock
10 import RMCA.Layer.LayerConf
11 import RMCA.Semantics
12
13 data RunStatus = Running | Stopped deriving(Show, Eq)
14
15 layerMetronome :: StaticLayerConf
16 -> SF (Event AbsBeat, DynLayerConf) (Event BeatNo)
17 layerMetronome StaticLayerConf { beatsPerBar = bpb
18 } =
19 proc (eb, DynLayerConf { layerBeat = r
20 }) -> do
21 ewbno <- accumFilter (\_ (ab,r) -> ((),selectBeat (ab,r))) () -< (,r) <$> eb
22 accumBy (flip nextBeatNo) 0 -< ewbno `tag` bpb
23 where selectBeat (absBeat, layBeat) =
24 maybeIf ((absBeat - 1) `mod`
25 floor (fromIntegral maxAbsBeat * layBeat) == 0)
26
27 automaton :: [PlayHead]
28 -> SF (Board, DynLayerConf, Event BeatNo)
29 (Event [Note], [PlayHead])
30 automaton iphs = proc (b, DynLayerConf { relPitch = rp
31 , strength = s
32 }, ebno) -> do
33 enphs <- accumBy advanceHeads' (iphs,[])
34 -< ebno `tag` (b, fromEvent ebno, rp, s)
35 (ephs,en) <- arr splitE -< enphs
36 phs <- hold iphs -< ephs
37 returnA -< (en, phs)
38 where advanceHeads' (ph,_) (board,bno,rp,s) = advanceHeads board bno rp s ph
39
40
41 layer :: SF (Event AbsBeat, Board, LayerConf, Event RunStatus)
42 (Event [Note], [PlayHead])
43 layer = layerStopped
44 where switchStatus (rs, slc, iphs) = case rs of
45 Stopped -> layerStopped
46 Running -> layerRunning slc iphs
47
48 layerStopped = switch lsAux switchStatus
49
50 layerRunning slc iphs = switch (lrAux slc iphs) switchStatus
51
52 lsAux = proc (_, b, (slc,_,_), ers) -> do
53 en <- never -< ()
54 phs <- constant [] -< ()
55 e <- notYet -< fmap (\rs -> (rs, slc, startHeads b)) ers
56 returnA -< ((en,phs),e)
57
58 lrAux slc iphs = proc (eab, b, (slc',dlc,_), ers) -> do
59 ebno <- layerMetronome slc -< (eab, dlc)
60 enphs@(_,phs) <- automaton iphs -< (b, dlc, ebno)
61 r <- (case repeatCount slc of
62 Nothing -> never
63 Just n -> countTo (1 + n * beatsPerBar slc)) -< ebno
64 erun <- waitForEvent -< (filterE (== Running) ers,ebno)
65 estop <- arr $ filterE (/= Running) -< ers
66 let ers' = erun `lMerge` estop
67 ers'' = ers' `lMerge` (r `tag` Running)
68 ophs <- iPre iphs -< phs
69 let ophs' = if keepHeads dlc then ophs else []
70 e <- notYet -< fmap (\rs -> (rs, slc', ophs' ++ startHeads b)) ers''
71 returnA -< (enphs,e)
72
73 layers :: M.IntMap a
74 -> SF (Tempo, Event RunStatus,
75 M.IntMap (Board,LayerConf,Event RunStatus))
76 (M.IntMap (Event [Note], [PlayHead]))
77 layers imap = proc (t,erun,map) -> do
78 elc <- edgeBy diffSig (M.keys imap) -< M.keys map
79 let e = fmap switchCol elc
80 newMetronome Running = metronome
81 newMetronome Stopped = never
82 erun' <- accumFilter (\oRS nRS ->
83 case (oRS,nRS) of
84 (Stopped,_) -> (nRS,Just nRS)
85 (Running, Stopped) -> (Stopped,Just Stopped)
86 _ -> (oRS,Nothing)) Stopped -< erun
87 eabs <- rSwitch metronome -< (t, newMetronome <$> erun')
88 rpSwitch routing (imap $> layer) -< ((eabs,erun,map),e)
89 where routing (eabs,erun,map) sfs = M.intersectionWith (,)
90 (fmap (\(b,l,er) -> (eabs,b,l,erun `lMerge` er)) map) sfs
91
92 diffSig :: [Int] -> [Int] -> Maybe ([Int],[Int])
93 diffSig oL nL
94 | oL == nL = Nothing
95 | otherwise = Just (oL \\ nL, nL \\ oL)
96
97 switchCol (oldSig,newSig) col =
98 foldr (\k m -> M.insert k layer m)
99 (foldr M.delete col oldSig) newSig