]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Global/Clock.hs
Add MCBMVar
[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 {-
12 -- The initial value is arbitrary but never appears because the switch
13 -- is immediate.
14 metronome :: SF Tempo (Event Beat)
15 metronome = switch (repeatedly (tempoToQNoteIvl 120) ()
16 &&&
17 onChange') metronome'
18 where metronome' :: Tempo -> SF Tempo (Event Beat)
19 metronome' t = switch (repeatedly (tempoToQNoteIvl t) ()
20 &&&
21 onChange) metronome'
22 -}
23 metronome :: SF Tempo (Event Beat)
24 metronome = repeatedlyS () <<^ tempoToQNoteIvl
25
26 -- Tempo is the number of quarter notes per minute.
27 tempoToQNoteIvl :: Tempo -> DTime
28 tempoToQNoteIvl = (15/) . fromIntegral
29
30 type TickingClock = (CBMVar (), ThreadId)
31
32 -- Make a clock that will execute any IO when it updates.
33 mkClockGeneric :: IO () -> DTime -> IO TickingClock
34 mkClockGeneric io d = do
35 n <- newCBMVar ()
36 tid <- forkIO $ forever $ do
37 threadDelay dInt
38 modifyCBMVar n return
39 io
40 return (n, tid)
41 where dInt = floor $ d * 1000
42
43 -- Ticking clock in the IO monad, sending callbacks every t milliseconds.
44 mkClock :: DTime -> IO TickingClock
45 mkClock = mkClockGeneric (return ())
46
47 -- For debugging purposes.
48 mkClockDebug :: DTime -> IO TickingClock
49 mkClockDebug = mkClockGeneric (putStrLn "Ping !")
50
51 clockRV :: TickingClock -> ReactiveFieldRead IO ThreadId
52 clockRV (mvar, tid) = ReactiveFieldRead (return tid)
53 (installCallbackCBMVar mvar)
54
55 mkClockRV :: DTime -> IO (ReactiveFieldRead IO ThreadId)
56 mkClockRV d = clockRV <$> mkClock d
57
58 stopClock :: TickingClock -> IO ()
59 stopClock (_,t) = killThread t