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