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