{-# 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 :: IORef State
-> IORef State
-> IO ViewPort
-> IORef world
-> (ViewPort -> Float -> world -> IO world)
-> Float
-> IdleCallback
callback_simulate_idle IORef State
simSR IORef State
animateSR IO ViewPort
viewSA IORef world
worldSR ViewPort -> Float -> world -> IO world
worldAdvance Float
_singleStepTime IORef a
backendRef
 = {-# SCC "callbackIdle" #-}
   do   IORef State
-> IORef State
-> IO ViewPort
-> IORef world
-> (ViewPort -> Float -> world -> IO world)
-> IORef a
-> IO ()
forall world.
IORef State
-> IORef State
-> IO ViewPort
-> IORef world
-> (ViewPort -> Float -> world -> IO world)
-> IdleCallback
simulate_run IORef State
simSR IORef State
animateSR IO ViewPort
viewSA IORef world
worldSR ViewPort -> Float -> world -> IO world
worldAdvance IORef a
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 :: IORef State
-> IORef State
-> IO ViewPort
-> IORef world
-> (ViewPort -> Float -> world -> IO world)
-> IdleCallback
simulate_run IORef State
simSR IORef State
_ IO ViewPort
viewSA IORef world
worldSR ViewPort -> Float -> world -> IO world
worldAdvance IORef a
backendRef
 = do   ViewPort
viewS           <- IO ViewPort
viewSA
        State
simS            <- IORef State -> IO State
forall a. IORef a -> IO a
readIORef IORef State
simSR
        world
worldS          <- IORef world -> IO world
forall a. IORef a -> IO a
readIORef IORef world
worldSR

        -- get the elapsed time since the start simulation (wall clock)
        Float
elapsedTime     <- (Double -> Float) -> IO Double -> IO Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> Float
double2Float (IO Double -> IO Float) -> IO Double -> IO Float
forall a b. (a -> b) -> a -> b
$ IORef a -> IO Double
forall a. Backend a => IORef a -> IO Double
Backend.elapsedTime IORef a
backendRef

        -- get how far along the simulation is
        Float
simTime                 <- IORef State
simSR IORef State -> (State -> Float) -> IO Float
forall a r. IORef a -> (a -> r) -> IO r
`getsIORef` State -> Float
SM.stateSimTime

        -- we want to simulate this much extra time to bring the simulation
        --      up to the wall clock.
        let thisTime :: Float
thisTime    = Float
elapsedTime Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
simTime

        -- work out how many steps of simulation this equals
        Int
resolution      <- IORef State
simSR IORef State -> (State -> Int) -> IO Int
forall a r. IORef a -> (a -> r) -> IO r
`getsIORef` State -> Int
SM.stateResolution
        let timePerStep :: Float
timePerStep = Float
1 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
resolution
        let thisSteps_ :: Integer
thisSteps_  = Float -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Float -> Integer) -> Float -> Integer
forall a b. (a -> b) -> a -> b
$ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
resolution Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
thisTime
        let thisSteps :: Integer
thisSteps   = if Integer
thisSteps_ Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Integer
0 else Integer
thisSteps_

        let newSimTime :: Float
newSimTime  = Float
simTime Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Integer -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
thisSteps Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
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 :: Integer
nStart      = State -> Integer
SM.stateIteration State
simS
        let nFinal :: Integer
nFinal      = Integer
nStart Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
thisSteps

        -- keep advancing the world until we get to the final iteration number
        (Integer
_,world
world')
         <- ((Integer, world) -> Bool)
-> ((Integer, world) -> IO (Integer, world))
-> (Integer, world)
-> IO (Integer, world)
forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> (a -> m a) -> a -> m a
untilM (\(Integer
n, world
_)        -> Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
nFinal)
                   (\(Integer
n, world
w)        -> (world -> (Integer, world)) -> IO world -> IO (Integer, world)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\world
w' -> (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1,world
w')) ( ViewPort -> Float -> world -> IO world
worldAdvance ViewPort
viewS Float
timePerStep world
w))
                   (Integer
nStart, world
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
world' world -> IO () -> IO ()
`seq` IORef world -> world -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef world
worldSR world
world'

        -- update the control state
        IORef State -> (State -> State) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef State
simSR ((State -> State) -> IO ()) -> (State -> State) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State
c -> State
c
                { stateIteration :: Integer
SM.stateIteration     = Integer
nFinal
                , stateSimTime :: Float
SM.stateSimTime       = Float
newSimTime }

        -- tell glut we want to draw the window after returning
        IORef a -> IO ()
IdleCallback
Backend.postRedisplay IORef a
backendRef


getsIORef :: IORef a -> (a -> r) -> IO r
getsIORef :: IORef a -> (a -> r) -> IO r
getsIORef IORef a
ref a -> r
fun
 = (a -> r) -> IO a -> IO r
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> r
fun (IO a -> IO r) -> IO a -> IO r
forall a b. (a -> b) -> a -> b
$ IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
ref

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