Animate.hs

module Graphics.Gloss.Internals.Interface.Animate
        (animateWithBackendIO)
where
import Graphics.Gloss.Data.Color
import Graphics.Gloss.Data.Controller
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 qualified Graphics.Gloss.Internals.Interface.Animate.State       as AN
import qualified Graphics.Gloss.Internals.Interface.Callback            as Callback
import Data.IORef
import Control.Monad
import System.Mem
import GHC.Float (double2Float)


animateWithBackendIO
        :: Backend a
        => a                     -- ^ Initial State of the backend
        -> Bool                  -- ^ Whether to allow the image to be panned around.
        -> Display               -- ^ Display mode.
        -> Color                 -- ^ Background color.
        -> (Float -> IO Picture) -- ^ Function to produce the next frame of animation.
                                 --     It is passed the time in seconds since the program started.
        -> (Controller -> IO ()) -- ^ Eat the controller.
        -> IO ()

animateWithBackendIO
        backend pannable display backColor
        frameOp eatController
 = do
        --
        viewSR          <- newIORef viewStateInit
        animateSR       <- newIORef AN.stateInit
        renderS_        <- initState
        renderSR        <- newIORef renderS_

        let displayFun backendRef = do
                -- extract the current time from the state
                timeS           <- animateSR `getsIORef` AN.stateAnimateTime

                -- call the user action to get the animation frame
                picture         <- frameOp (double2Float timeS)

                renderS         <- readIORef renderSR
                portS           <- viewStateViewPort <$> readIORef viewSR

                windowSize      <- getWindowDimensions backendRef

                -- render the frame
                displayPicture
                        windowSize
                        backColor
                        renderS
                        (viewPortScale portS)
                        (applyViewPortToPicture portS 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         (\s -> postRedisplay s)
                , callback_exit ()
                , callback_viewState_motion viewSR
                , callback_viewState_reshape ]

             ++ (if pannable
                  then [callback_viewState_keyMouse viewSR]
                  else [])

        createWindow backend display backColor callbacks
           $ \ backendRef
           ->  eatController
                $ Controller
                { controllerSetRedraw
                   = postRedisplay backendRef

                , controllerModifyViewPort
                   = \modViewPort
                     -> do viewState       <- readIORef viewSR
                           port'           <- modViewPort $ viewStateViewPort viewState
                           let viewState'  =  viewState { viewStateViewPort = port' }
                           writeIORef viewSR viewState'
                           postRedisplay backendRef
                }





getsIORef :: IORef a -> (a -> r) -> IO r
getsIORef ref fun
 = liftM fun $ readIORef ref