{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_HADDOCK hide #-}
module Brillo.Internals.Interface.Simulate.Idle (callback_simulate_idle)
where
import Brillo.Data.ViewPort
import Brillo.Internals.Interface.Animate.State qualified as AN
import Brillo.Internals.Interface.Backend qualified as Backend
import Brillo.Internals.Interface.Callback
import Brillo.Internals.Interface.Simulate.State qualified as SM
import Control.Monad
import Data.IORef
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 :: forall world.
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)
-> IdleCallback
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 :: forall world.
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 a b. (a -> b) -> IO a -> IO b
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 b. Integral b => Float -> b
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
n Integer -> 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 ()
forall a b. a -> b -> b
`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
{ SM.stateIteration = nFinal
, SM.stateSimTime = newSimTime
}
IORef a -> IO ()
IdleCallback
Backend.postRedisplay IORef a
backendRef
getsIORef :: IORef a -> (a -> r) -> IO r
getsIORef :: forall a r. 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 :: forall (m :: * -> *) a.
Monad m =>
(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 a. 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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m a
go