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 (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 -- 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 * (10^3)
  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