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