{-# 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            -- ^ Initial state of the backend
        -> Display      -- ^ Display mode.
        -> Color        -- ^ Background color.
        -> Int          -- ^ Number of simulation steps to take for each second of real time.
        -> model        -- ^ The initial model.
        -> (model -> IO Picture)
                -- ^ A function to convert the model to a picture.
        -> (ViewPort -> Float -> model -> IO model)
                -- ^ A function to step the model one iteration. It is passed the
                --     current viewport and the amount of time for this simulation
                --     step (in seconds).
        -> 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

        -- make the simulation state
        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

        -- make a reference to the initial world
        IORef model
worldSR         <- model -> IO (IORef model)
forall a. a -> IO (IORef a)
newIORef model
worldStart

        -- make the initial GL view and render states
        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
                -- convert the world to a picture
                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

                -- display the picture in the current view
                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

                -- render the frame
                (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)

                -- perform GC every frame to try and avoid long pauses
                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 ()))