    {-# 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
            backend :: a
    backend
            display :: Display
    display
            backgroundColor :: Color
    backgroundColor
            simResolution :: Int
    simResolution
            worldStart :: model
    worldStart
            worldToPicture :: model -> IO Picture
    worldToPicture
            worldAdvance :: ViewPort -> Float -> model -> IO model
    worldAdvance
     = do
            let singleStepTime :: Float
    singleStepTime      = 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 backendRef :: 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 ()))