src/RMCA/Global/Clock.hs

   1 {-# LANGUAGE MultiParamTypeClasses #-}
   2
   3 module RMCA.Global.Clock ( AbsBeat
   4                          , maxAbsBeat
   5                          , metronome
   6                          , tempoToQNoteIvl
   7                          , TickableClock
   8                          , newTickableClock
   9                          , tickClock
  10                          ) where
  11
  12 import Control.Concurrent
  13 import Control.Monad
  14 import Data.CBMVar
  15 import Data.ReactiveValue
  16 import FRP.Yampa
  17 import RMCA.Auxiliary
  18 import RMCA.Semantics
  19
  20 -- The absolute beat is the beat number of the global clock, there are
  21 -- 16 starting from 1.
  22 type AbsBeat = BeatNo
  23
  24 maxAbsBeat :: AbsBeat
  25 maxAbsBeat = 16
  26
  27 -- The global system tempo beats every 16th note, each beat is tagged
  28 -- with a beat number modulo sixteen. Each layer is then beating at
  29 -- its own fraction, discarding the unecessary beats.
  30 metronome :: SF Tempo (Event AbsBeat)
  31 metronome = accumBy (\pb _ -> nextBeatNo maxAbsBeat pb) 1 <<<
  32             repeatedlyS () <<^ (/4) <<^ tempoToQNoteIvl
  33
  34 -- Tempo is the number of quarter notes per minute.
  35 tempoToQNoteIvl :: Tempo -> DTime
  36 tempoToQNoteIvl = (15/) . fromIntegral
  37
  38 type TickingClock = (CBMVar (), ThreadId)
  39
  40 -- Make a clock that will execute any IO when it updates.
  41 mkClockGeneric :: IO () -> DTime -> IO TickingClock
  42 mkClockGeneric io d = do
  43   n <- newCBMVar ()
  44   tid <- forkIO $ forever $  do
  45     threadDelay dInt
  46     modifyCBMVar n return
  47     io
  48   return (n, tid)
  49   where dInt = floor $ d * 1000
  50
  51 -- Ticking clock in the IO monad, sending callbacks every t milliseconds.
  52 mkClock :: DTime -> IO TickingClock
  53 mkClock = mkClockGeneric (return ())
  54
  55 -- For debugging purposes.
  56 mkClockDebug :: DTime -> IO TickingClock
  57 mkClockDebug = mkClockGeneric (putStrLn "Ping !")
  58
  59 clockRV :: TickingClock -> ReactiveFieldRead IO ThreadId
  60 clockRV (mvar, tid) = ReactiveFieldRead (return tid)
  61                       (installCallbackCBMVar mvar)
  62
  63 mkClockRV :: DTime -> IO (ReactiveFieldRead IO ThreadId)
  64 mkClockRV d = clockRV <$> mkClock d
  65
  66 stopClock :: TickingClock -> IO ()
  67 stopClock (_,t) = killThread t
  68
  69 -- | A clock that can be written to.
  70 newtype TickableClock = TickableClock (CBMVar ())
  71
  72 tickClock :: TickableClock -> IO ()
  73 tickClock (TickableClock cl) = writeCBMVar cl ()
  74
  75 newTickableClock :: IO TickableClock
  76 newTickableClock = TickableClock <$> newCBMVar ()
  77
  78 instance ReactiveValueRead TickableClock () IO where
  79   reactiveValueRead _ = return ()
  80   reactiveValueOnCanRead (TickableClock tc) = installCallbackCBMVar tc