src/RMCA/Layer/Board.hs

   1 {-# LANGUAGE Arrows #-}
   2
   3 module RMCA.Layer.Board ( boardRun
   4                         , SwitchBoard (..)
   5                         ) where
   6
   7 import qualified Data.IntMap          as M
   8 import           Data.List            ((\\))
   9 import           FRP.Yampa
  10 import           RMCA.Global.Clock
  11 import           RMCA.Layer.LayerConf
  12 import           RMCA.Semantics
  13
  14 data SwitchBoard = StartBoard StaticLayerConf
  15                  | ContinueBoard
  16                  | StopBoard
  17
  18 updatePhOnSwitch :: Board -> [PlayHead] -> SwitchBoard -> [PlayHead]
  19 updatePhOnSwitch _ _ (StopBoard {}) = []
  20 updatePhOnSwitch board _ (StartBoard {}) = startHeads board
  21 updatePhOnSwitch board oldPhs (ContinueBoard {}) = oldPhs ++ startHeads board
  22 {-
  23 noStopBoard :: Event SwitchBoard -> Event SwitchBoard
  24 noStopBoard (Event (StopBoard {})) = NoEvent
  25 noStopBoard e = e
  26 -}
  27 {-
  28 genPlayHeads :: Board -> SwitchBoard -> [PlayHead]
  29 genPlayHeads _ (StopBoard {}) = []
  30 genPlayHeads board _ = startHeads board
  31 -}
  32 {-
  33 continueBoard :: Event SwitchBoard -> Event [PlayHead]
  34 continueBoard board (Event (ContinueBoard {})) = Event $ startHeads board
  35 continueBoard _ _ = NoEvent
  36 -}
  37 startBoard :: Event SwitchBoard -> Event StaticLayerConf
  38 startBoard (Event (StartBoard st)) = Event st
  39 startBoard _ = NoEvent
  40
  41 stopBoard :: Event SwitchBoard -> Event SwitchBoard
  42 stopBoard e@(Event StopBoard) = e
  43 stopBoard _ = NoEvent
  44
  45 -- singleboard is a simple running board. Given an initial list of
  46 -- play heads, it runs the board by the beat. It produces events but
  47 -- also a constant output of the states of the play heads to allow for
  48 -- adding them.
  49 singleBoard :: [PlayHead]
  50             -> SF (Board,DynLayerConf,Event BeatNo)
  51                   (Event [Note], [PlayHead])
  52 singleBoard iPh = proc (board, DynLayerConf { relPitch = rp
  53                                             , strength = s
  54                                             }, ebno) -> do
  55   (phs,notes) <- accumHoldBy advanceHeads' (iPh,[])
  56                  -< ebno `tag` (board, fromEvent ebno, rp, s)
  57   returnA -< (ebno `tag` notes, phs)
  58   where advanceHeads' (ph,_) (board,bno,rp,s) = advanceHeads board bno rp s ph
  59
  60 -- dynSingleBoard differs from singleBoard in that it receives a
  61 -- SwitchBoard event allowing it to start/stop the board.
  62 dynSingleBoard :: SF (Board, DynLayerConf, Event BeatNo, Event SwitchBoard)
  63                   (Event [Note], [PlayHead])
  64 dynSingleBoard = proc (board, dynConf, ebno, esb) -> do
  65   rec
  66     res@(_,curPhs) <- rSwitch $ singleBoard []
  67       -< ( (board, dynConf, ebno)
  68          , fmap (singleBoard . updatePhOnSwitch board curPhs') esb)
  69     curPhs' <- iPre [] -< curPhs
  70   returnA -< res
  71
  72 boardSF :: StaticLayerConf
  73         -> SF (Event AbsBeat, Board, DynLayerConf, Event SwitchBoard)
  74               (Event [Note], [PlayHead])
  75 boardSF (StaticLayerConf { beatsPerBar = bpb }) =
  76   proc (eabs, board, dynConf, esb) -> do
  77     ebno <- rSwitch never -< ( (eabs,dynConf)
  78                              , layerMetronome <$> startBoard esb)
  79     dynSingleBoard -< (board,dynConf,ebno,esb)
  80
  81 ----------------------------------------------------------------------------
  82 -- Machinery to make boards run in parallel
  83 ----------------------------------------------------------------------------
  84
  85 boardRun' :: M.IntMap (SF (Event AbsBeat,Board,DynLayerConf,Event SwitchBoard)
  86                           (Event [Note], [PlayHead]))
  87           -> SF (Event AbsBeat, M.IntMap (Board,DynLayerConf,Event SwitchBoard))
  88                 (M.IntMap (Event [Note], [PlayHead]))
  89 boardRun' iSF = boardRun'' iSF (lengthChange iSF)
  90   where boardRun'' iSF swSF = pSwitch routeBoard iSF swSF contSwitch
  91         contSwitch contSig (oldSig, newSig) = boardRun'' newSF
  92                                               (lengthChange newSF >>> notYet)
  93           where defaultBoardSF = boardSF defaultStaticLayerConf
  94                 newSF = foldr (\k m -> M.insert k defaultBoardSF m)
  95                         (foldr M.delete contSig oldSig) newSig
  96         lengthChange iSig = edgeBy diffSig ik <<^ M.keys <<^ (\(_,x) -> x) <<^ fst
  97           where ik = M.keys iSig
  98           -- Old elements removed in nL are on the left, new elements added to
  99           -- nL are on the right.
 100                 diffSig :: [Int] -> [Int] -> Maybe ([Int],[Int])
 101                 diffSig oL nL
 102                   | oL == nL = Nothing
 103                   | otherwise = Just (oL \\ nL, nL \\ oL)
 104         routeBoard :: (Event AbsBeat,M.IntMap (Board,DynLayerConf,Event SwitchBoard))
 105                    -> M.IntMap sf
 106                    -> M.IntMap ((Event AbsBeat,Board,DynLayerConf,Event SwitchBoard),sf)
 107         routeBoard (evs,map) sfs =
 108           M.intersectionWith (,) ((\(b,l,ebs) -> (evs,b,l,ebs)) <$> map) sfs
 109
 110 boardRun :: M.IntMap StaticLayerConf
 111          -> SF (Tempo, M.IntMap (Board,DynLayerConf,Event SwitchBoard))
 112                (M.IntMap (Event [Note], [PlayHead]))
 113 boardRun iMap = mkBeat >>> (boardRun' $ fmap boardSF iMap)
 114   where mkBeat = proc (t,map) -> do
 115           esb <- arr (foldr selEvent NoEvent) <<^ fmap (\(_,_,e) -> e) -< map
 116           eab <- rSwitch never -< (t, lMerge (stopBoard esb `tag` never)
 117                                       (startBoard esb `tag` metronome))
 118           returnA -< (eab,map)
 119         selEvent x NoEvent = x
 120         selEvent e@(Event (StopBoard {})) _ = e
 121         selEvent (Event (StartBoard {})) f@(Event (StopBoard {})) = f
 122         selEvent _ x = x