{-# LANGUAGE RankNTypes #-}

module Graphics.Gloss.Internals.Interface.Interact
        (interactWithBackend)
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.Event
import Graphics.Gloss.Internals.Interface.Backend
import Graphics.Gloss.Internals.Interface.Window
import Graphics.Gloss.Internals.Interface.ViewState.Reshape
import qualified Graphics.Gloss.Internals.Interface.Callback as Callback
import Data.IORef
import System.Mem


interactWithBackend
        :: Backend a
        => a                            -- ^ Initial state of the backend.
        -> Display                      -- ^ Display config.
        -> Color                        -- ^ Background color.
        -> world                        -- ^ The initial world.
        -> (world -> IO Picture)        -- ^ A function to produce the current picture.
        -> (Event -> world -> IO world) -- ^ A function to handle input events.
        -> (Controller -> IO ())        -- ^ Eat the controller
        -> IO ()

interactWithBackend :: a
-> Display
-> Color
-> world
-> (world -> IO Picture)
-> (Event -> world -> IO world)
-> (Controller -> IO ())
-> IO ()
interactWithBackend
        a
backend Display
displayMode Color
background
        world
worldStart
        world -> IO Picture
worldToPicture
        Event -> world -> IO world
worldHandleEvent
        Controller -> IO ()
eatController

 =  do  IORef ViewState
viewSR          <- ViewState -> IO (IORef ViewState)
forall a. a -> IO (IORef a)
newIORef ViewState
viewStateInit
        IORef world
worldSR         <- world -> IO (IORef world)
forall a. a -> IO (IORef a)
newIORef world
worldStart
        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
                world
world      <- IORef world -> IO world
forall a. IORef a -> IO a
readIORef IORef world
worldSR
                Picture
picture    <- world -> IO Picture
worldToPicture world
world

                State
renderS'      <- IORef State -> IO State
forall a. IORef a -> IO a
readIORef IORef State
renderSR
                ViewState
viewState     <- IORef ViewState -> IO ViewState
forall a. IORef a -> IO a
readIORef IORef ViewState
viewSR
                let viewPort :: ViewPort
viewPort  =  ViewState -> ViewPort
viewStateViewPort ViewState
viewState

                (Int, Int)
windowSize <- IORef a -> IO (Int, Int)
forall a. Backend a => IORef a -> IO (Int, Int)
getWindowDimensions IORef a
backendRef

                (Int, Int) -> Color -> State -> Float -> Picture -> IO ()
displayPicture
                        (Int, Int)
windowSize
                        Color
background
                        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 DisplayCallback
displayFun

                -- Viewport control with mouse
                , IORef world
-> IORef ViewState -> (Event -> world -> IO world) -> Callback
forall world.
IORef world
-> IORef ViewState -> (Event -> world -> IO world) -> Callback
callback_keyMouse IORef world
worldSR IORef ViewState
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 ]

        -- When we create the window we can pass a function to get a
        -- reference to the backend state. Using this we make a controller
        -- so the client can control the window asynchronously.
        a -> Display -> Color -> [Callback] -> (IORef a -> IO ()) -> IO ()
forall a.
Backend a =>
a -> Display -> Color -> [Callback] -> (IORef a -> IO ()) -> IO ()
createWindow a
backend Display
displayMode Color
background [Callback]
callbacks
         ((IORef a -> IO ()) -> IO ()) -> (IORef a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \  IORef a
backendRef
           -> Controller -> IO ()
eatController
                (Controller -> IO ()) -> Controller -> IO ()
forall a b. (a -> b) -> a -> b
$ Controller :: IO () -> ((ViewPort -> IO ViewPort) -> IO ()) -> Controller
Controller
                { controllerSetRedraw :: IO ()
controllerSetRedraw
                   = do IORef a -> IO ()
DisplayCallback
postRedisplay IORef a
backendRef

                , controllerModifyViewPort :: (ViewPort -> IO ViewPort) -> IO ()
controllerModifyViewPort
                   = \ViewPort -> IO ViewPort
modViewPort
                     -> do ViewState
viewState       <- IORef ViewState -> IO ViewState
forall a. IORef a -> IO a
readIORef IORef ViewState
viewSR
                           ViewPort
port'           <- ViewPort -> IO ViewPort
modViewPort (ViewPort -> IO ViewPort) -> ViewPort -> IO ViewPort
forall a b. (a -> b) -> a -> b
$ ViewState -> ViewPort
viewStateViewPort ViewState
viewState
                           let viewState' :: ViewState
viewState'  =  ViewState
viewState { viewStateViewPort :: ViewPort
viewStateViewPort = ViewPort
port' }
                           IORef ViewState -> ViewState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ViewState
viewSR ViewState
viewState'
                           IORef a -> IO ()
DisplayCallback
postRedisplay IORef a
backendRef
                }


-- | Callback for KeyMouse events.
callback_keyMouse
        :: IORef world                  -- ^ ref to world state
        -> IORef ViewState
        -> (Event -> world -> IO world) -- ^ fn to handle input events
        -> Callback

callback_keyMouse :: IORef world
-> IORef ViewState -> (Event -> world -> IO world) -> Callback
callback_keyMouse IORef world
worldRef IORef ViewState
viewRef Event -> world -> IO world
eventFn
        = KeyboardMouseCallback -> Callback
KeyMouse (IORef world
-> IORef ViewState
-> (Event -> world -> IO world)
-> KeyboardMouseCallback
forall a t.
IORef a -> t -> (Event -> a -> IO a) -> KeyboardMouseCallback
handle_keyMouse IORef world
worldRef IORef ViewState
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'
        IORef a -> IO ()
DisplayCallback
postRedisplay IORef a
backendRef


-- | 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'
        IORef a -> IO ()
DisplayCallback
postRedisplay IORef a
backendRef


-- | 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
backendRef (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
backendRef (Int
width, Int
height)
        IORef a -> IO ()
DisplayCallback
postRedisplay IORef a
backendRef