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 StaticLayerConf
  86          -> SF (Tempo, Event SwitchBoard, M.IntMap (Board,DynLayerConf))
  87                (M.IntMap (Event [Note], [PlayHead]))
  88 boardRun iMap = undefined
  89   where routing :: ( Event AbsBeat, Event SwitchBoard
  90                    , M.IntMap (Board, DynLayerConf))
  91                 -> M.IntMap sf
  92                 -> M.IntMap
  93                 ((Event AbsBeat, Board, DynLayerConf, Event SwitchBoard),sf)
  94         routing (eb,es,mSig) sfs = M.unionWith (,)
  95           (fmap (\(board,layer) -> (eb,board,layer,es)) mSig)
  96           sfs
  97 -}
  98
  99 boardRun' :: M.IntMap (SF (Event AbsBeat,Board,DynLayerConf,Event SwitchBoard)
 100                           (Event [Note], [PlayHead]))
 101           -> SF (Event AbsBeat, M.IntMap (Board,DynLayerConf,Event SwitchBoard))
 102                 (M.IntMap (Event [Note], [PlayHead]))
 103 boardRun' iSF = boardRun'' iSF (lengthChange iSF)
 104   where boardRun'' iSF swSF = pSwitch routeBoard iSF swSF contSwitch
 105         contSwitch contSig (oldSig, newSig) = boardRun'' newSF
 106                                               (lengthChange newSF >>> notYet)
 107           where defaultBoardSF = boardSF defaultStaticLayerConf
 108                 newSF = foldr (\k m -> M.insert k defaultBoardSF m)
 109                         (foldr M.delete contSig oldSig) newSig
 110         lengthChange iSig = edgeBy diffSig ik <<^ M.keys <<^ (\(_,x) -> x) <<^ fst
 111           where ik = M.keys iSig
 112           -- Old elements removed in nL are on the left, new elements added to
 113           -- nL are on the right.
 114                 diffSig :: [Int] -> [Int] -> Maybe ([Int],[Int])
 115                 diffSig oL nL
 116                   | oL == nL = Nothing
 117                   | otherwise = Just (oL \\ nL, nL \\ oL)
 118         routeBoard :: (Event AbsBeat,M.IntMap (Board,DynLayerConf,Event SwitchBoard))
 119                    -> M.IntMap sf
 120                    -> M.IntMap ((Event AbsBeat,Board,DynLayerConf,Event SwitchBoard),sf)
 121         routeBoard (evs,map) sfs =
 122           M.intersectionWith (,) ((\(b,l,ebs) -> (evs,b,l,ebs)) <$> map) sfs
 123
 124 boardRun :: M.IntMap StaticLayerConf
 125          -> SF (Tempo, M.IntMap (Board,DynLayerConf,Event SwitchBoard))
 126                (M.IntMap (Event [Note], [PlayHead]))
 127 boardRun iMap = mkBeat >>> (boardRun' $ fmap boardSF iMap)
 128   where mkBeat = proc (t,map) -> do
 129           esb <- arr (foldr selEvent NoEvent) <<^ fmap (\(_,_,e) -> e) -< map
 130           eab <- rSwitch never -< (t, lMerge (stopBoard esb `tag` never)
 131                                       (startBoard esb `tag` metronome))
 132           returnA -< (eab,map)
 133         selEvent x NoEvent = x
 134         selEvent e@(Event (StopBoard {})) _ = e
 135         selEvent (Event (StartBoard {})) f@(Event (StopBoard {})) = f
 136         selEvent _ x = x