RCMA/Layer/Board.hs

   1 {-# LANGUAGE Arrows, FlexibleContexts #-}
   2
   3 module RCMA.Layer.Board where
   4
   5 import FRP.Yampa
   6 import RCMA.Layer.Layer
   7 import RCMA.Semantics
   8 import RCMA.Auxiliary.Curry
   9 import Data.ReactiveValue
  10 import Hails.Yampa
  11 import Data.Tuple
  12
  13 -- The state of the board is described by the list of the playheads
  14 -- and the different actions onto the board.
  15 -- It can then be modified discretly when a beat is received or
  16 -- continuously when the user acts on it.
  17 boardAction :: Board
  18             -> SF (Layer, [PlayHead], Event BeatNo)
  19                   (Event ([PlayHead], [Note]))
  20 boardAction board = proc (Layer { relPitch    = rp
  21                                 , strength    = s
  22                                 , beatsPerBar = bpb
  23                                 }, pl, ebn) -> do
  24   ahSF <<^ arr propEvent -< (ebn, rp, s, pl)
  25   where
  26     ahSF :: SF (Event (BeatNo, RelPitch, Strength, [PlayHead]))
  27                (Event ([PlayHead], [Note]))
  28     ahSF = arr $ fmap (uncurry4 $ advanceHeads board)
  29     propEvent (a,b,c,d) = if isEvent a
  30                           then Event (fromEvent a,b,c,d)
  31                           else NoEvent
  32
  33 boardSF :: Board -> SF (Layer, [PlayHead], Tempo) (Event ([PlayHead], [Note]))
  34 boardSF board = proc (l, ph, t) -> do
  35   (ebno, el) <- splitE ^<< layerMetronome -< (t, l)
  36   boardAction board -< (l, ph, ebno)
  37
  38 boardInit :: (ReactiveValueRead tempo Tempo IO,
  39               ReactiveValueRead ph [PlayHead] IO) =>
  40              Board
  41           -> tempo
  42           -> ph
  43           -> ReactiveFieldReadWrite IO Layer
  44           -> IO ()
  45 boardInit board tempoRV phRV layerRV = do
  46   layer <- reactiveValueRead layerRV
  47   tempo <- reactiveValueRead tempoRV
  48   ph  <- reactiveValueRead phRV
  49   (inBoard, outBoard) <- yampaReactiveDual (layer, ph, tempo) (boardSF board)
  50   return ()
  51 {-
  52 boardRun :: (ReactiveValueRead tempo Tempo IO,
  53              ReactiveValueRead ph [PlayHead] IO) =>
  54             Board
  55          -> tempo
  56          -> ph
  57          -> ReactiveFieldReadWrite IO Layer
  58          -> IO ()
  59 boardRun board tempoRV phRV layerRV = do
  60   layer <- reactiveValueRead layerRV
  61   tempo <- reactiveValueRead tempoRV
  62   ph  <- reactiveValueRead phRV
  63   (inBoard, outBoard) <- yampaReactiveDual (layer, tempo, ph)  (boardAction board)
  64
  65   return ()
  66 -}