src/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)
  23                (Event ([PlayHead], [Note]))
  24 boardAction = proc ((board, Layer { relPitch    = rp
  25                                   , strength    = s
  26                                   , beatsPerBar = bpb
  27                                   },ph), ebno) ->
  28   arr $ fmap (uncurry5 advanceHeads)
  29   -< ebno `tag` (board, fromEvent ebno, rp, s, ph)
  30   --returnA -< traceShow e e
  31
  32 boardSF :: SF (Board, Layer, [PlayHead], Tempo) (Event ([PlayHead], [Note]))
  33 boardSF = proc (board, l, ph, t) -> do
  34   ebno <- layerMetronome -< (t, l)
  35   boardAction -< ((board, l, ph), ebno)
  36
  37 {-
  38 -- We need the list of initial playheads
  39 boardSF :: [PlayHead] -> SF (Board, Layer, Tempo) (Event [Note])
  40 boardSF iph = proc (board, l@Layer { relPitch = rp
  41                                    , strength = s
  42                                    }, t) -> do
  43   ebno <- layerMetronome -< (t,l)
  44   boardSF' iph -< ((board, l), ebno)
  45   where
  46     boardSF' :: [PlayHead] -> SF ((Board, Layer), Event BeatNo) (Event [Note])
  47     boardSF' ph = dSwitch (boardAction ph >>> arr splitE >>> arr swap)
  48                   (\nph -> second notYet >>> boardSF' nph)
  49
  50
  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 -}