{-# 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
        a
backend
        Display
display
        Color
backgroundColor
        Int
simResolution
        world
worldStart
        world -> IO Picture
worldToPicture
        Event -> world -> IO world
worldHandleEvent
        Float -> world -> IO world
worldAdvance
        Bool
withCallbackExit
 = do
        let singleStepTime :: Float
singleStepTime      = Float
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 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 (\ViewPort
_ -> 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)
                (\IORef a
_ -> () -> 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 IORef world
worldRef IORef ViewPort
viewRef 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 IORef a
worldRef t
_ Event -> a -> IO a
eventFn IORef a
backendRef Key
key KeyState
keyState Modifiers
keyMods (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 IORef world
worldRef 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 IORef a
worldRef Event -> a -> IO a
eventFn IORef a
backendRef (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 IORef world
worldRef 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 IORef world
worldRef Event -> world -> IO world
eventFn IORef a
stateRef (Int
width,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)