Simulate.hs

{-# 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
        backend
        display
        backgroundColor
        simResolution
        worldStart
        worldToPicture
        worldAdvance
 = do
        let singleStepTime      = 1

        -- make the simulation state
        stateSR         <- newIORef $ SM.stateInit simResolution

        -- make a reference to the initial world
        worldSR         <- newIORef worldStart

        -- make the initial GL view and render states
        viewSR          <- newIORef viewStateInit
        animateSR       <- newIORef AN.stateInit
        renderS_        <- initState
        renderSR        <- newIORef renderS_

        let displayFun backendRef
             = do
                -- convert the world to a picture
                world           <- readIORef worldSR
                port            <- viewStateViewPort <$> readIORef viewSR
                picture         <- worldToPicture world

                -- display the picture in the current view
                renderS         <- readIORef renderSR

                windowSize      <- getWindowDimensions backendRef

                -- render the frame
                displayPicture
                        windowSize
                        backgroundColor
                        renderS
                        (viewPortScale port)
                        (applyViewPortToPicture port picture)

                -- perform GC every frame to try and avoid long pauses
                performGC

        let callbacks
             =  [ Callback.Display      (animateBegin animateSR)
                , Callback.Display      displayFun
                , Callback.Display      (animateEnd   animateSR)
                , Callback.Idle         (callback_simulate_idle
                                                stateSR animateSR
                                                (viewStateViewPort <$> readIORef viewSR)
                                                worldSR worldAdvance
                                                singleStepTime)
                , callback_exit ()
                , callback_viewState_keyMouse viewSR
                , callback_viewState_motion   viewSR
                , callback_viewState_reshape ]

        createWindow backend display backgroundColor
                callbacks
                (const (return ()))