From a62275f853be9d9f43772fe1969c225ae43c3d62 Mon Sep 17 00:00:00 2001
From: mtgmonkey <mtgmonkey@nixos>
Date: Sun, 21 Dec 2025 12:23:57 +0100
Subject: merge development into master

---
 src/Main.hs | 329 ++++++++++++++++++++++++++++++++++++------------------------
 1 file changed, 196 insertions(+), 133 deletions(-)

(limited to 'src/Main.hs')

diff --git a/src/Main.hs b/src/Main.hs
index 2a96e89..6dec8ad 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
+
 {- |
  - Module      : Game
  - Description : runs game
@@ -7,177 +8,243 @@
  - Maintainer  : Matrix @Andromeda:tchncs.de
  - Stability   : Experimental
  -}
-module Main (main) where
+module Main
+  ( main
+  ) where
 
-import Game.Internal.Types
 import Game.Internal
+import Game.Internal.Types
 
-import Control.Lens          ((^.))
-import Data.IORef            (newIORef)
-import GHC.Float             (double2Float)
+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 Graphics.Rendering.OpenGL (($=))
+import qualified Graphics.UI.GLFW as GLFW
 
 import qualified Linear as L
-import           Linear      ( V3(..), _y )
+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 
+  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
-
+  (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)
-        )
+  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
+  ]
 
--- | 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
+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
-      $ updateCameraAngle
-        dt
-        model
+  updateVelocity dt
+  $ updateAcceleration dt
+  $ updateSpeed 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
-            }
+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
-        model
-          { camera = model.camera
-            { airTime = 0
-            , camVel = camVel' * (V3 1 0 1)
-            , camPos = model.camera.camPos * (V3 1 0 1)
-            , hasJumped = aboveGround
-            }
+    }
+  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
-      }
+    { 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
-      }
-    }
+  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 ()
@@ -185,39 +252,35 @@ 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)
+  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)
+  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
-- 
cgit v1.3.1