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