src/RMCA/Layer/Board.hs

   1 {-# LANGUAGE Arrows #-}
   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 import           Debug.Trace
  14
  15 data RunStatus = Running | Stopped
  16
  17 automaton :: [PlayHead]
  18           -> SF (Board, DynLayerConf, Event BeatNo)
  19                 (Event [Note], [PlayHead])
  20 automaton iphs = proc (b, DynLayerConf { relPitch = rp
  21                                        , strength = s
  22                                        }, ebno) -> do
  23   enphs     <- accumBy advanceHeads' (iphs,[])
  24                           -< ebno `tag` (b, fromEvent ebno, rp, s)
  25   (ephs,en) <- arr splitE -< enphs
  26   phs       <- hold iphs  -< ephs
  27   returnA                 -< (en, phs)
  28   where advanceHeads' (ph,_) (board,bno,rp,s) = advanceHeads board bno rp s ph
  29
  30
  31 layer :: SF (Event AbsBeat, Board, LayerConf, Event RunStatus)
  32             (Event [Note], [PlayHead])
  33 layer = layerStopped
  34   where switchStatus (rs, slc, iphs) = case rs of
  35           Stopped -> layerStopped
  36           Running -> layerRunning slc iphs
  37
  38         layerStopped = switch lsAux switchStatus
  39
  40         layerRunning slc iphs = switch (lrAux slc iphs) switchStatus
  41
  42         lsAux = proc (_, b, (slc,_,_), ers) -> do
  43           en  <- never       -< ()
  44           phs <- constant [] -< ()
  45           e   <- notYet      -< fmap (\rs -> (rs, slc, startHeads b)) ers
  46           returnA            -< ((en,phs),e)
  47
  48         lrAux slc iphs = proc (eab, b, (slc',dlc,_), ers) -> do
  49           ebno  <- layerMetronome slc -< (eab, dlc)
  50           enphs@(_,phs) <- automaton iphs -< (b, dlc, ebno)
  51           r <- (case let a = repeatCount slc in traceShow a a of
  52                   Nothing -> never
  53                   Just n -> countTo (n * beatsPerBar slc)) -< ebno
  54           let ers' = ers `lMerge` (r `tag` Running)
  55           e <- notYet -< fmap (\rs -> (rs, slc', phs ++ startHeads b)) ers'
  56           returnA -< (enphs,e)
  57
  58 layers :: M.IntMap a
  59        -> SF (Tempo, Event RunStatus,
  60               M.IntMap (Board,LayerConf,Event RunStatus))
  61              (M.IntMap (Event [Note], [PlayHead]))
  62 layers imap = proc (t,erun,map) -> do
  63   elc <- edgeBy diffSig (M.keys imap) -< M.keys map
  64   let e = fmap switchCol elc
  65       newMetronome Running = metronome
  66       newMetronome Stopped = never
  67   eabs <- rSwitch metronome -< (t, newMetronome <$> erun)
  68   rpSwitch routing (imap $> layer) -< ((eabs,erun,map),e)
  69   where routing (eabs,erun,map) sfs = M.intersectionWith (,)
  70           (fmap (\(b,l,er) -> (eabs,b,l,erun `lMerge` er)) map) sfs
  71
  72         diffSig :: [Int] -> [Int] -> Maybe ([Int],[Int])
  73         diffSig oL nL
  74           | oL == nL = Nothing
  75           | otherwise = Just (oL \\ nL, nL \\ oL)
  76
  77         switchCol (oldSig,newSig) col =
  78           foldr (\k m -> M.insert k layer m)
  79           (foldr M.delete col oldSig) newSig