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 metronome :: SF Tempo (Event Beat)
  12 metronome = repeatedlyS () <<^ tempoToQNoteIvl
  13
  14 -- Tempo is the number of quarter notes per minute.
  15 tempoToQNoteIvl :: Tempo -> DTime
  16 tempoToQNoteIvl = (15/) . fromIntegral
  17
  18 type TickingClock = (CBMVar (), ThreadId)
  19
  20 -- Make a clock that will execute any IO when it updates.
  21 mkClockGeneric :: IO () -> DTime -> IO TickingClock
  22 mkClockGeneric io d = do
  23   n <- newCBMVar ()
  24   tid <- forkIO $ forever $  do
  25     threadDelay dInt
  26     modifyCBMVar n return
  27     io
  28   return (n, tid)
  29   where dInt = floor $ d * 1000
  30
  31 -- Ticking clock in the IO monad, sending callbacks every t milliseconds.
  32 mkClock :: DTime -> IO TickingClock
  33 mkClock = mkClockGeneric (return ())
  34
  35 -- For debugging purposes.
  36 mkClockDebug :: DTime -> IO TickingClock
  37 mkClockDebug = mkClockGeneric (putStrLn "Ping !")
  38
  39 clockRV :: TickingClock -> ReactiveFieldRead IO ThreadId
  40 clockRV (mvar, tid) = ReactiveFieldRead (return tid)
  41                       (installCallbackCBMVar mvar)
  42
  43 mkClockRV :: DTime -> IO (ReactiveFieldRead IO ThreadId)
  44 mkClockRV d = clockRV <$> mkClock d
  45
  46 stopClock :: TickingClock -> IO ()
  47 stopClock (_,t) = killThread t