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