path: root/src/Main.hs

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

{- |
 - Module      : Game
 - Description : runs game
 - Copyright   : 2025 Andromeda
 - License     : BSD 3-clause
 - Maintainer  : Matrix @Andromeda:tchncs.de
 - Stability   : Experimental
 -}
module Main
  ( main
  ) where

import Game.Internal
import Game.Internal.Types

import Control.Lens ((^.))
import Data.IORef (newIORef)
import GHC.Float (double2Float)

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

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
    [ map (+ V3 a 0 0) cube | a <- take 100 [0,2..]]
  -- 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
--------------------------------------------------------------------------------
top :: [V3 GL.GLfloat]
top =
  [ V3 p 0 p
  , V3 p 0 m
  , V3 m 0 p
  , V3 m 0 m
  ]
side :: [V3 GL.GLfloat]
side =
  [ V3 0 p p
  , V3 0 p m
  , V3 0 m p
  , V3 0 m m
  ]
front :: [V3 GL.GLfloat]
front =
  [ V3 p p 0
  , V3 p m 0
  , V3 m p 0
  , V3 m m 0
  ]

m = (0 - p)
p = 0.5

-- TODO optimise cube
-- | cube vertices
cube :: [V3 GL.GLfloat]
cube =
  [ V3 p p p -- front
  , V3 p m p
  , V3 m p p
  , V3 m m p -- down
  , V3 m m m
  , V3 p m p
  , V3 p m m -- right
  , V3 p p m
  , V3 p m p
  , V3 p p p -- up
  , V3 m p p
  , V3 p p m
  , V3 m p m -- back
  , V3 p m m
  , V3 p p m
  , V3 m m m -- left
  , V3 m p m
  , V3 m m p
  , V3 m p p
  ]

--------------------------------------------------------------------------------
-- Elm-like data structures
--------------------------------------------------------------------------------
-- | update function
update :: Float -> Model -> Model
update dt model =
  updateVelocity dt
  $ updateAcceleration dt
  $ updateSpeed dt
  $ updateCameraAngle dt model

updateSpeed :: Float -> Model -> Model
updateSpeed dt model =
  if elem GLFW.Key'T model.keys then
  model
    { camera =
        model.camera
          { jumpStrength = model.camera.jumpStrength * 1.1
          , strafeStrength = model.camera.strafeStrength * 1.1
          }
    }
  else if elem GLFW.Key'G model.keys then
  model
    { camera =
        model.camera
          { jumpStrength = model.camera.jumpStrength * 0.99
          , strafeStrength = model.camera.strafeStrength * 0.99
          }
    }
  else 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.2 (fromIntegral w / fromIntegral h) 0.01 1000
  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