{-# LANGUAGE RankNTypes #-}

module Brillo.Internals.Interface.Game (
  playWithBackendIO,
  Event (..),
)
where

import Brillo.Data.Color
import Brillo.Data.Picture
import Brillo.Data.ViewPort
import Brillo.Internals.Interface.Animate.State qualified as AN
import Brillo.Internals.Interface.Animate.Timing
import Brillo.Internals.Interface.Backend
import Brillo.Internals.Interface.Callback qualified as Callback
import Brillo.Internals.Interface.Common.Exit
import Brillo.Internals.Interface.Event
import Brillo.Internals.Interface.Simulate.Idle
import Brillo.Internals.Interface.Simulate.State qualified as SM
import Brillo.Internals.Interface.ViewState.Reshape
import Brillo.Internals.Interface.Window
import Brillo.Rendering
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 :: forall world a.
Backend a =>
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 IORef a -> IO ()
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 a. a -> IO a
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 :: forall world.
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 :: forall a t.
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 :: forall world.
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 :: forall a. 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 :: forall world.
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 :: forall a. IORef a -> (Event -> a -> IO a) -> 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)