src/RMCA/Layer/Board.hs

   1 {-# LANGUAGE Arrows #-}
   2
   3 module RMCA.Layer.Board ( boardRun
   4                         , BoardRun (..)
   5                         ) where
   6
   7 import qualified Data.IntMap       as M
   8 import           Data.List         ((\\))
   9 import           FRP.Yampa
  10 import           RMCA.Auxiliary
  11 import           RMCA.Global.Clock
  12 import           RMCA.Layer.Layer
  13 import           RMCA.Semantics
  14
  15 data BoardRun = BoardStart | BoardStop deriving (Eq, Show)
  16
  17 singleBoard :: [PlayHead]
  18             -> SF (Board, Layer, Event BeatNo) (Event ([PlayHead], [Note]))
  19 singleBoard iPh = proc (board, Layer { relPitch = rp
  20                                      , strength = s
  21                                      }, ebno) ->
  22   accumBy advanceHeads' (iPh,[]) -< ebno `tag` (board, fromEvent ebno, rp, s)
  23   where advanceHeads' (ph,_) (board,bno,rp,s) = advanceHeads board bno rp s ph
  24
  25 boardSF :: SF (Event AbsBeat, Board, Layer, BoardRun)
  26               (Event ([PlayHead], [Note]))
  27 boardSF = proc (eabs, board, l, br) -> do
  28   ebno <- layerMetronome -< (eabs,l)
  29   ess <- onChange -< br
  30   boardSwitch [] -< ((board, l, ebno), ess `tag` (br, startHeads board))
  31
  32 boardSwitch :: [PlayHead]
  33             -> SF ((Board, Layer, Event BeatNo), Event (BoardRun, [PlayHead]))
  34                   (Event ([PlayHead],[Note]))
  35 boardSwitch rPh = dSwitch (singleBoard rPh *** (identity >>> notYet)) fnSwitch
  36   where fnSwitch (BoardStart, iPh) = boardSwitch iPh
  37         fnSwitch (BoardStop, _) = boardSwitch []
  38
  39 --------------------------------------------------------------------------------
  40 -- Machinery to make boards run in parallel
  41 --------------------------------------------------------------------------------
  42
  43 boardRun' :: M.IntMap (SF (Event AbsBeat,Board,Layer,BoardRun)
  44                           (Event ([PlayHead],[Note])))
  45           -> SF (Event AbsBeat, BoardRun, M.IntMap (Board,Layer))
  46                 (M.IntMap (Event ([PlayHead],[Note])))
  47 boardRun' iSF = boardRun'' iSF (lengthChange iSF)
  48   where boardRun'' iSF swSF = pSwitch routeBoard iSF swSF contSwitch
  49         contSwitch contSig (oldSig, newSig) = boardRun'' newSF
  50                                               (lengthChange newSF >>> notYet)
  51           where newSF = foldr (\k m -> M.insert k boardSF m)
  52                         (foldr M.delete contSig oldSig) newSig
  53         lengthChange iSig = edgeBy diffSig ik <<^ M.keys <<^ (\(_,_,x) -> x) <<^ fst
  54           where ik = M.keys iSig
  55           -- Old elements removed in nL are on the left, new elements added to
  56           -- nL are on the right.
  57                 diffSig :: [Int] -> [Int] -> Maybe ([Int],[Int])
  58                 diffSig oL nL
  59                   | oL == nL = Nothing
  60                   | otherwise = Just (oL \\ nL, nL \\ oL)
  61         routeBoard :: (Event AbsBeat,BoardRun,M.IntMap (Board,Layer))
  62                    -> M.IntMap sf
  63                    -> M.IntMap ((Event AbsBeat,Board,Layer,BoardRun),sf)
  64         routeBoard (evs,br,map) =
  65           M.intersectionWith (,) ((\(b,l) -> (evs,b,l,br)) <$> map)
  66
  67 boardRun :: (Tempo, BoardRun, M.IntMap (Board,Layer))
  68          -> SF (Tempo, BoardRun, M.IntMap (Board,Layer))
  69                (M.IntMap (Event ([PlayHead],[Note])))
  70 boardRun (_,_,iMap) = mkBeat >>> boardRun' (iMap $> boardSF)
  71   where mkBeat = proc (t,x,y) -> do
  72           e <- metronome -< t
  73           returnA -< (e,x,y)