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