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
  16 -- The state of the board is described by the list of the playheads
  17 -- and the different actions onto the board.
  18 -- It can then be modified discretly when a beat is received or
  19 -- continuously when the user acts on it.
  20 boardAction :: Board
  21             -> SF (Layer, [PlayHead], Event BeatNo)
  22                   (Event ([PlayHead], [Note]))
  23 boardAction board = proc (Layer { relPitch    = rp
  24                                 , strength    = s
  25                                 , beatsPerBar = bpb
  26                                 }, pl, ebn) -> do
  27   ahSF <<^ arr propEvent -< (ebn, rp, s, pl)
  28   where
  29     ahSF :: SF (Event (BeatNo, RelPitch, Strength, [PlayHead]))
  30                (Event ([PlayHead], [Note]))
  31     ahSF = arr $ fmap (uncurry4 $ advanceHeads board)
  32     propEvent (a,b,c,d) = if isEvent a
  33                           then Event (fromEvent a,b,c,d)
  34                           else NoEvent
  35
  36 boardSF' :: Board
  37          -> [PlayHead]
  38          -> SF (Layer, Tempo) (Event ([PlayHead], [Note]))
  39 boardSF' board ph = proc (l, t) -> do
  40   (ebno, el) <- splitE ^<< layerMetronome -< (t, l)
  41   boardAction board -< (l, ph, ebno)
  42
  43 boardSF :: Board -> SF (Layer, Tempo) (Event [Note])
  44 boardSF board = boardSF'' board []
  45   where boardSF'' :: Board -> [PlayHead] -> SF (Layer, Tempo) (Event [Note])
  46         boardSF'' board ph = switch (splitE ^<< fmap swap ^<< boardSF' board ph)
  47                              (\nph -> boardSF'' board nph)
  48
  49 boardSetup :: Board
  50            -> ReactiveFieldReadWrite IO Tempo
  51            -> ReactiveFieldReadWrite IO Layer
  52            -> IO (ReactiveFieldRead IO [Note])
  53 boardSetup board tempoRV layerRV = do
  54   layer <- reactiveValueRead layerRV
  55   tempo <- reactiveValueRead tempoRV
  56   (inBoard, outBoard) <- yampaReactiveDual (layer, tempo) (boardSF board)
  57   boardRun board tempoRV layerRV inBoard outBoard
  58
  59 (^:>) :: (ReactiveValueRead a b m, ReactiveValueReadWrite c d m) =>
  60          a -> c -> m ()
  61 not ^:> rv = reactiveValueOnCanRead not resync
  62   where resync = reactiveValueRead rv >>= reactiveValueWrite rv
  63
  64 boardRun :: Board
  65          -> ReactiveFieldReadWrite IO Tempo
  66          -> ReactiveFieldReadWrite IO Layer
  67          -> ReactiveFieldWrite IO (Layer, Tempo)
  68          -> ReactiveFieldRead IO (Event [Note])
  69          -> IO (ReactiveFieldRead IO [Note])
  70 boardRun board tempoRV layerRV inBoard outBoard = do
  71   let inRV =  pairRW layerRV tempoRV
  72   clock <- mkClockRV 10
  73   inRV =:> inBoard
  74   clock ^:> inRV
  75   return $ liftR (event [] id) outBoard