]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Layer/Board.hs
MIDI influences the GUI back.
[tmp/julm/arpeggigon.git] / src / RMCA / Layer / Board.hs
1 {-# LANGUAGE Arrows #-}
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 import Debug.Trace
14
15 data RunStatus = Running | Stopped
16
17 automaton :: [PlayHead]
18 -> SF (Board, DynLayerConf, Event BeatNo)
19 (Event [Note], [PlayHead])
20 automaton iphs = proc (b, DynLayerConf { relPitch = rp
21 , strength = s
22 }, ebno) -> do
23 enphs <- accumBy advanceHeads' (iphs,[])
24 -< ebno `tag` (b, fromEvent ebno, rp, s)
25 (ephs,en) <- arr splitE -< enphs
26 phs <- hold iphs -< ephs
27 returnA -< (en, phs)
28 where advanceHeads' (ph,_) (board,bno,rp,s) = advanceHeads board bno rp s ph
29
30
31 layer :: SF (Event AbsBeat, Board, LayerConf, Event RunStatus)
32 (Event [Note], [PlayHead])
33 layer = layerStopped
34 where switchStatus (rs, slc, iphs) = case rs of
35 Stopped -> layerStopped
36 Running -> layerRunning slc iphs
37
38 layerStopped = switch lsAux switchStatus
39
40 layerRunning slc iphs = switch (lrAux slc iphs) switchStatus
41
42 lsAux = proc (_, b, (slc,_,_), ers) -> do
43 en <- never -< ()
44 phs <- constant [] -< ()
45 e <- notYet -< fmap (\rs -> (rs, slc, startHeads b)) ers
46 returnA -< ((en,phs),e)
47
48 lrAux slc iphs = proc (eab, b, (slc',dlc,_), ers) -> do
49 ebno <- layerMetronome slc -< (traceShow eab eab, dlc)
50 enphs@(_,phs) <- automaton iphs -< (b, dlc, ebno)
51 r <- (case repeatCount slc of
52 Nothing -> never
53 Just n -> countTo (n * beatsPerBar slc)) -< ebno
54 let ers' = ers `lMerge` (r `tag` Running)
55 e <- notYet -< fmap (\rs -> (rs, slc', phs ++ startHeads b)) ers'
56 returnA -< (enphs,e)
57
58 layers :: M.IntMap a
59 -> SF (Tempo, Event RunStatus,
60 M.IntMap (Board,LayerConf,Event RunStatus))
61 (M.IntMap (Event [Note], [PlayHead]))
62 layers imap = proc (t,erun,map) -> do
63 elc <- edgeBy diffSig (M.keys imap) -< M.keys map
64 let e = fmap switchCol elc
65 newMetronome Running = metronome
66 newMetronome Stopped = never
67 eabs <- rSwitch metronome -< (t, newMetronome <$> erun)
68 rpSwitch routing (imap $> layer) -< ((eabs,erun,map),e)
69 where routing (eabs,erun,map) sfs = M.intersectionWith (,)
70 (fmap (\(b,l,er) -> (eabs,b,l,erun `lMerge` er)) map) sfs
71
72 diffSig :: [Int] -> [Int] -> Maybe ([Int],[Int])
73 diffSig oL nL
74 | oL == nL = Nothing
75 | otherwise = Just (oL \\ nL, nL \\ oL)
76
77 switchCol (oldSig,newSig) col =
78 foldr (\k m -> M.insert k layer m)
79 (foldr M.delete col oldSig) newSig