path: root/src/Main.hs

{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE 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 Control.Lens ((^.))
import Data.IORef (newIORef)
import GHC.Float (double2Float)
import Game.Internal
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 (..), (*^), _w, _xyz, _y)
import qualified Linear as L

-- | 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
  -- alpha
  -- 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)
  (object, program) <-
    initResources $
      concat
        ( [hCube]
            ++ [map (\v -> (V4 a 0 0 a) + (rotate4 0 1 (a * g90 / 24) v)) hCube | a <- take 1000 [0, 2 ..]]
            ++ [map (\v -> (V4 a 2 0 a) + (rotate4 0 2 (a * g90 / 24) v)) hCube | a <- take 1000 [0, 2 ..]]
            ++ [map (\v -> (V4 a 4 0 a) + (rotate4 0 3 (a * g90 / 24) v)) hCube | a <- take 1000 [0, 2 ..]]
            ++ [map (\v -> (V4 a (-2) 0 a) + (rotate4 1 0 (a * g90 / 24) v)) hCube | a <- take 1000 [0, 2 ..]]
            ++ [map (\v -> (V4 a (-4) 0 a) + (rotate4 2 0 (a * g90 / 24) v)) hCube | a <- take 1000 [0, 2 ..]]
            ++ [map (\v -> (V4 a (-6) 0 a) + (rotate4 3 0 (a * g90 / 24) v)) hCube | a <- take 1000 [0, 2 ..]]
        )

  let model =
        mkModel
          ( mkCamera
              (V4 0 0 3 0) -- 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
          )
          [object]
          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
--------------------------------------------------------------------------------

m = (0 - p)

p = 0.5

g90 = pi / 2

v3tov4 :: GL.GLfloat -> V3 GL.GLfloat -> V4 GL.GLfloat
v3tov4 w (V3 x y z) = V4 x y z w

v3tov4' :: GL.GLfloat -> V3 GL.GLfloat -> V4 GL.GLfloat
v3tov4' w (V3 x y z) = V4 x y w z

v3tov4'' :: GL.GLfloat -> V3 GL.GLfloat -> V4 GL.GLfloat
v3tov4'' w (V3 x y z) = V4 x w y z

v3tov4''' :: GL.GLfloat -> V3 GL.GLfloat -> V4 GL.GLfloat
v3tov4''' w (V3 x y z) = V4 w x y z

rotate :: V3 GL.GLfloat -> GL.GLfloat -> V3 GL.GLfloat -> V3 GL.GLfloat
rotate axis angle point = L.fromQuaternion (L.axisAngle axis angle) L.!* point

rotate4 :: Int -> Int -> GL.GLfloat -> V4 GL.GLfloat -> V4 GL.GLfloat
rotate4 i0 i1 angle (V4 x y z w) =
  let coords = [x, y, z, w]
      cos' = cos angle
      sin' = sin angle
      xi = coords !! i0
      xj = coords !! i1
      coords' =
        [ if k == i0
            then cos' * xi - sin' * xj
            else
              if k == i1
                then sin' * xi + cos' * xj
                else coords !! k
        | k <- [0 .. 3]
        ]
   in V4 (coords' !! 0) (coords' !! 1) (coords' !! 2) (coords' !! 3)

cycle3r :: V3 GL.GLfloat -> V3 GL.GLfloat
cycle3r (V3 a b c) = V3 c a b

cycle3l :: V3 GL.GLfloat -> V3 GL.GLfloat
cycle3l (V3 a b c) = V3 b c a

face :: [V3 GL.GLfloat]
face =
  [ V3 m m 0,
    V3 p m 0,
    V3 m p 0,
    V3 m p 0,
    V3 p m 0,
    V3 p p 0
  ]

-- | cube, side length 1, centered on 0 0 0
cube :: [V3 GL.GLfloat]
cube =
  concatMap
    ( \faceSpec ->
        map
          (\v -> (rotate (fst faceSpec) g90 v) L.^+^ (rotate (fst faceSpec) g90 (snd faceSpec)))
          face
    )
    [ (V3 0 0 1, V3 0 0 p),
      (V3 0 1 0, V3 0 0 p),
      (V3 1 0 0, V3 0 0 p),
      (V3 0 0 (-1), V3 0 0 m), -- no clue
      (V3 0 (-1) 0, V3 0 0 p),
      (V3 (-1) 0 0, V3 0 0 p)
    ]

hCube :: [V4 GL.GLfloat]
hCube =
  concatMap
    ( \(w, i0, i1) ->
        map
          (rotate4 i0 i1 g90 . v3tov4 w)
          cube
    )
    [ (p, 3, 0),
      (p, 0, 3),
      (p, 1, 3),
      (p, 2, 3),
      (m, 3, 0),
      (m, 0, 3),
      (m, 1, 3),
      (m, 2, 3)
    ]

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

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

updateW :: Float -> Model -> Model
updateW dt model =
  if elem GLFW.Key'R model.keys
    then
      model
        { camera =
            model.camera
              { camPos = model.camera.camPos + (V4 0 0 0 (dt * dt * model.camera.strafeStrength))
              }
        }
    else
      if elem GLFW.Key'F model.keys
        then
          model
            { camera =
                model.camera
                  { camPos = model.camera.camPos - (V4 0 0 0 (dt * dt * model.camera.strafeStrength))
                  }
            }
        else 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 ^. _xyz) + 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 * (V4 1 0 1 1),
                        hasJumped = aboveGround
                      }
                }

updateVelocity :: Float -> Model -> Model
updateVelocity dt model =
  model
    { camera =
        model.camera
          { camPos = V4 1 1 1 (model.camera.camPos ^. _w) * (L.point $ (model.camera.camPos ^. _xyz) + 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 ^. _xyz)
          ((model.camera.camPos ^. _xyz) - 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)

  -- load 3d view matrix
  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)

  -- load 3d projection matrix
  projectionLocation <- GL.get $ GL.uniformLocation model.program "u_projection"
  GL.uniform projectionLocation $= projectionGLMatrix

  let camx = (\(V4 x _ _ _) -> x) model.camera.camPos
      camy = (\(V4 _ y _ _) -> y) model.camera.camPos
      camz = (\(V4 _ _ z _) -> z) model.camera.camPos
      camw = (\(V4 _ _ _ w) -> w) model.camera.camPos
  camWLocation <- GL.get $ GL.uniformLocation model.program "u_cam"
  GL.uniform camWLocation $= GL.Vector4 camx camy camz camw

  -- draw objects; returns IO []
  _ <- drawObjects model.objects
  -- swap to current buffer
  GLFW.swapBuffers window
  -- check for interrupts
  GLFW.pollEvents