]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - RMCA/Layer/Layer.hs
Playheads and notes are correct.
[tmp/julm/arpeggigon.git] / 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 }