RMCA/Layer/Layer.hs

   1 {-# LANGUAGE Arrows #-}
   2
   3 module RMCA.Layer.Layer where
   4
   5 import Data.CBMVar
   6 import Data.ReactiveValue
   7 import FRP.Yampa
   8 import RMCA.Global.Clock
   9 import RMCA.Semantics
  10
  11 import Debug.Trace
  12
  13 -- Data representing the state of a layer. It is updated continuously.
  14 data Layer = Layer { relTempo    :: Double
  15                    , relPitch    :: RelPitch
  16                    , strength    :: Strength
  17                    , beatsPerBar :: BeatsPerBar
  18                    } deriving (Show)
  19
  20 layerTempo :: SF (Tempo, Layer) LTempo
  21 layerTempo = proc (t, Layer { relTempo = r }) ->
  22   returnA -< floor $ r * fromIntegral t
  23
  24 -- The layer is modified after the beat as been
  25 layerMetronome' :: BeatNo -> SF (Tempo, Layer) (Event BeatNo)
  26 layerMetronome' b = proc (t, l@Layer { beatsPerBar = bpb }) -> do
  27   eb <- metronome <<< layerTempo -< (t, l)
  28   returnA -< eb `tag` nextBeatNo bpb b
  29
  30 layerMetronome :: SF (Tempo, Layer) (Event BeatNo)
  31 layerMetronome = layerMetronome'' 0
  32   where layerMetronome'' no = dSwitch (layerMetronome' no >>^ dup)
  33                               layerMetronome''
  34
  35 layerRV :: CBMVar Layer -> ReactiveFieldReadWrite IO Layer
  36 layerRV mvar = ReactiveFieldReadWrite setter getter notifier
  37   where setter :: Layer ->  IO ()
  38         setter = writeCBMVar mvar
  39
  40         getter :: IO Layer
  41         getter = readCBMVar mvar
  42
  43         notifier :: IO () -> IO ()
  44         notifier = installCallbackCBMVar mvar
  45
  46 getDefaultLayerRV :: IO (ReactiveFieldReadWrite IO Layer)
  47 getDefaultLayerRV = layerRV <$> newCBMVar dl
  48   where dl = Layer { relTempo = 1
  49                    , relPitch = 0
  50                    , strength = 1
  51                    , beatsPerBar = 4
  52                    }