]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Global/Clock.hs
Deleted 'Unknown' directory.
[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.Auxiliary
9 import RMCA.Semantics
10
11 tempo :: Tempo -> SF () Tempo
12 tempo = constant
13
14 -- The initial value is arbitrary but never appears because the switch
15 -- is immediate.
16 metronome :: SF Tempo (Event Beat)
17 metronome = switch (repeatedly (tempoToQNoteIvl 120) ()
18 &&&
19 onChange') metronome'
20 where metronome' :: Tempo -> SF Tempo (Event Beat)
21 metronome' t = switch (repeatedly (tempoToQNoteIvl t) ()
22 &&&
23 onChange) metronome'
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