RCMA/Layer/Board.hs

   1 {-# LANGUAGE Arrows, FlexibleContexts #-}
   2
   3 module RCMA.Layer.Board ( boardSF
   4                         , (^:>)
   5                         ) where
   6
   7 import Control.Concurrent
   8 import Control.Concurrent.MVar
   9 import Data.ReactiveValue
  10 import Data.Tuple
  11 import FRP.Yampa
  12 import Hails.Yampa
  13 import RCMA.Auxiliary.Curry
  14 import RCMA.Layer.Layer
  15 import RCMA.Semantics
  16 import RCMA.Global.Clock
  17 import Control.Monad
  18
  19 -- The state of the board is described by the list of the playheads
  20 -- and the different actions onto the board.
  21 -- It can then be modified discretly when a beat is received or
  22 -- continuously when the user acts on it.
  23 boardAction :: Board
  24             -> SF (Layer, [PlayHead], Event BeatNo)
  25                   (Event ([PlayHead], [Note]))
  26 boardAction board = proc (Layer { relPitch    = rp
  27                                 , strength    = s
  28                                 , beatsPerBar = bpb
  29                                 }, pl, ebn) ->
  30   ahSF <<^ arr propEvent -< (ebn, rp, s, pl)
  31   where
  32     ahSF :: SF (Event (BeatNo, RelPitch, Strength, [PlayHead]))
  33                (Event ([PlayHead], [Note]))
  34     ahSF = arr $ fmap (uncurry4 $ advanceHeads board)
  35     propEvent (a,b,c,d) = if isEvent a
  36                           then Event (fromEvent a,b,c,d)
  37                           else NoEvent
  38
  39 boardSF' :: Board
  40          -> [PlayHead]
  41          -> SF (Layer, Tempo) (Event ([PlayHead], [Note]))
  42 boardSF' board ph = proc (l, t) -> do
  43   (ebno, el) <- splitE ^<< layerMetronome -< (t, l)
  44   boardAction board -< (l, ph, ebno)
  45
  46 boardSF :: Board -> SF (Layer, Tempo) (Event [Note])
  47 boardSF board = boardSF'' board []
  48   where boardSF'' :: Board -> [PlayHead] -> SF (Layer, Tempo) (Event [Note])
  49         boardSF'' board ph = switch (splitE ^<< fmap swap ^<< boardSF' board ph)
  50                              (boardSF'' board)
  51
  52 boardSetup :: Board
  53            -> ReactiveFieldReadWrite IO Tempo
  54            -> ReactiveFieldReadWrite IO Layer
  55            -> ReactiveFieldReadWrite IO [Note]
  56            -> IO ()
  57 boardSetup board tempoRV layerRV outBoardRV = do
  58   layer <- reactiveValueRead layerRV
  59   tempo <- reactiveValueRead tempoRV
  60   (inBoard, outBoard) <- yampaReactiveDual (layer, tempo) (boardSF board)
  61   let inRV =  pairRW layerRV tempoRV
  62   clock <- mkClockRV 10
  63   inRV =:> inBoard
  64   clock ^:> inRV
  65   reactiveValueOnCanRead outBoard
  66     (reactiveValueRead outBoard >>= reactiveValueWrite outBoardRV . event [] id)
  67   putStrLn "Board started."
  68   n <- newEmptyMVar
  69   takeMVar n
  70   return ()
  71
  72 (^:>) :: (ReactiveValueRead a b m, ReactiveValueReadWrite c d m) =>
  73          a -> c -> m ()
  74 not ^:> rv = reactiveValueOnCanRead not resync
  75   where resync = reactiveValueRead rv >>= reactiveValueWrite rv