RCMA/Layer/Board.hs

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