1 {-# LANGUAGE Arrows #-}
3 module RMCA.Layer.Board where
7 import RMCA.Layer.Layer
10 data BoardRun = BoardStart | BoardStop deriving Eq
13 -- The state of the board is described by the list of the playheads
14 -- and the different actions onto the board.
15 boardAction :: SF ((Board, Layer, [PlayHead]), Event BeatNo)
16 (Event ([PlayHead], [Note]))
17 boardAction = proc ((board, Layer { relPitch = rp
20 arr $ fmap (uncurry5 advanceHeads)
21 -< ebno `tag` (board, fromEvent ebno, rp, s, ph)
22 --returnA -< traceShow e e
24 boardSF :: SF (Board, Layer, [PlayHead], Tempo) (Event ([PlayHead], [Note]))
25 boardSF = proc (board, l, ph, t) -> do
26 ebno <- layerMetronome -< (t, l)
27 boardAction -< ((board, l, ph), ebno)
30 singleBoard :: [PlayHead]
31 -> SF (Board, Layer, Event BeatNo) (Event ([PlayHead], [Note]))
32 singleBoard iPh = proc (board, Layer { relPitch = rp
35 accumBy advanceHeads' (iPh,[]) -< ebno `tag` (board, fromEvent ebno, rp, s)
36 where advanceHeads' (ph,_) (board,bno,rp,s) = uncurry5 advanceHeads (board,bno,rp,s,ph)
38 boardSF :: SF (Board, Layer, Tempo, BoardRun) (Event ([PlayHead], [Note]))
39 boardSF = proc (board, l, t, br) -> do
40 ebno <- layerMetronome -< (t,l)
42 boardSwitch [] -< ((board, l, ebno), ess `tag` (br, startHeads board))
44 boardSwitch :: [PlayHead]
45 -> SF ((Board, Layer,Event BeatNo), Event (BoardRun, [PlayHead]))
46 (Event ([PlayHead],[Note]))
47 boardSwitch rPh = dSwitch (singleBoard rPh *** identity) fnSwitch
48 where fnSwitch (BoardStart, iPh) = boardSwitch iPh
49 fnSwitch (BoardStop, _) = boardSwitch []