src/RMCA/Layer/Board.hs

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