]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Layer/Board.hs
Basic tab system but completely not very well linked to the internal machine…
[tmp/julm/arpeggigon.git] / src / RMCA / Layer / Board.hs
1 {-# LANGUAGE Arrows #-}
2
3 module RMCA.Layer.Board where
4
5 import FRP.Yampa
6 import RMCA.Auxiliary
7 import RMCA.Layer.Layer
8 import RMCA.Semantics
9
10 data BoardRun = BoardStart | BoardStop deriving Eq
11
12 singleBoard :: [PlayHead]
13 -> SF (Board, Layer, Event BeatNo) (Event ([PlayHead], [Note]))
14 singleBoard iPh = proc (board, Layer { relPitch = rp
15 , strength = s
16 }, ebno) ->
17 accumBy advanceHeads' (iPh,[]) -< ebno `tag` (board, fromEvent ebno, rp, s)
18 where advanceHeads' (ph,_) (board,bno,rp,s) = uncurry5 advanceHeads (board,bno,rp,s,ph)
19
20 boardSF :: SF (Board, Layer, Tempo, BoardRun) (Event ([PlayHead], [Note]))
21 boardSF = proc (board, l, t, br) -> do
22 ebno <- layerMetronome -< (t,l)
23 ess <- onChange -< br
24 boardSwitch [] -< ((board, l, ebno), ess `tag` (br, startHeads board))
25
26 boardSwitch :: [PlayHead]
27 -> SF ((Board, Layer,Event BeatNo), Event (BoardRun, [PlayHead]))
28 (Event ([PlayHead],[Note]))
29 boardSwitch rPh = dSwitch (singleBoard rPh *** (identity >>> notYet)) fnSwitch
30 where fnSwitch (BoardStart, iPh) = boardSwitch iPh
31 fnSwitch (BoardStop, _) = boardSwitch []