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) -< 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 boardSF :: SF (Board, Layer, Tempo) (Event [Note])
  43 boardSF = proc (board, l@Layer { relPitch = rp
  44                                , strength = s
  45                                }, t) -> do
  46   ebno <- layerMetronome -< (t,l)
  47   --iph <- arr startHeads -< board
  48   boardSF' [] -< ((board, l), ebno)
  49   where
  50     boardSF' :: [PlayHead] -> SF ((Board, Layer), Event BeatNo) (Event [Note])
  51     boardSF' ph = switch (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 -}
  76 (^:>) :: (ReactiveValueRead a b m, ReactiveValueReadWrite c d m) =>
  77          a -> c -> m ()
  78 not ^:> rv = reactiveValueOnCanRead not resync
  79   where resync = reactiveValueRead rv >>= reactiveValueWrite rv