RCMA/Global/Clock.hs

   1 module RCMA.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 RCMA.Auxiliary.Auxiliary
   9 import RCMA.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 (tempoToDTime 60) ())
  18                      &&&
  19                     (onChange')) (metronome')
  20   where metronome' :: Tempo -> SF Tempo (Event Beat)
  21         metronome' t = (switch ((repeatedly (4 * tempoToDTime t) ())
  22                                  &&&
  23                                  onChange) (metronome'))
  24
  25 -- Tempo is the number of whole notes per minute.
  26 tempoToDTime :: Tempo -> DTime
  27 tempoToDTime = (15/) . fromIntegral
  28
  29 type TickingClock = (CBMVar (), ThreadId)
  30
  31 -- Ticking clock in the IO monad, sending callbacks every t milliseconds.
  32 mkClock :: DTime -> IO TickingClock
  33 mkClock d = do
  34   n <- newCBMVar ()
  35   tid <- forkIO $ forever $  do
  36     threadDelay dInt
  37     modifyCBMVar n return
  38   return (n, tid)
  39   where dInt = floor $ d * (10^3)
  40
  41 clockRV :: TickingClock -> ReactiveFieldRead IO ThreadId
  42 clockRV (mvar, tid) = ReactiveFieldRead (return tid)
  43                       (installCallbackCBMVar mvar)
  44
  45 mkClockRV :: DTime -> IO (ReactiveFieldRead IO ThreadId)
  46 mkClockRV d = clockRV <$> mkClock d
  47
  48 stopClock :: TickingClock -> IO ()
  49 stopClock (_,t) = killThread t