src/RMCA/Layer/Board.hs

   1 {-# LANGUAGE Arrows, TupleSections #-}
   2
   3 module RMCA.Layer.Board where
   4
   5 import qualified Data.IntMap          as M
   6 import           Data.List            ((\\))
   7 import           FRP.Yampa
   8 import           RMCA.Auxiliary
   9 import           RMCA.Global.Clock
  10 import           RMCA.Layer.LayerConf
  11 import           RMCA.Semantics
  12
  13 data RunStatus = Running | Stopped deriving(Show, Eq)
  14
  15 layerMetronome :: StaticLayerConf
  16                -> SF (Event AbsBeat, DynLayerConf) (Event BeatNo)
  17 layerMetronome StaticLayerConf { beatsPerBar = bpb
  18                                } =
  19   proc (eb, DynLayerConf { layerBeat = r
  20                          }) -> do
  21     ewbno <- accumFilter (\_ (ab,r) -> ((),selectBeat (ab,r))) () -< (,r) <$> eb
  22     accumBy (flip nextBeatNo) 0 -< ewbno `tag` bpb
  23       where selectBeat (absBeat, layBeat) =
  24               maybeIf ((absBeat - 1) `mod`
  25                         floor (fromIntegral maxAbsBeat * layBeat) == 0)
  26
  27 automaton :: [PlayHead]
  28           -> SF (Board, DynLayerConf, Event BeatNo)
  29                 (Event [Note], [PlayHead])
  30 automaton iphs = proc (b, DynLayerConf { relPitch = rp
  31                                        , strength = s
  32                                        }, ebno) -> do
  33   enphs     <- accumBy advanceHeads' (iphs,[])
  34                           -< ebno `tag` (b, fromEvent ebno, rp, s)
  35   (ephs,en) <- arr splitE -< enphs
  36   phs       <- hold iphs  -< ephs
  37   returnA                 -< (en, phs)
  38   where advanceHeads' (ph,_) (board,bno,rp,s) = advanceHeads board bno rp s ph
  39
  40
  41 layer :: SF (Event AbsBeat, Board, LayerConf, Event RunStatus)
  42             (Event [Note], [PlayHead])
  43 layer = layerStopped
  44   where switchStatus (rs, slc, iphs) = case rs of
  45           Stopped -> layerStopped
  46           Running -> layerRunning slc iphs
  47
  48         layerStopped = switch lsAux switchStatus
  49
  50         layerRunning slc iphs = switch (lrAux slc iphs) switchStatus
  51
  52         lsAux = proc (_, b, (slc,_,_), ers) -> do
  53           en  <- never       -< ()
  54           phs <- constant [] -< ()
  55           e   <- notYet      -< fmap (\rs -> (rs, slc, startHeads b)) ers
  56           returnA            -< ((en,phs),e)
  57
  58         lrAux slc iphs = proc (eab, b, (slc',dlc,_), ers) -> do
  59           ebno  <- layerMetronome slc -< (eab, dlc)
  60           enphs@(_,phs) <- automaton iphs -< (b, dlc, ebno)
  61           r <- (case repeatCount slc of
  62                   Nothing -> never
  63                   Just n -> countTo (1 + n * beatsPerBar slc)) -< ebno
  64           erun <- waitForEvent -< (filterE (== Running) ers,ebno)
  65           estop <- arr $ filterE (/= Running) -< ers
  66           let ers' = erun `lMerge` estop
  67               ers'' = ers' `lMerge` (r `tag` Running)
  68           ophs <- iPre iphs -< phs
  69           let ophs' = if keepHeads dlc then ophs else []
  70           e <- notYet -< fmap (\rs -> (rs, slc', ophs' ++ startHeads b)) ers''
  71           returnA -< (enphs,e)
  72
  73 layers :: M.IntMap a
  74        -> SF (Tempo, Event RunStatus,
  75               M.IntMap (Board,LayerConf,Event RunStatus))
  76              (M.IntMap (Event [Note], [PlayHead]))
  77 layers imap = proc (t,erun,map) -> do
  78   elc <- edgeBy diffSig (M.keys imap) -< M.keys map
  79   let e = fmap switchCol elc
  80       newMetronome Running = metronome
  81       newMetronome Stopped = never
  82   erun' <- accumFilter (\oRS nRS ->
  83                           case (oRS,nRS) of
  84                             (Stopped,_) -> (nRS,Just nRS)
  85                             (Running, Stopped) -> (Stopped,Just Stopped)
  86                             _ -> (oRS,Nothing)) Stopped -< erun
  87   eabs <- rSwitch metronome -< (t, newMetronome <$> erun')
  88   rpSwitch routing (imap $> layer) -< ((eabs,erun,map),e)
  89   where routing (eabs,erun,map) sfs = M.intersectionWith (,)
  90           (fmap (\(b,l,er) -> (eabs,b,l,erun `lMerge` er)) map) sfs
  91
  92         diffSig :: [Int] -> [Int] -> Maybe ([Int],[Int])
  93         diffSig oL nL
  94           | oL == nL = Nothing
  95           | otherwise = Just (oL \\ nL, nL \\ oL)
  96
  97         switchCol (oldSig,newSig) col =
  98           foldr (\k m -> M.insert k layer m)
  99           (foldr M.delete col oldSig) newSig