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 :: [PlayHead]
  23             -> SF ((Board, Layer), Event BeatNo) (Event ([PlayHead], [Note]))
  24 boardAction ph = proc ((board, Layer { relPitch    = rp
  25                                      , strength    = s
  26                                      , beatsPerBar = bpb
  27                                      }), 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, Tempo) (Event [Note])
  33 boardSF = proc (board, l, t) -> do
  34   ebno <- layerMetronome -< (t, l)
  35   iph <- startHeads -< board
  36   boardSF' iph -< (board, l, ebno)
  37   where boardSF' :: [PlayHead] -> SF (Board, Layer, Event BeatNo) (Event [Note])
  38         boardSF' ph = switch (swap ^<< splitE ^<< boardAction ph)
  39                       boardSF'
  40 -}
  41
  42 -- We need the list of initial playheads
  43 boardSF :: [PlayHead] -> SF (Board, Layer, Tempo) (Event [Note])
  44 boardSF iph = proc (board, l@Layer { relPitch = rp
  45                                    , strength = s
  46                                    }, t) -> do
  47   ebno <- layerMetronome -< (t,l)
  48   boardSF' iph -< ((board, l), ebno)
  49   where
  50     boardSF' :: [PlayHead] -> SF ((Board, Layer), Event BeatNo) (Event [Note])
  51     boardSF' ph = dSwitch (boardAction ph >>> arr splitE >>> arr swap)
  52                   (\nph -> second notYet >>> boardSF' nph)
  53
  54
  55 {-
  56 boardSetup :: Board
  57            -> ReactiveFieldReadWrite IO Tempo
  58            -> ReactiveFieldReadWrite IO Layer
  59            -> ReactiveFieldReadWrite IO [Note]
  60            -> IO ()
  61 boardSetup board tempoRV layerRV outBoardRV = do
  62   layer <- reactiveValueRead layerRV
  63   tempo <- reactiveValueRead tempoRV
  64   (inBoard, outBoard) <- yampaReactiveDual (layer, tempo) (boardSF board)
  65   let inRV =  pairRW layerRV tempoRV
  66   clock <- mkClockRV 10
  67   inRV =:> inBoard
  68   clock ^:> inRV
  69   reactiveValueOnCanRead outBoard
  70     (reactiveValueRead outBoard >>= reactiveValueWrite outBoardRV . event [] id)
  71   putStrLn "Board started."
  72   n <- newEmptyMVar
  73   takeMVar n
  74   return ()
  75 -}