RMCA/Layer/Board.hs

   1 {-# LANGUAGE Arrows, FlexibleContexts #-}
   2
   3 module RMCA.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 RMCA.Auxiliary.Curry
  14 import RMCA.Layer.Layer
  15 import RMCA.Semantics
  16 import RMCA.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 boardAction :: [PlayHead]
  24             -> SF ((Board, Layer), Event BeatNo) (Event ([PlayHead], [Note]))
  25 boardAction ph = proc ((board, Layer { relPitch    = rp
  26                                      , strength    = s
  27                                      , beatsPerBar = bpb
  28                                      }), ebno) -> do
  29   arr $ fmap (uncurry5 $ advanceHeads)
  30        -< ebno `tag` (board, fromEvent ebno, rp, s, ph)
  31   --returnA -< traceShow e e
  32 {-
  33 boardSF :: SF (Board, Layer, Tempo) (Event [Note])
  34 boardSF = proc (board, l, t) -> do
  35   ebno <- layerMetronome -< (t, l)
  36   iph <- startHeads -< board
  37   boardSF' iph -< (board, l, ebno)
  38   where boardSF' :: [PlayHead] -> SF (Board, Layer, Event BeatNo) (Event [Note])
  39         boardSF' ph = switch (swap ^<< splitE ^<< boardAction ph)
  40                       boardSF'
  41 -}
  42
  43 -- We need the list of initial playheads
  44 boardSF :: [PlayHead] -> SF (Board, Layer, Tempo) (Event [Note])
  45 boardSF iph = proc (board, l@Layer { relPitch = rp
  46                                    , strength = s
  47                                    }, t) -> do
  48   ebno <- layerMetronome -< (t,l)
  49   boardSF' iph -< ((board, l), ebno)
  50   where
  51     boardSF' :: [PlayHead] -> SF ((Board, Layer), Event BeatNo) (Event [Note])
  52     boardSF' ph = dSwitch (boardAction ph >>> arr splitE >>> arr swap)
  53                   (\nph -> second notYet >>> boardSF' nph)
  54
  55
  56 {-
  57 boardSetup :: Board
  58            -> ReactiveFieldReadWrite IO Tempo
  59            -> ReactiveFieldReadWrite IO Layer
  60            -> ReactiveFieldReadWrite IO [Note]
  61            -> IO ()
  62 boardSetup board tempoRV layerRV outBoardRV = do
  63   layer <- reactiveValueRead layerRV
  64   tempo <- reactiveValueRead tempoRV
  65   (inBoard, outBoard) <- yampaReactiveDual (layer, tempo) (boardSF board)
  66   let inRV =  pairRW layerRV tempoRV
  67   clock <- mkClockRV 10
  68   inRV =:> inBoard
  69   clock ^:> inRV
  70   reactiveValueOnCanRead outBoard
  71     (reactiveValueRead outBoard >>= reactiveValueWrite outBoardRV . event [] id)
  72   putStrLn "Board started."
  73   n <- newEmptyMVar
  74   takeMVar n
  75   return ()
  76 -}
  77 (^:>) :: (ReactiveValueRead a b m, ReactiveValueReadWrite c d m) =>
  78          a -> c -> m ()
  79 not ^:> rv = reactiveValueOnCanRead not resync
  80   where resync = reactiveValueRead rv >>= reactiveValueWrite rv