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   e <- 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   --iph <- arr startHeads -< board
  50   boardSF' iph -< ((board, l), ebno)
  51   where
  52     boardSF' :: [PlayHead] -> SF ((Board, Layer), Event BeatNo) (Event [Note])
  53     boardSF' ph = switch (boardAction ph >>> arr splitE >>> arr swap)
  54                   (\nph -> second notYet >>> boardSF' nph)
  55
  56
  57 {-
  58 boardSetup :: Board
  59            -> ReactiveFieldReadWrite IO Tempo
  60            -> ReactiveFieldReadWrite IO Layer
  61            -> ReactiveFieldReadWrite IO [Note]
  62            -> IO ()
  63 boardSetup board tempoRV layerRV outBoardRV = do
  64   layer <- reactiveValueRead layerRV
  65   tempo <- reactiveValueRead tempoRV
  66   (inBoard, outBoard) <- yampaReactiveDual (layer, tempo) (boardSF board)
  67   let inRV =  pairRW layerRV tempoRV
  68   clock <- mkClockRV 10
  69   inRV =:> inBoard
  70   clock ^:> inRV
  71   reactiveValueOnCanRead outBoard
  72     (reactiveValueRead outBoard >>= reactiveValueWrite outBoardRV . event [] id)
  73   putStrLn "Board started."
  74   n <- newEmptyMVar
  75   takeMVar n
  76   return ()
  77 -}
  78 (^:>) :: (ReactiveValueRead a b m, ReactiveValueReadWrite c d m) =>
  79          a -> c -> m ()
  80 not ^:> rv = reactiveValueOnCanRead not resync
  81   where resync = reactiveValueRead rv >>= reactiveValueWrite rv