Idle.hs

{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE RankNTypes #-}

module Graphics.Gloss.Internals.Interface.Simulate.Idle
        ( callback_simulate_idle )
where
import Graphics.Gloss.Data.ViewPort
import Graphics.Gloss.Internals.Interface.Callback
import qualified Graphics.Gloss.Internals.Interface.Backend             as Backend
import qualified Graphics.Gloss.Internals.Interface.Animate.State       as AN
import qualified Graphics.Gloss.Internals.Interface.Simulate.State      as SM
import Data.IORef
import Control.Monad
import GHC.Float (double2Float)


-- | The graphics library calls back on this function when it's finished drawing
--      and it's time to do some computation.
callback_simulate_idle
        :: IORef SM.State                               -- ^ the simulation state
        -> IORef AN.State                               -- ^ the animation statea
        -> IO ViewPort
        -- ^ action to get the 'ViewPort'.  We don't use an 'IORef'
        -- directly because sometimes we hold a ref to a 'ViewPort' (in
        -- Game) and sometimes a ref to a 'ViewState'.
        -> IORef world                                  -- ^ the current world
        -> (ViewPort -> Float -> world -> IO world)     -- ^ fn to advance the world
        -> Float                                        -- ^ how much time to advance world by
                                                        --      in single step mode
        -> IdleCallback

callback_simulate_idle simSR animateSR viewSA worldSR worldAdvance _singleStepTime backendRef
 = {-# SCC "callbackIdle" #-}
   do   simulate_run simSR animateSR viewSA worldSR worldAdvance backendRef


-- take the number of steps specified by controlWarp
simulate_run
        :: IORef SM.State
        -> IORef AN.State
        -> IO ViewPort
        -> IORef world
        -> (ViewPort -> Float -> world -> IO world)
        -> IdleCallback

simulate_run simSR _ viewSA worldSR worldAdvance backendRef
 = do   viewS           <- viewSA
        simS            <- readIORef simSR
        worldS          <- readIORef worldSR

        -- get the elapsed time since the start simulation (wall clock)
        elapsedTime     <- fmap double2Float $ Backend.elapsedTime backendRef

        -- get how far along the simulation is
        simTime                 <- simSR `getsIORef` SM.stateSimTime

        -- we want to simulate this much extra time to bring the simulation
        --      up to the wall clock.
        let thisTime    = elapsedTime - simTime

        -- work out how many steps of simulation this equals
        resolution      <- simSR `getsIORef` SM.stateResolution
        let timePerStep = 1 / fromIntegral resolution
        let thisSteps_  = truncate $ fromIntegral resolution * thisTime
        let thisSteps   = if thisSteps_ < 0 then 0 else thisSteps_

        let newSimTime  = simTime + fromIntegral thisSteps * timePerStep

{-      putStr  $  "elapsed time    = " ++ show elapsedTime     ++ "\n"
                ++ "sim time        = " ++ show simTime         ++ "\n"
                ++ "this time       = " ++ show thisTime        ++ "\n"
                ++ "this steps      = " ++ show thisSteps       ++ "\n"
                ++ "new sim time    = " ++ show newSimTime      ++ "\n"
                ++ "taking          = " ++ show thisSteps       ++ "\n\n"
-}
        -- work out the final step number for this display cycle
        let nStart      = SM.stateIteration simS
        let nFinal      = nStart + thisSteps

        -- keep advancing the world until we get to the final iteration number
        (_,world')
         <- untilM (\(n, _)        -> n >= nFinal)
                   (\(n, w)        -> liftM (\w' -> (n+1,w')) ( worldAdvance viewS timePerStep w))
                   (nStart, worldS)

        -- write the world back into its IORef
        -- We need to seq on the world to avoid space leaks when the window is not showing.
        world' `seq` writeIORef worldSR world'

        -- update the control state
        modifyIORef' simSR $ \c -> c
                { SM.stateIteration     = nFinal
                , SM.stateSimTime       = newSimTime }

        -- tell glut we want to draw the window after returning
        Backend.postRedisplay backendRef


getsIORef :: IORef a -> (a -> r) -> IO r
getsIORef ref fun
 = liftM fun $ readIORef ref

untilM :: (Monad m) => (a -> Bool) -> (a -> m a) -> a -> m a
untilM test op i = go i
  where
  go x | test x    = return x
       | otherwise = op x >>= go