module Clocked (
Timer,
withTimer,
waitTimer,
getTimeDouble,
) where
import Data.IORef
import Data.Sequence
import Control.Monad
import Control.Monad.CatchIO
import Control.Monad.IO.Class
import Control.Applicative ((<$>))
import Clocked.Common
import Clocked.WinTimePeriod
windowSize :: Double
windowSize = 10
initialDeviation = 0.00018
heuristicCorrectionFraction = 0.1
foreign import ccall qtUSleep :: Int -> IO ()
newtype Timer = Timer (IORef State)
withTimer :: MonadCatchIO m => (Timer -> m a) -> m a
withTimer m = withTimePeriod 1 $
(m =<< liftIO (Timer <$> (newIORef =<< mkState)))
data State = State {
lastTime :: Double,
deviations :: Seq Double,
deviationMovingAverage :: Double
}
mkState :: IO State
mkState = do
now <- getTimeDouble
return $ State now (mkFullBuffer (round windowSize) initialDeviation) initialDeviation
waitTimer :: Timer -> Double -> IO ()
waitTimer (Timer ref) waitSeconds = do
state <- readIORef ref
now <- getTimeDouble
let heuristicCorrection = deviationMovingAverage state
waitTime :: Double = waitSeconds (now lastTime state) heuristicCorrection
waitMicroSeconds = round (waitTime * 10 ^ 6)
when (waitMicroSeconds > 0) $
qtUSleep waitMicroSeconds
after <- getTimeDouble
let actuallyWaited = after lastTime state
deviation = min
(actuallyWaited waitSeconds + heuristicCorrection)
(waitSeconds * heuristicCorrectionFraction)
(droppedDeviation, newBuffer) = crank deviation (deviations state)
newAverage = deviationMovingAverage state + ((deviation droppedDeviation) / windowSize)
state' = State after newBuffer newAverage
writeIORef ref state'
mkFullBuffer :: Int -> a -> Seq a
mkFullBuffer = Data.Sequence.replicate
crank :: a -> Seq a -> (a, Seq a)
crank new buffer = case viewl buffer of
head :< tail -> (head, tail |> new)
EmptyL -> error "crank on empty buffer"