hs-game/src/Game/Internal.hs

{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}

-- |
-- - Module      : Game.Internal
-- - Description : internal functions
-- - Copyright   : 2025 Andromeda
-- - License     : BSD 3-clause
-- - Maintainer  : Matrix @Andromeda:tchncs.de
-- - Stability   : Experimental
module Game.Internal
  ( cursorPosHandler,
    drawObjects,
    initResources,
    keyPressed,
    loop,
    resizeWindow,
    shutdownWindow,
    updateCursorPos,
    updateKeyPressed,
    updateKeyReleased,
  )
where

import Control.Concurrent (threadDelay)
import Control.Monad (when)
import Data.IORef (IORef, modifyIORef', readIORef)
import Data.List (delete)
import Foreign.Marshal.Array (withArray)
import Foreign.Ptr (nullPtr, plusPtr)
import Foreign.Storable (Storable, sizeOf)
import GHC.Float (double2Float)
import Game.Internal.LoadShaders
import Game.Internal.Types
import Graphics.Rendering.OpenGL (($=))
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLFW as GLFW
import Linear (V3 (..), V4 (..))

--------------------------------------------------------------------------------
-- Shader creation and object initialisation
--------------------------------------------------------------------------------

initResources :: [[V4 GL.GLfloat]] -> IO ([Object], GL.Program)
initResources arrays = do
  objects <-
    listIOsToIOlist
      [createObject arr 4 GL.TriangleStrip (GL.AttribLocation 0) | arr <- arrays]
      []
  program <-
    loadShaders
      [ ShaderInfo GL.VertexShader (StringSource vertShader),
        ShaderInfo GL.FragmentShader (StringSource fragShader)
      ]
  GL.currentProgram $= Just program
  return (objects, program)

listIOsToIOlist :: [IO a] -> [a] -> IO [a]
listIOsToIOlist [] out = return out
listIOsToIOlist (io : ios) out = do
  ioVal <- io
  listIOsToIOlist ios (ioVal : out)

-- a_ vertex shader input
-- v_ varying
-- u_ uniform
-- o_ fragment shader output

-- | vertex shader
vertShader :: String
vertShader =
  "#version 330 core\n"
    ++ "layout (location = 0) in vec4 a_vPos;\n"
    ++ "uniform mat4 u_view;\n"
    ++ "uniform mat4 u_projection;\n"
    ++ "out vec3 v_pos;\n"
    ++ glslProjectTo3d
    ++ "void main()\n"
    ++ "{\n"
    ++ "  gl_Position = u_projection * u_view * vec4(projectTo3d(a_vPos), 1.0);\n"
    ++ "  v_pos = a_vPos.xyz;\n"
    ++ "}\n"

-- | fragment shader
fragShader :: String
fragShader =
  "#version 330 core\n"
    ++ "out vec4 o_vColor;\n"
    ++ "in vec3 v_pos;\n"
    ++ "void main()\n"
    ++ "{\n"
    ++ "  o_vColor = vec4(0.5 + 0.5 * normalize(v_pos), 1);\n"
    ++ "}\n"

glslProjectTo3d :: String
glslProjectTo3d =
  "vec3 projectTo3d(vec4 point)\n"
    ++ "{\n"
    ++ "  float perspective = 1.0 / (1.0 + point.w);\n"
    ++ "  return perspective * point.xyz;\n"
    ++ "}\n"

--------------------------------------------------------------------------------
-- Objects
--------------------------------------------------------------------------------

-- | calculates the size in memory of an array
sizeOfArray :: (Storable a, Num b) => [a] -> b
sizeOfArray [] = 0
sizeOfArray (x : xs) = fromIntegral $ (*) (1 + length xs) $ sizeOf x

-- | loads a given array into a given attribute index
createVBO ::
  (Storable (a GL.GLfloat)) =>
  [a GL.GLfloat] ->
  GL.NumComponents ->
  GL.AttribLocation ->
  IO GL.BufferObject
createVBO array numComponents attribLocation = do
  -- vbo for buffer
  buffer <- GL.genObjectName
  GL.bindBuffer GL.ArrayBuffer $= Just buffer
  -- populate buffer
  withArray array $ \ptr ->
    GL.bufferData GL.ArrayBuffer $= (sizeOfArray array, ptr, GL.StaticDraw)
  -- create attribute pointer to buffer
  GL.vertexAttribPointer attribLocation
    $= ( GL.ToFloat,
         GL.VertexArrayDescriptor numComponents GL.Float 0 (plusPtr nullPtr 0)
       )
  GL.vertexAttribArray attribLocation $= GL.Enabled
  return buffer

-- | creates an object from a given array; deals with vbos and everything
createObject ::
  (Storable (a GL.GLfloat)) =>
  [a GL.GLfloat] ->
  GL.NumComponents ->
  GL.PrimitiveMode ->
  GL.AttribLocation ->
  IO Object
createObject array numComponents primitiveMode attrLocation = do
  -- vao for object
  vao <- GL.genObjectName
  GL.bindVertexArrayObject $= Just vao
  -- vbo for vertices
  _ <- createVBO array numComponents attrLocation
  return (Object vao (fromIntegral $ length array) numComponents primitiveMode)

--------------------------------------------------------------------------------
-- Elm-like data structures
--------------------------------------------------------------------------------

-- | gameloop
loop ::
  -- | window to display on
  GLFW.Window ->
  -- | dt
  Float ->
  -- | update function
  (Float -> Model -> Model) ->
  -- | view function
  (GLFW.Window -> Model -> IO ()) ->
  -- | model
  IORef Model ->
  IO ()
loop window dt update view modelRef = do
  -- start frame timer
  Just frameStart <- GLFW.getTime
  -- tick model
  modifyIORef' modelRef $ update dt
  model' <- readIORef modelRef
  -- view new model
  view window model'
  -- end frame timer, wait the difference between expected and actual
  Just frameEnd <- GLFW.getTime
  let drawTime = double2Float $ frameEnd - frameStart
      target = 1 / 60 :: Float
  when (drawTime < target) $ threadDelay $ floor $ (target - drawTime) * 1000000
  Just frameEnd' <- GLFW.getTime
  let dt' = double2Float $ frameEnd' - frameStart
  loop window dt' update view modelRef

-- | updates given a keypress. escape case is probably caught by GLFW in the
-- handler function itself
updateKeyPressed :: GLFW.Key -> Model -> Model
updateKeyPressed key model = model {keys = key : model.keys}

-- | updates given a keyrelease. escape case is probably caught by GLFW in the
-- handler function itself
updateKeyReleased :: GLFW.Key -> Model -> Model
updateKeyReleased key model = model {keys = (delete key model.keys)}

applyToTuples :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
applyToTuples f (x, y) (a, b) = (f x a, f y b)

-- | updates cursor
updateCursorPos :: Double -> Double -> Model -> Model
updateCursorPos x y model =
  let pyth =
        (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos) - y) ** 2)
          ** 0.5
   in if pyth < 16
        then
          model
            { cursorPos = (x, y),
              cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y)
            }
        else model {cursorPos = (x, y)}

-- | draws objects
drawObjects :: [Object] -> IO ([Object])
drawObjects [] = return []
drawObjects ((Object vao numVertices _ primitiveMode) : objects) = do
  GL.bindVertexArrayObject $= Just vao
  GL.drawArrays primitiveMode 0 numVertices
  drawObjects objects

--------------------------------------------------------------------------------
-- interrupts
--------------------------------------------------------------------------------

-- | shuts down GLFW
shutdownWindow :: GLFW.WindowCloseCallback
shutdownWindow window = do
  GLFW.destroyWindow window
  GLFW.terminate

-- | resizes viewport with window
resizeWindow :: GLFW.WindowSizeCallback
resizeWindow _ _ _ = return ()

-- | handles key presses
keyPressed :: Maybe (IORef Model) -> GLFW.KeyCallback
keyPressed _ window GLFW.Key'Escape _ GLFW.KeyState'Pressed _ =
  shutdownWindow window
keyPressed (Just modelRef) _ key _ GLFW.KeyState'Pressed _ =
  modifyIORef' modelRef $ updateKeyPressed key
keyPressed (Just modelRef) _ key _ GLFW.KeyState'Released _ =
  modifyIORef' modelRef $ updateKeyReleased key
keyPressed _ _ _ _ _ _ = return ()

-- | handles cursor position updates
cursorPosHandler :: Maybe (IORef Model) -> GLFW.CursorPosCallback
cursorPosHandler (Just modelRef) _ x y =
  modifyIORef' modelRef $ updateCursorPos x y
cursorPosHandler Nothing _ _ _ = return ()