path: root/src/Game/Main.hs

{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
{- |
 - Module      : Game
 - Description : runs game
 - Copyright   : Andromeda 2025
 - License     : WTFPL
 - Maintainer  : Matrix @Andromeda:tchncs.de
 - Stability   : Experimental
 -}
module Game (main) where

import Game.LoadShaders
import Game.Types

import Control.Concurrent    (threadDelay)
import Control.Lens          ((^.), (+~), (&), (%~))
import Control.Monad         (when)
import Data.Fixed            (mod')
import Data.IORef            (atomicModifyIORef', IORef, modifyIORef', newIORef, readIORef, writeIORef)
import Data.List             (delete)
import Foreign.Marshal.Array (withArray)
import Foreign.Ptr           (nullPtr, plusPtr)
import Foreign.Storable      (sizeOf, Storable)
import GHC.Float             (double2Float)

import qualified Graphics.UI.GLFW          as GLFW
import qualified Graphics.Rendering.OpenGL as GL
import           Graphics.Rendering.OpenGL as GL (($=))

import qualified Linear as L
import           Linear      ( V3(..)
                             , _x
                             , _y
                             , _z
                             )

-- | Main function runs game
main :: IO ()
main = do
  GLFW.init
  GLFW.defaultWindowHints

  -- OpenGL core >=3.3
  GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor 3
  GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 3
  GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
  
  -- 4x MSAA
  GLFW.windowHint $ GLFW.WindowHint'Samples $ Just 4

  -- create window
  monitor <- GLFW.getPrimaryMonitor
  Just window <- GLFW.createWindow 256 256 "hs-game" monitor Nothing 
  GLFW.makeContextCurrent $ Just window

  -- add callbacks
  GLFW.setWindowCloseCallback window $ Just shutdownWindow
  GLFW.setWindowSizeCallback window $ Just resizeWindow
  GLFW.setKeyCallback window $ Just (keyPressed Nothing)
  GLFW.setCursorPosCallback window $ Just (cursorPosHandler Nothing)

  (objects, program) <- initResources window

  -- init model
  let
    model =
      mkModel
        (mkCamera
          (V3 0 0 3) -- camPos
          0 -- pitch
          0 -- yaw
          (V3 0 0 (-1)) -- reference vector
          (V3 0 0 0) -- velocity
          0.08 -- mouse sensitivity
          16 -- strafe strength
          12 -- jump strength
        )
        objects
        program
        (mkWorldProperties
          2
          0.16
          (V3 0 1 0)
        )
  modelRef <- newIORef model

  -- add callbacks with io ref to model
  GLFW.setKeyCallback window $ Just $ keyPressed $ Just modelRef
  GLFW.setCursorPosCallback window $ Just $ cursorPosHandler $ Just modelRef

  loop window (update 0) view modelRef

--------------------------------------------------------------------------------
-- Arrays
--------------------------------------------------------------------------------

-- | centered unit square
testVertices :: [V3 GL.GLfloat]
testVertices =
  [ V3 (-0.5) (-0.5) 0
  , V3 0.5    (-0.5) 0
  , V3 (-0.5) 0.5    0
  , V3 0.5    0.5    0
  ]

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

-- | loads models, shaders
initResources :: GLFW.Window -> IO ([Object], GL.Program)
initResources window = do
  -- create objects
  testObject0 <- createObject (map (+(V3 (-1) (-1) (-1))) testVertices) 3 GL.TriangleStrip
  testObject1 <- createObject (map (+(V3 (1) (1) (1))) testVertices) 3 GL.TriangleStrip
  testObject2 <- createObject testVertices 3 GL.TriangleStrip
  let objects = [testObject0, testObject1, testObject2]

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

  return (objects, program)

-- 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 vec3 a_vPos;\n" ++
  "uniform mat4 u_view;\n" ++
  "uniform mat4 u_projection;\n" ++
  "out vec3 v_pos;\n" ++
  "void main()\n" ++
  "{\n" ++
  "  gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n" ++
  "  v_pos = a_vPos;\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 * v_pos, 1);\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
  -> IO Object
createObject array numComponents primitiveMode = do
  -- vao for object
  vao <- GL.genObjectName
  GL.bindVertexArrayObject $= Just vao

  -- vbo for vertices
  createVBO array numComponents $ GL.AttribLocation 0

  return
    (Object
      vao
      (fromIntegral $ length array)
      numComponents
      primitiveMode
    )

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

-- | gameloop
loop
  :: GLFW.Window -- ^ window to display on
  -> (Model -> Model) -- ^ update function
  -> (GLFW.Window -> Model -> IO ()) -- ^ view function
  -> IORef Model -- ^ model
  -> IO ()
loop window update view modelRef = do
  -- start frame timer
  Just frameStart <- GLFW.getTime

  -- tick model
  modifyIORef' modelRef $ update
  model' <- readIORef modelRef

  -- view new model
  view window model'

  putStrLn $ (++) "pitch" $ show model'.camera.camPitch
  putStrLn $ (++) "yaw" $ show model'.camera.camYaw

  -- end frame timer, wait the difference between expected and actual
  Just frameEnd <- GLFW.getTime
  let
    dt = double2Float $ frameEnd - frameStart
    target = 1 / 60 :: Float
  when (dt < target) $ threadDelay $ floor $ (target - dt) * 1000000
  Just frameEnd' <- GLFW.getTime
  let
    dt' = double2Float $ frameEnd' - frameStart

  loop window (Game.update dt') view modelRef

-- | update function
update :: Float -> Model -> Model
update dt model =
  updateVelocity
    dt
    $ updateAcceleration
      dt
      $ updateCameraAngle
        dt
        model

updateAcceleration :: Float -> Model -> Model
updateAcceleration dt model =
  let
    yaw = (L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) model.camera.camReference)
    front = L.normalize $ (V3 1 0 1) * (L.rotate (L.axisAngle (L.cross model.wprop.up yaw) model.camera.camPitch) yaw)
    zp = if elem GLFW.Key'S model.keys then 1 else 0
    zn = if elem GLFW.Key'W model.keys then 1 else 0
    xp = if elem GLFW.Key'D model.keys then 1 else 0
    xn = if elem GLFW.Key'A model.keys then 1 else 0
    x = xn - xp
    z = zn - zp
    friction = V3 (1 - model.wprop.friction) 1 (1 - model.wprop.friction)
    movement = L.normalize (V3 x 0 z) L.^* (dt * model.camera.strafeStrength)
    movement' = L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) movement
    jump =
      if model.camera.hasJumped then
        V3 0 (0 - model.wprop.g * model.camera.airTime) 0
      else
        V3 0 0 0
    camVel' = friction * (model.camera.camVel + movement' + jump)
    aboveGround = (model.camera.camPos + dt L.*^ camVel') ^. _y > 0
  in
    if
      (elem GLFW.Key'Space model.keys)
      && (model.camera.hasJumped == False)
    then
      updateAcceleration dt $ model { camera = model.camera { airTime = dt, camVel = model.camera.camVel + (V3 0 model.camera.jumpStrength 0), hasJumped = True } }
    else
      if aboveGround then
        model
          { camera = model.camera
            { airTime = model.camera.airTime + dt
            , camVel = camVel'
            , hasJumped = aboveGround
            }
          }
      else
        model
          { camera = model.camera
            { airTime = 0
            , camVel = camVel' * (V3 1 0 1)
            , camPos = model.camera.camPos * (V3 1 0 1)
            , hasJumped = aboveGround
            }
          }

updateVelocity :: Float -> Model -> Model
updateVelocity dt model =
  model
    { camera = model.camera
      { camPos = model.camera.camPos + dt L.*^ model.camera.camVel
      }
    }

updateCameraAngle :: Float -> Model -> Model
updateCameraAngle dt model =
  let
    newPitch = model.camera.camPitch - model.camera.mouseSensitivity * dt * (double2Float $ snd model.cursorDeltaPos)
    newPitch' = if newPitch >= (pi / 2) then (0.9999 * pi / 2) else newPitch
    newPitch'' = if newPitch <= ((-1) * pi / 2) then ((-0.9999) * pi / 2) else newPitch
    newYaw = model.camera.camYaw + model.camera.mouseSensitivity * dt * (double2Float $ fst model.cursorDeltaPos)
    newYaw' = newYaw - (mod' newYaw pi)
  in
  model
    { cursorDeltaPos = (0, 0)
    , camera = model.camera
      { camPitch = model.camera.camPitch + dt * (double2Float $ snd model.cursorDeltaPos)
      , camYaw = model.camera.camYaw + dt * (double2Float $ fst model.cursorDeltaPos)
      }
    }

-- | 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 =
  model
    { cursorPos = (x, y)
    , cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y)
    }

-- | views the model
view :: GLFW.Window -> Model -> IO ()
view window model = do
  -- fit viewport to window
  (w, h) <- GLFW.getFramebufferSize window
  GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))

  -- clear screen
  GL.clearColor $= GL.Color4 1 0 1 1
  GL.clear [GL.ColorBuffer, GL.DepthBuffer]

  -- apply transforms
  let
    yaw = (L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) model.camera.camReference)
    viewMatrix =
      L.lookAt
        model.camera.camPos
        (model.camera.camPos + L.rotate (L.axisAngle (L.cross model.wprop.up yaw) model.camera.camPitch) yaw)
        model.wprop.up
    projectionMatrix = L.perspective 1.5 (fromIntegral w / fromIntegral h) 0.1 100

  viewGLMatrix <- GL.newMatrix GL.RowMajor $ toGLMatrix viewMatrix :: IO (GL.GLmatrix GL.GLfloat)
  viewLocation <- GL.get $ GL.uniformLocation model.program "u_view"
  GL.uniform viewLocation $= viewGLMatrix

  projectionGLMatrix <- GL.newMatrix GL.RowMajor $ toGLMatrix projectionMatrix :: IO (GL.GLmatrix GL.GLfloat)
  projectionLocation <- GL.get $ GL.uniformLocation model.program "u_projection"
  GL.uniform projectionLocation $= projectionGLMatrix

  -- draw objects
  drawObjects model.objects

  -- swap to current buffer
  GLFW.swapBuffers window

  -- check for interrupts
  GLFW.pollEvents

-- | 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) window key _ GLFW.KeyState'Pressed _ =
  modifyIORef' modelRef $ updateKeyPressed key
keyPressed (Just modelRef) window 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 ()