    {-# LANGUAGE RankNTypes #-}

    module Graphics.Gloss.Internals.Interface.Game
    	( playWithBackendIO
    	, Event(..))
    where
    import Graphics.Gloss.Data.Color
    import Graphics.Gloss.Data.Picture
    import Graphics.Gloss.Internals.Render.Picture
    import Graphics.Gloss.Internals.Render.ViewPort
    import Graphics.Gloss.Internals.Interface.Backend
    import Graphics.Gloss.Internals.Interface.Window
    import Graphics.Gloss.Internals.Interface.Common.Exit
    import Graphics.Gloss.Internals.Interface.ViewPort
    import Graphics.Gloss.Internals.Interface.ViewPort.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 qualified Graphics.Gloss.Internals.Render.State	        	as RS
    import Data.IORef
    import System.Mem

    -- | Possible input events.
    data Event
    	= EventKey    Key KeyState Modifiers (Float, Float)
    	| EventMotion (Float, Float)
    	deriving (Eq, Show)

    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.
    	-> IO ()

    playWithBackendIO
    	backend
            display
    	backgroundColor
    	simResolution
    	worldStart
    	worldToPicture
    	worldHandleEvent
    	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 viewPortInit
    	animateSR	<- newIORef AN.stateInit
            renderS_        <- RS.stateInit
    	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
    		viewS		<- readIORef viewSR

    		-- render the frame
    		withViewPort
    			backendRef
    			viewS
    	 	 	(renderPicture backendRef renderS viewS picture)

    		-- perform garbage collection
    		performGC

    	let callbacks
    	     = 	[ Callback.Display	(animateBegin animateSR)
    		, Callback.Display 	displayFun
    		, Callback.Display	(animateEnd   animateSR)
    		, Callback.Idle		(callback_simulate_idle
    						stateSR animateSR viewSR
    						worldSR worldStart (\_ -> worldAdvance)
    						singleStepTime)
    		, callback_exit ()
    		, callback_keyMouse worldSR viewSR worldHandleEvent
    		, callback_motion   worldSR worldHandleEvent
    		, callback_viewPort_reshape ]

    	createWindow backend display backgroundColor callbacks

    -- | 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	pos'       <- convertPoint backendRef pos
            world      <- readIORef worldRef
            world'     <- eventFn (EventKey key keyState keyMods pos') 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   pos'     <- convertPoint backendRef pos
            world    <- readIORef worldRef
            world'   <- eventFn (EventMotion pos') world
            writeIORef worldRef world'

    convertPoint ::
    	forall a . Backend a
    	=> IORef a
    	-> (Int, Int)
    	-> IO (Float,Float)
    convertPoint backendRef pos
     = do	(sizeX_, sizeY_) 		<- getWindowDimensions backendRef
    	let (sizeX, sizeY)		= (fromIntegral sizeX_, fromIntegral sizeY_)

    	let (px_, py_)	= pos
    	let px		= fromIntegral px_
    	let py		= sizeY - fromIntegral py_

    	let px'		= px - sizeX / 2
    	let py' 	= py - sizeY / 2
    	let pos'	= (px', py')
    	return pos'