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

import Control.Lens          ((^.))
import Data.IORef            (newIORef)
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(..), _y )

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

-- | 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; returns IO []
  _ <- drawObjects model.objects

  -- swap to current buffer
  GLFW.swapBuffers window

  -- check for interrupts
  GLFW.pollEvents