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.Layer.Layer
  12 import           RMCA.Semantics
  13
  14 data BoardRun = BoardStart | BoardStop deriving (Eq, Show)
  15
  16 singleBoard :: [PlayHead]
  17             -> SF (Board, Layer, Event BeatNo) (Event ([PlayHead], [Note]))
  18 singleBoard iPh = proc (board, Layer { relPitch = rp
  19                                      , strength = s
  20                                      }, ebno) ->
  21   accumBy advanceHeads' (iPh,[]) -< ebno `tag` (board, fromEvent ebno, rp, s)
  22   where advanceHeads' (ph,_) (board,bno,rp,s) = uncurry5 advanceHeads (board,bno,rp,s,ph)
  23
  24 boardSF :: SF (Board, Layer, Tempo, BoardRun)
  25               (Event ([PlayHead], [(LTempo,Note)]))
  26 boardSF = proc (board, l, t, br) -> do
  27   lt <- layerTempo -< (t,l)
  28   ebno <- layerMetronome -< (t,l)
  29   ess <- onChange -< br
  30   ephn <- boardSwitch [] -< ((board, l, ebno), ess `tag` (br, startHeads board))
  31   returnA -< fmap (second (zip (repeat lt))) ephn
  32
  33 boardSwitch :: [PlayHead]
  34             -> SF ((Board, Layer,Event BeatNo), Event (BoardRun, [PlayHead]))
  35                (Event ([PlayHead],[Note]))
  36 boardSwitch rPh = dSwitch (singleBoard rPh *** (identity >>> notYet)) fnSwitch
  37   where fnSwitch (BoardStart, iPh) = boardSwitch iPh
  38         fnSwitch (BoardStop, _) = boardSwitch []
  39
  40 --------------------------------------------------------------------------------
  41 -- Machinery to make parallel boards run
  42 --------------------------------------------------------------------------------
  43
  44 routeBoard :: M.IntMap a -> M.IntMap sf -> M.IntMap (a,sf)
  45 routeBoard = M.intersectionWith (,)
  46
  47 -- On the left are the disappearing signals, on the right the
  48 -- appearing one.
  49 lengthChange :: M.IntMap b -> SF (M.IntMap a, M.IntMap sf) (Event ([Int],[Int]))
  50 lengthChange iSig = edgeBy diffSig ik <<^ M.keys <<^ fst
  51   where ik = M.keys iSig
  52         -- Old elements removed in nL are on the left, new elements added to
  53         -- nL are on the right.
  54         diffSig :: [Int] -> [Int] -> Maybe ([Int],[Int])
  55         diffSig oL nL
  56           | oL == nL = Nothing
  57           | otherwise = Just (oL \\ nL, nL \\ oL)
  58
  59 boardRun' :: M.IntMap (SF (Board,Layer,Tempo,BoardRun)
  60                           (Event ([PlayHead],[(LTempo,Note)])))
  61           -> SF (M.IntMap (Board,Layer,Tempo,BoardRun))
  62                 (M.IntMap (Event ([PlayHead],[(LTempo,Note)])))
  63 boardRun' iSF = boardRun'' iSF (lengthChange iSF)
  64   where boardRun'' iSF swSF = pSwitch routeBoard iSF swSF contSwitch
  65         contSwitch contSig (oldSig, newSig) = boardRun'' newSF
  66                                               (lengthChange newSF >>> notYet)
  67           where newSF = foldr (\k m -> M.insert k boardSF m)
  68                         (foldr M.delete contSig oldSig) newSig
  69
  70 boardRun :: M.IntMap (Board,Layer,Tempo,BoardRun)
  71          -> SF (M.IntMap (Board,Layer,Tempo,BoardRun))
  72                (M.IntMap (Event ([PlayHead],[(LTempo,Note)])))
  73 boardRun iSig = boardRun' (iSig $> boardSF)