RMCA/Layer/Board.hs

   1 {-# LANGUAGE Arrows, FlexibleContexts #-}
   2
   3 module RMCA.Layer.Board ( boardSF
   4                         ) where
   5
   6 import Control.Concurrent
   7 import Control.Concurrent.MVar
   8 import Control.Monad
   9 import Data.ReactiveValue
  10 import Data.Tuple
  11 import FRP.Yampa
  12 import Hails.Yampa
  13 import RMCA.Auxiliary.Curry
  14 import RMCA.Global.Clock
  15 import RMCA.Layer.Layer
  16 import RMCA.Semantics
  17
  18 import Debug.Trace
  19
  20 -- The state of the board is described by the list of the playheads
  21 -- and the different actions onto the board.
  22 boardAction :: SF ((Board, Layer, [PlayHead]), Event BeatNo) (Event ([PlayHead], [Note]))
  23 boardAction = proc ((board, Layer { relPitch    = rp
  24                                   , strength    = s
  25                                   , beatsPerBar = bpb
  26                                   },ph), ebno) ->
  27   arr $ fmap (uncurry5 advanceHeads)
  28   -< ebno `tag` (board, fromEvent ebno, rp, s, ph)
  29   --returnA -< traceShow e e
  30
  31 boardSF :: SF (Board, Layer, [PlayHead], Tempo) (Event ([PlayHead], [Note]))
  32 boardSF = proc (board, l, ph, t) -> do
  33   ebno <- layerMetronome -< (t, l)
  34   boardAction -< ((board, l, ph), ebno)
  35
  36 {-
  37 -- We need the list of initial playheads
  38 boardSF :: [PlayHead] -> SF (Board, Layer, Tempo) (Event [Note])
  39 boardSF iph = proc (board, l@Layer { relPitch = rp
  40                                    , strength = s
  41                                    }, t) -> do
  42   ebno <- layerMetronome -< (t,l)
  43   boardSF' iph -< ((board, l), ebno)
  44   where
  45     boardSF' :: [PlayHead] -> SF ((Board, Layer), Event BeatNo) (Event [Note])
  46     boardSF' ph = dSwitch (boardAction ph >>> arr splitE >>> arr swap)
  47                   (\nph -> second notYet >>> boardSF' nph)
  48
  49
  50 {-
  51 boardSetup :: Board
  52            -> ReactiveFieldReadWrite IO Tempo
  53            -> ReactiveFieldReadWrite IO Layer
  54            -> ReactiveFieldReadWrite IO [Note]
  55            -> IO ()
  56 boardSetup board tempoRV layerRV outBoardRV = do
  57   layer <- reactiveValueRead layerRV
  58   tempo <- reactiveValueRead tempoRV
  59   (inBoard, outBoard) <- yampaReactiveDual (layer, tempo) (boardSF board)
  60   let inRV =  pairRW layerRV tempoRV
  61   clock <- mkClockRV 10
  62   inRV =:> inBoard
  63   clock ^:> inRV
  64   reactiveValueOnCanRead outBoard
  65     (reactiveValueRead outBoard >>= reactiveValueWrite outBoardRV . event [] id)
  66   putStrLn "Board started."
  67   n <- newEmptyMVar
  68   takeMVar n
  69   return ()
  70 -}
  71 -}