{-# 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)
callback_simulate_idle
:: IORef SM.State
-> IORef AN.State
-> IO ViewPort
-> IORef world
-> (ViewPort -> Float -> world -> IO world)
-> Float
-> 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
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
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
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
let thisTime :: Float
thisTime = Float
elapsedTime Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
simTime
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
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
(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)
world
world' world -> IO () -> IO ()
`seq` IORef world -> world -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef world
worldSR world
world'
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 }
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