hs-game/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.Internal.LoadShaders
import Game.Internal.Types
import Game.Internal

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, int2Double)

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
  
  -- MSAA
  GLFW.windowHint $ GLFW.WindowHint'Samples $ Just 8

  -- 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.setCursorInputMode window GLFW.CursorInputMode'Hidden
  GLFW.setCursorPosCallback window $ Just (cursorPosHandler Nothing)

  (objects, program) <- initResources window testVertices

  -- 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
          2 -- 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 0 update 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
  ]

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

-- | 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 = xp - xn
    z = zp - zn
    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
    scaleFactor = model.camera.mouseSensitivity * dt
    newPitch = model.camera.camPitch -
      scaleFactor * (double2Float $ snd model.cursorDeltaPos) -- mouse sensitivity, update pitch
    newPitch' = if newPitch > 1.56 then 1.56 else newPitch
    newPitch'' = if newPitch' < (-1.56) then (-1.56) else newPitch'
    newYaw = model.camera.camYaw +
      scaleFactor * (double2Float $ fst model.cursorDeltaPos)
  in
  model
    { cursorDeltaPos = (0, 0)
    , camera = model.camera
      { camPitch = newPitch''
      , camYaw = newYaw
      }
    }

-- | 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 }

-- | 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]

  -- depth
  GL.depthFunc $= Just GL.Less

  -- apply transforms
  let
    pitch = model.camera.camPitch
    yaw = model.camera.camYaw
    forward = V3 (cos pitch * sin yaw) (sin pitch) (cos pitch * cos yaw)
    viewMatrix =
      L.lookAt
        model.camera.camPos
        (model.camera.camPos - forward)
        model.wprop.up
    projectionMatrix = L.perspective 1.5 (fromIntegral w / fromIntegral h) 0.01 10000

  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