    {-# 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 :: a
    -> Display
    -> Color
    -> Int
    -> world
    -> (world -> IO Picture)
    -> (Event -> world -> IO world)
    -> (Float -> world -> IO world)
    -> Bool
    -> IO ()
    playWithBackendIO
            backend :: a
    backend
            display :: Display
    display
            backgroundColor :: Color
    backgroundColor
            simResolution :: Int
    simResolution
            worldStart :: world
    worldStart
            worldToPicture :: world -> IO Picture
    worldToPicture
            worldHandleEvent :: Event -> world -> IO world
    worldHandleEvent
            worldAdvance :: Float -> world -> IO world
    worldAdvance
            withCallbackExit :: Bool
    withCallbackExit
     = 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 world
    worldSR         <- world -> IO (IORef world)
    forall a. a -> IO (IORef a)
    newIORef world
    worldStart

            -- make the initial GL view and render states
            IORef ViewPort
    viewSR          <- ViewPort -> IO (IORef ViewPort)
    forall a. a -> IO (IORef a)
    newIORef ViewPort
    viewPortInit
            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
                    world
    world           <- IORef world -> IO world
    forall a. IORef a -> IO a
    readIORef IORef world
    worldSR
                    Picture
    picture         <- world -> IO Picture
    worldToPicture world
    world

                    -- display the picture in the current view
                    State
    renderS         <- IORef State -> IO State
    forall a. IORef a -> IO a
    readIORef IORef State
    renderSR
                    ViewPort
    viewPort        <- IORef ViewPort -> IO ViewPort
    forall a. IORef a -> IO a
    readIORef IORef ViewPort
    viewSR

                    (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
    viewPort)
                            (ViewPort -> Picture -> Picture
    applyViewPortToPicture ViewPort
    viewPort 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 world
    -> (ViewPort -> Float -> world -> IO world)
    -> 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 (IORef ViewPort -> IO ViewPort
    forall a. IORef a -> IO a
    readIORef IORef ViewPort
    viewSR)
                                                    IORef world
    worldSR (\_ -> Float -> world -> IO world
    worldAdvance)
                                                    Float
    singleStepTime)
                    , IORef world
    -> IORef ViewPort -> (Event -> world -> IO world) -> Callback
    forall world.
    IORef world
    -> IORef ViewPort -> (Event -> world -> IO world) -> Callback
    callback_keyMouse IORef world
    worldSR IORef ViewPort
    viewSR Event -> world -> IO world
    worldHandleEvent
                    , IORef world -> (Event -> world -> IO world) -> Callback
    forall world.
    IORef world -> (Event -> world -> IO world) -> Callback
    callback_motion   IORef world
    worldSR Event -> world -> IO world
    worldHandleEvent
                    , IORef world -> (Event -> world -> IO world) -> Callback
    forall world.
    IORef world -> (Event -> world -> IO world) -> Callback
    callback_reshape  IORef world
    worldSR Event -> world -> IO world
    worldHandleEvent]

            let exitCallback :: [Callback]
    exitCallback
                     = if Bool
    withCallbackExit then [() -> Callback
    forall a. a -> Callback
    callback_exit ()] else []

            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 [Callback] -> [Callback] -> [Callback]
    forall a. [a] -> [a] -> [a]
    ++ [Callback]
    exitCallback)
                    (\_ -> () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    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 :: IORef world
    -> IORef ViewPort -> (Event -> world -> IO world) -> Callback
    callback_keyMouse worldRef :: IORef world
    worldRef viewRef :: IORef ViewPort
    viewRef eventFn :: Event -> world -> IO world
    eventFn
            = KeyboardMouseCallback -> Callback
    KeyMouse (IORef world
    -> IORef ViewPort
    -> (Event -> world -> IO world)
    -> KeyboardMouseCallback
    forall a t.
    IORef a -> t -> (Event -> a -> IO a) -> KeyboardMouseCallback
    handle_keyMouse IORef world
    worldRef IORef ViewPort
    viewRef Event -> world -> IO world
    eventFn)

    handle_keyMouse
            :: IORef a
            -> t
            -> (Event -> a -> IO a)
            -> KeyboardMouseCallback

    handle_keyMouse :: IORef a -> t -> (Event -> a -> IO a) -> KeyboardMouseCallback
    handle_keyMouse worldRef :: IORef a
    worldRef _ eventFn :: Event -> a -> IO a
    eventFn backendRef :: IORef a
    backendRef key :: Key
    key keyState :: KeyState
    keyState keyMods :: Modifiers
    keyMods pos :: (Int, Int)
    pos
     = do   Event
    ev         <- IORef a -> Key -> KeyState -> Modifiers -> (Int, Int) -> IO Event
    forall a.
    Backend a =>
    IORef a -> Key -> KeyState -> Modifiers -> (Int, Int) -> IO Event
    keyMouseEvent IORef a
    backendRef Key
    key KeyState
    keyState Modifiers
    keyMods (Int, Int)
    pos
            a
    world      <- IORef a -> IO a
    forall a. IORef a -> IO a
    readIORef IORef a
    worldRef
            a
    world'     <- Event -> a -> IO a
    eventFn Event
    ev a
    world
            IORef a -> a -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef a
    worldRef a
    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 :: IORef world -> (Event -> world -> IO world) -> Callback
    callback_motion worldRef :: IORef world
    worldRef eventFn :: Event -> world -> IO world
    eventFn
            = MotionCallback -> Callback
    Motion (IORef world -> (Event -> world -> IO world) -> MotionCallback
    forall a. IORef a -> (Event -> a -> IO a) -> MotionCallback
    handle_motion IORef world
    worldRef Event -> world -> IO world
    eventFn)

    handle_motion
            :: IORef a
            -> (Event -> a -> IO a)
            -> MotionCallback

    handle_motion :: IORef a -> (Event -> a -> IO a) -> MotionCallback
    handle_motion worldRef :: IORef a
    worldRef eventFn :: Event -> a -> IO a
    eventFn backendRef :: IORef a
    backendRef pos :: (Int, Int)
    pos
     = do   Event
    ev       <- IORef a -> (Int, Int) -> IO Event
    forall a. Backend a => IORef a -> (Int, Int) -> IO Event
    motionEvent IORef a
    backendRef (Int, Int)
    pos
            a
    world    <- IORef a -> IO a
    forall a. IORef a -> IO a
    readIORef IORef a
    worldRef
            a
    world'   <- Event -> a -> IO a
    eventFn Event
    ev a
    world
            IORef a -> a -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef a
    worldRef a
    world'

    -- | Callback for Handle reshape event.
    callback_reshape
      :: IORef world
      -> (Event -> world -> IO world)
      -> Callback
    callback_reshape :: IORef world -> (Event -> world -> IO world) -> Callback
    callback_reshape worldRef :: IORef world
    worldRef eventFN :: Event -> world -> IO world
    eventFN
            = MotionCallback -> Callback
    Reshape (IORef world -> (Event -> world -> IO world) -> MotionCallback
    forall a. IORef a -> (Event -> a -> IO a) -> MotionCallback
    handle_reshape IORef world
    worldRef Event -> world -> IO world
    eventFN)

    handle_reshape
      :: IORef world
      -> (Event -> world -> IO world)
      -> ReshapeCallback
    handle_reshape :: IORef world -> (Event -> world -> IO world) -> MotionCallback
    handle_reshape worldRef :: IORef world
    worldRef eventFn :: Event -> world -> IO world
    eventFn stateRef :: IORef a
    stateRef (width :: Int
    width,height :: Int
    height)
     = do   world
    world  <- IORef world -> IO world
    forall a. IORef a -> IO a
    readIORef IORef world
    worldRef
            world
    world' <- Event -> world -> IO world
    eventFn ((Int, Int) -> Event
    EventResize (Int
    width, Int
    height)) world
    world
            IORef world -> world -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef world
    worldRef world
    world'
            IORef a -> (Int, Int) -> IO ()
    MotionCallback
    viewState_reshape IORef a
    stateRef (Int
    width, Int
    height)