content: {-# LANGUAGE RankNTypes #-}
  
  module Graphics.Gloss.Internals.Interface.Game
          ( playWithBackendIO
          , Event(..) )
  where
  import Graphics.Gloss.Data.Color
  import Graphics.Gloss.Data.Picture
  import Graphics.Gloss.Data.ViewPort
  import Graphics.Gloss.Rendering
  import Graphics.Gloss.Internals.Interface.Event
  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.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
  
  playWithBackendIO
          :: forall world 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.
          -> world        -- ^ The initial world.
          -> (world -> IO Picture)
                          -- ^ A function to convert the world to a picture.
          -> (Event -> world -> IO world)
                          -- ^ A function to handle input events.
          -> (Float -> world -> IO world)
                          -- ^ A function to step the world one iteration.
                          --   It is passed the period of time (in seconds) needing to be advanced.
          -> Bool         -- ^ Whether to use the callback_exit or not.
          -> IO ()
  
  playWithBackendIO
          backend
          display
          backgroundColor
          simResolution
          worldStart
          worldToPicture
          worldHandleEvent
          worldAdvance
          withCallbackExit
   = 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 viewPortInit
          animateSR       <- newIORef AN.stateInit
          renderS_        <- initState
          renderSR        <- newIORef renderS_
  
          let displayFun backendRef
               = do
                  -- convert the world to a picture
                  world           <- readIORef worldSR
                  picture         <- worldToPicture world
  
                  -- display the picture in the current view
                  renderS         <- readIORef renderSR
                  viewPort        <- readIORef viewSR
  
                  windowSize <- getWindowDimensions backendRef
  
                  -- render the frame
                  displayPicture
                          windowSize
                          backgroundColor
                          renderS
                          (viewPortScale viewPort)
                          (applyViewPortToPicture viewPort 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 (readIORef viewSR)
                                                  worldSR (\_ -> worldAdvance)
                                                  singleStepTime)
                  , callback_keyMouse worldSR viewSR worldHandleEvent
                  , callback_motion   worldSR worldHandleEvent
                  , callback_reshape  worldSR worldHandleEvent]
  
          let exitCallback
                   = if withCallbackExit then [callback_exit ()] else []
  
          createWindow
                  backend
                  display
                  backgroundColor
                  (callbacks ++ exitCallback)
                  (\_ -> return ())
  
  
  
  -- | Callback for KeyMouse events.
  callback_keyMouse
          :: IORef world                  -- ^ ref to world state
          -> IORef ViewPort
          -> (Event -> world -> IO world) -- ^ fn to handle input events
          -> Callback
  
  callback_keyMouse worldRef viewRef eventFn
          = KeyMouse (handle_keyMouse worldRef viewRef eventFn)
  
  
  handle_keyMouse
          :: IORef a
          -> t
          -> (Event -> a -> IO a)
          -> KeyboardMouseCallback
  
  handle_keyMouse worldRef _ eventFn backendRef key keyState keyMods pos
   = do   ev         <- keyMouseEvent backendRef key keyState keyMods pos
          world      <- readIORef worldRef
          world'     <- eventFn ev world
          writeIORef worldRef world'
  
  
  -- | Callback for Motion events.
  callback_motion
          :: IORef world                  -- ^ ref to world state
          -> (Event -> world -> IO world) -- ^ fn to handle input events
          -> Callback
  
  callback_motion worldRef eventFn
          = Motion (handle_motion worldRef eventFn)
  
  
  handle_motion
          :: IORef a
          -> (Event -> a -> IO a)
          -> MotionCallback
  
  handle_motion worldRef eventFn backendRef pos
   = do   ev       <- motionEvent backendRef pos
          world    <- readIORef worldRef
          world'   <- eventFn ev world
          writeIORef worldRef world'
  
  
  -- | Callback for Handle reshape event.
  callback_reshape
    :: IORef world
    -> (Event -> world -> IO world)
    -> Callback
  callback_reshape worldRef eventFN
          = Reshape (handle_reshape worldRef eventFN)
  
  
  handle_reshape
    :: IORef world
    -> (Event -> world -> IO world)
    -> ReshapeCallback
  handle_reshape worldRef eventFn stateRef (width,height)
   = do   world  <- readIORef worldRef
          world' <- eventFn (EventResize (width, height)) world
          writeIORef worldRef world'
          viewState_reshape stateRef (width, height)
  