path: root/src/Game/Internal.hs

{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE MultilineStrings #-}
{-# 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 arr = do
  object <-
    createObject arr 4 GL.Triangles (GL.AttribLocation 0)

  -- compile shader program
  program <-
    loadShaders
      [ ShaderInfo GL.VertexShader (StringSource vertShader),
        ShaderInfo GL.FragmentShader (StringSource fragShader)
      ]
  GL.currentProgram $= Just program

  -- alpha
  GL.blend $= GL.Enabled
  GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)

  return (object, 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

vertShader :: String
vertShader =
  """
  #version 330 core

  layout (location = 0) in vec4 a_vPos;

  uniform mat4 u_view;
  uniform mat4 u_projection;
  uniform vec4 u_cam;

  out vec3 v_pos;
  out float v_w;
  out float v_alpha;

  vec3 orthoFrom4d(vec4 point)
  {
    return point.xyz;
  }

  // creates a simple 3d coordinate from a 4d
  vec3 projectFrom4d(vec4 point)
  {
    // TODO don't do camera ops in shader, prefer linear algebra
    // also use a reasonable projection for god's sake
    vec4 view = abs(u_cam - point);
    float perspective = 1.0 / abs(u_cam.w - view.w);

    return perspective * (point.xyz);
  }

  void main()
  {
    vec3 vPos = orthoFrom4d(a_vPos);

    // TODO don't set constant inside of shader :/
    float wHorizon = 3;
    float alpha = (wHorizon - abs(u_cam.w - a_vPos.w)) / wHorizon;

    // cull invisible things
    if (alpha < -1) {
      gl_Position = vec4(0.0);
      alpha = 0.0;
    } else {
      alpha = max(alpha, 0.0);
      gl_Position = u_projection * u_view * vec4(vPos, 1.0);
    }

    v_pos = vPos;
    v_w = a_vPos.w;
    v_alpha = alpha;
  }
  """

fragShader :: String
fragShader =
  """
  #version 330 core

  uniform vec4 u_cam;

  out vec4 o_vColor;

  in vec3 v_pos;
  in float v_w;
  in float v_alpha;

  void main()
  {
    // the normal vector of the face
    // yoinked from https://stackoverflow.com/questions/14980712/how-to-get-flat-normals-on-a-cube/14981446#14981446
    vec3 norm = normalize(cross(dFdx(v_pos), dFdy(v_pos)));

    // creates a color based on the normal direction
    o_vColor = vec4((0.5 + 0.5 * norm) / 2, v_alpha);
  }
  """

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