RCMA/Layer/Board.hs

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