RCMA/Layer/Board.hs

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