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 {-
  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
  18                                   , strength    = s
  19                                   },ph), ebno) ->
  20   arr $ fmap (uncurry5 advanceHeads)
  21   -< ebno `tag` (board, fromEvent ebno, rp, s, ph)
  22   --returnA -< traceShow e e
  23
  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)
  28 -}
  29
  30 singleBoard :: [PlayHead]
  31             -> SF (Board, Layer, Event BeatNo) (Event ([PlayHead], [Note]))
  32 singleBoard iPh = proc (board, Layer { relPitch = rp
  33                                      , strength = s
  34                                      }, ebno) ->
  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)
  37
  38 boardSF :: SF (Board, Layer, Tempo, BoardRun) (Event ([PlayHead], [Note]))
  39 boardSF = proc (board, l, t, br) -> do
  40   ebno <- layerMetronome -< (t,l)
  41   ess <- onChange -< br
  42   boardSwitch [] -< ((board, l, ebno), ess `tag` (br, startHeads board))
  43
  44 boardSwitch :: [PlayHead]
  45             -> SF ((Board, Layer,Event BeatNo), Event (BoardRun, [PlayHead]))
  46                (Event ([PlayHead],[Note]))
  47 boardSwitch rPh = dSwitch (singleBoard rPh *** (identity >>> notYet)) fnSwitch
  48   where fnSwitch (BoardStart, iPh) = boardSwitch iPh
  49         fnSwitch (BoardStop, _) = boardSwitch []