{-# LANGUAGE RankNTypes #-}
module Graphics.Gloss.Internals.Interface.Simulate
(simulateWithBackendIO)
where
import Graphics.Gloss.Data.Display
import Graphics.Gloss.Data.Color
import Graphics.Gloss.Data.Picture
import Graphics.Gloss.Data.ViewPort
import Graphics.Gloss.Data.ViewState
import Graphics.Gloss.Rendering
import Graphics.Gloss.Internals.Interface.Backend
import Graphics.Gloss.Internals.Interface.Window
import Graphics.Gloss.Internals.Interface.Common.Exit
import Graphics.Gloss.Internals.Interface.ViewState.KeyMouse
import Graphics.Gloss.Internals.Interface.ViewState.Motion
import Graphics.Gloss.Internals.Interface.ViewState.Reshape
import Graphics.Gloss.Internals.Interface.Animate.Timing
import Graphics.Gloss.Internals.Interface.Simulate.Idle
import qualified Graphics.Gloss.Internals.Interface.Callback as Callback
import qualified Graphics.Gloss.Internals.Interface.Simulate.State as SM
import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN
import Data.IORef
import System.Mem
simulateWithBackendIO
:: forall model a
. Backend a
=> a
-> Display
-> Color
-> Int
-> model
-> (model -> IO Picture)
-> (ViewPort -> Float -> model -> IO model)
-> IO ()
simulateWithBackendIO :: a
-> Display
-> Color
-> Int
-> model
-> (model -> IO Picture)
-> (ViewPort -> Float -> model -> IO model)
-> IO ()
simulateWithBackendIO
a
backend
Display
display
Color
backgroundColor
Int
simResolution
model
worldStart
model -> IO Picture
worldToPicture
ViewPort -> Float -> model -> IO model
worldAdvance
= do
let singleStepTime :: Float
singleStepTime = Float
1
IORef State
stateSR <- State -> IO (IORef State)
forall a. a -> IO (IORef a)
newIORef (State -> IO (IORef State)) -> State -> IO (IORef State)
forall a b. (a -> b) -> a -> b
$ Int -> State
SM.stateInit Int
simResolution
IORef model
worldSR <- model -> IO (IORef model)
forall a. a -> IO (IORef a)
newIORef model
worldStart
IORef ViewState
viewSR <- ViewState -> IO (IORef ViewState)
forall a. a -> IO (IORef a)
newIORef ViewState
viewStateInit
IORef State
animateSR <- State -> IO (IORef State)
forall a. a -> IO (IORef a)
newIORef State
AN.stateInit
State
renderS_ <- IO State
initState
IORef State
renderSR <- State -> IO (IORef State)
forall a. a -> IO (IORef a)
newIORef State
renderS_
let displayFun :: IORef a -> IO ()
displayFun IORef a
backendRef
= do
model
world <- IORef model -> IO model
forall a. IORef a -> IO a
readIORef IORef model
worldSR
ViewPort
port <- ViewState -> ViewPort
viewStateViewPort (ViewState -> ViewPort) -> IO ViewState -> IO ViewPort
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef ViewState -> IO ViewState
forall a. IORef a -> IO a
readIORef IORef ViewState
viewSR
Picture
picture <- model -> IO Picture
worldToPicture model
world
State
renderS <- IORef State -> IO State
forall a. IORef a -> IO a
readIORef IORef State
renderSR
(Int, Int)
windowSize <- IORef a -> IO (Int, Int)
forall a. Backend a => IORef a -> IO (Int, Int)
getWindowDimensions IORef a
backendRef
(Int, Int) -> Color -> State -> Float -> Picture -> IO ()
displayPicture
(Int, Int)
windowSize
Color
backgroundColor
State
renderS
(ViewPort -> Float
viewPortScale ViewPort
port)
(ViewPort -> Picture -> Picture
applyViewPortToPicture ViewPort
port Picture
picture)
IO ()
performGC
let callbacks :: [Callback]
callbacks
= [ DisplayCallback -> Callback
Callback.Display (IORef State -> DisplayCallback
animateBegin IORef State
animateSR)
, DisplayCallback -> Callback
Callback.Display DisplayCallback
displayFun
, DisplayCallback -> Callback
Callback.Display (IORef State -> DisplayCallback
animateEnd IORef State
animateSR)
, DisplayCallback -> Callback
Callback.Idle (IORef State
-> IORef State
-> IO ViewPort
-> IORef model
-> (ViewPort -> Float -> model -> IO model)
-> Float
-> DisplayCallback
forall world.
IORef State
-> IORef State
-> IO ViewPort
-> IORef world
-> (ViewPort -> Float -> world -> IO world)
-> Float
-> DisplayCallback
callback_simulate_idle
IORef State
stateSR IORef State
animateSR
(ViewState -> ViewPort
viewStateViewPort (ViewState -> ViewPort) -> IO ViewState -> IO ViewPort
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef ViewState -> IO ViewState
forall a. IORef a -> IO a
readIORef IORef ViewState
viewSR)
IORef model
worldSR ViewPort -> Float -> model -> IO model
worldAdvance
Float
singleStepTime)
, () -> Callback
forall a. a -> Callback
callback_exit ()
, IORef ViewState -> Callback
callback_viewState_keyMouse IORef ViewState
viewSR
, IORef ViewState -> Callback
callback_viewState_motion IORef ViewState
viewSR
, Callback
callback_viewState_reshape ]
a -> Display -> Color -> [Callback] -> (IORef a -> IO ()) -> IO ()
forall a.
Backend a =>
a -> Display -> Color -> [Callback] -> (IORef a -> IO ()) -> IO ()
createWindow a
backend Display
display Color
backgroundColor
[Callback]
callbacks
(IO () -> IORef a -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()))