brillo-2.0.0: Brillo/Internals/Interface/Game.hs

{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Use camelCase" #-}
{-# HLINT ignore "Use list comprehension" #-}

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) =>
  -- | Initial state of the backend
  a ->
  -- | Display mode.
  Display ->
  -- | Background color.
  Color ->
  -- | Number of simulation steps to take for each second of real time.
  Int ->
  -- | The initial world.
  world ->
  -- | A function to convert the world to a picture.
  (world -> IO Picture) ->
  -- | A function to handle input events.
  (Event -> world -> IO world) ->
  {-| A function to step the world one iteration.
  It is passed the period of time (in seconds) needing to be advanced.
  -}
  (Float -> world -> IO world) ->
  -- | Whether to use the callback_exit or not.
  Bool ->
  IO ()
playWithBackendIO
  backend
  display
  backgroundColor
  simResolution
  worldStart
  worldToPicture
  worldHandleEvent
  worldAdvance
  withCallbackExit =
    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_ <- initState
      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
              viewPort <- readIORef viewSR

              windowSize <- getWindowDimensions backendRef

              -- render the frame
              displayPicture
                windowSize
                backgroundColor
                renderS
                (viewPortScale viewPort)
                (applyViewPortToPicture viewPort picture)

              -- perform GC every frame to try and avoid long pauses
              performGC

      let callbacks =
            [ Callback.Display (animateBegin animateSR)
            , Callback.Display displayFun
            , Callback.Display (animateEnd animateSR)
            , Callback.Idle
                ( callback_simulate_idle
                    stateSR
                    animateSR
                    (readIORef viewSR)
                    worldSR
                    (const worldAdvance)
                    singleStepTime
                )
            , callback_keyMouse worldSR viewSR worldHandleEvent
            , callback_motion worldSR worldHandleEvent
            , callback_drop worldSR worldHandleEvent
            , callback_reshape worldSR worldHandleEvent
            ]

      let exitCallback =
            if withCallbackExit then [callback_exit ()] else []

      createWindow
        backend
        display
        backgroundColor
        (callbacks ++ exitCallback)
        (\_ -> return ())


-- | Callback for KeyMouse events.
callback_keyMouse ::
  -- | ref to world state
  IORef world ->
  IORef ViewPort ->
  -- | fn to handle input events
  (Event -> world -> IO world) ->
  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
    ev <- keyMouseEvent backendRef key keyState keyMods pos
    world <- readIORef worldRef
    world' <- eventFn ev world
    writeIORef worldRef world'


-- | Callback for Motion events.
callback_motion ::
  -- | ref to world state
  IORef world ->
  -- | fn to handle input events
  (Event -> world -> IO world) ->
  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
    ev <- motionEvent backendRef pos
    world <- readIORef worldRef
    world' <- eventFn ev world
    writeIORef worldRef world'


callback_drop ::
  IORef world ->
  (Event -> world -> IO world) ->
  Callback
callback_drop worldRef eventFn =
  Drop (handle_drop worldRef eventFn)


handle_drop ::
  IORef a ->
  (Event -> a -> IO a) ->
  DropCallback
handle_drop worldRef eventFn backendRef paths = do
  ev <- dropEvent backendRef paths
  world <- readIORef worldRef
  world' <- eventFn ev world
  writeIORef worldRef world'


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


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