src/RMCA/Layer/Board.hs

   1 {-# LANGUAGE Arrows, FlexibleContexts #-}
   2
   3 module RMCA.Layer.Board ( boardSF
   4                         ) where
   5
   6 import FRP.Yampa
   7 import RMCA.Auxiliary.Curry
   8 import RMCA.Layer.Layer
   9 import RMCA.Semantics
  10
  11 -- The state of the board is described by the list of the playheads
  12 -- and the different actions onto the board.
  13 boardAction :: SF ((Board, Layer, [PlayHead]), Event BeatNo)
  14                (Event ([PlayHead], [Note]))
  15 boardAction = proc ((board, Layer { relPitch    = rp
  16                                   , strength    = s
  17                                   },ph), ebno) ->
  18   arr $ fmap (uncurry5 advanceHeads)
  19   -< ebno `tag` (board, fromEvent ebno, rp, s, ph)
  20   --returnA -< traceShow e e
  21
  22 boardSF :: SF (Board, Layer, [PlayHead], Tempo) (Event ([PlayHead], [Note]))
  23 boardSF = proc (board, l, ph, t) -> do
  24   ebno <- layerMetronome -< (t, l)
  25   boardAction -< ((board, l, ph), ebno)
  26
  27 {-
  28 -- We need the list of initial playheads
  29 boardSF :: [PlayHead] -> SF (Board, Layer, Tempo) (Event [Note])
  30 boardSF iph = proc (board, l@Layer { relPitch = rp
  31                                    , strength = s
  32                                    }, t) -> do
  33   ebno <- layerMetronome -< (t,l)
  34   boardSF' iph -< ((board, l), ebno)
  35   where
  36     boardSF' :: [PlayHead] -> SF ((Board, Layer), Event BeatNo) (Event [Note])
  37     boardSF' ph = dSwitch (boardAction ph >>> arr splitE >>> arr swap)
  38                   (\nph -> second notYet >>> boardSF' nph)
  39
  40
  41 {-
  42 boardSetup :: Board
  43            -> ReactiveFieldReadWrite IO Tempo
  44            -> ReactiveFieldReadWrite IO Layer
  45            -> ReactiveFieldReadWrite IO [Note]
  46            -> IO ()
  47 boardSetup board tempoRV layerRV outBoardRV = do
  48   layer <- reactiveValueRead layerRV
  49   tempo <- reactiveValueRead tempoRV
  50   (inBoard, outBoard) <- yampaReactiveDual (layer, tempo) (boardSF board)
  51   let inRV =  pairRW layerRV tempoRV
  52   clock <- mkClockRV 10
  53   inRV =:> inBoard
  54   clock ^:> inRV
  55   reactiveValueOnCanRead outBoard
  56     (reactiveValueRead outBoard >>= reactiveValueWrite outBoardRV . event [] id)
  57   putStrLn "Board started."
  58   n <- newEmptyMVar
  59   takeMVar n
  60   return ()
  61 -}
  62 -}