]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Global/Clock.hs
Refactored parallel boards.
[tmp/julm/arpeggigon.git] / src / RMCA / Global / Clock.hs
1 module RMCA.Global.Clock where
2
3 import Control.Concurrent
4 import Control.Monad
5 import Data.CBMVar
6 import Data.ReactiveValue
7 import FRP.Yampa
8 import RMCA.Auxiliary
9 import RMCA.Semantics
10
11 -- The absolute beat is the beat number of the global clock, there are
12 -- 16 starting from 1.
13 type AbsBeat = BeatNo
14
15 maxAbsBeat :: AbsBeat
16 maxAbsBeat = 16
17
18 -- The global system tempo beats every 16th note, each beat is tagged
19 -- with a beat number modulo sixteen. Each layer is then beating at
20 -- its own fraction, discarding the unecessary beats.
21 metronome :: SF Tempo (Event AbsBeat)
22 metronome = accumBy (\pb _ -> nextBeatNo maxAbsBeat pb) 1 <<<
23 repeatedlyS () <<^ (/4) <<^ tempoToQNoteIvl
24
25 -- Tempo is the number of quarter notes per minute.
26 tempoToQNoteIvl :: Tempo -> DTime
27 tempoToQNoteIvl = (15/) . fromIntegral
28
29 type TickingClock = (CBMVar (), ThreadId)
30
31 -- Make a clock that will execute any IO when it updates.
32 mkClockGeneric :: IO () -> DTime -> IO TickingClock
33 mkClockGeneric io d = do
34 n <- newCBMVar ()
35 tid <- forkIO $ forever $ do
36 threadDelay dInt
37 modifyCBMVar n return
38 io
39 return (n, tid)
40 where dInt = floor $ d * 1000
41
42 -- Ticking clock in the IO monad, sending callbacks every t milliseconds.
43 mkClock :: DTime -> IO TickingClock
44 mkClock = mkClockGeneric (return ())
45
46 -- For debugging purposes.
47 mkClockDebug :: DTime -> IO TickingClock
48 mkClockDebug = mkClockGeneric (putStrLn "Ping !")
49
50 clockRV :: TickingClock -> ReactiveFieldRead IO ThreadId
51 clockRV (mvar, tid) = ReactiveFieldRead (return tid)
52 (installCallbackCBMVar mvar)
53
54 mkClockRV :: DTime -> IO (ReactiveFieldRead IO ThreadId)
55 mkClockRV d = clockRV <$> mkClock d
56
57 stopClock :: TickingClock -> IO ()
58 stopClock (_,t) = killThread t