add types.hs, add README, add mouse movement

README.md

@@ -0,0 +1,12 @@
+```bash
+git clone https://git.mtgmonkey.net/Andromeda/hs-game
+cd hs-game
+nix run
+```
+
+todo
+
+- [x] add proper mouse movement
+- [ ] abstract into `Game` and `Game.Internal` with appropriate exports
+- [ ] refactor for correctness
+- [ ] fix depth clipping; near squares show oft before far

src/Game/Main.hs

@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fwarn-name-shadowing #-}
+{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
 {- |
  - Module      : Game
  - Description : runs game
@@ -10,21 +10,29 @@
 module Game (main) where
 
 import Game.LoadShaders
+import Game.Types
 
 import Control.Concurrent    (threadDelay)
+import Control.Lens          ((^.), (+~), (&), (%~))
 import Control.Monad         (when)
-import Data.IORef            (IORef, modifyIORef', newIORef, readIORef, writeIORef)
-import Data.List             (delete, nub)
+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)
 
 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      (V2, V3, V4, M44, V2(..), V3(..), V4(..))
+import           Linear      ( V3(..)
+                             , _x
+                             , _y
+                             , _z
+                             )
 
 -- | Main function runs game
 main :: IO ()
@@ -49,31 +57,38 @@ main = do
   GLFW.setWindowCloseCallback window $ Just shutdownWindow
   GLFW.setWindowSizeCallback window $ Just resizeWindow
   GLFW.setKeyCallback window $ Just (keyPressed Nothing)
+  GLFW.setCursorPosCallback window $ Just (cursorPosHandler Nothing)
 
   (objects, program) <- initResources window
 
   -- init model
-  let model =
-        Model
-          objects
-          (Camera
-            (V3 0 0 3)
-            (V3 0 0 0)
-            (V3 0 1 0)
-            (V3 0 0 0)
-          )
-          program
-          []
-          (WorldProperties
-            600
-            300
-          )
+  let
+    model =
+      mkModel
+        (mkCamera
+          (V3 0 0 3) -- camPos
+          0 -- pitch
+          0 -- yaw
+          (V3 0 0 (-1)) -- reference vector
+          (V3 0 0 0) -- velocity
+          0.08 -- mouse sensitivity
+          16 -- strafe strength
+          12 -- jump strength
+        )
+        objects
+        program
+        (mkWorldProperties
+          2
+          0.16
+          (V3 0 1 0)
+        )
   modelRef <- newIORef model
 
-  -- add key callback with io ref to model
+  -- add callbacks with io ref to model
   GLFW.setKeyCallback window $ Just $ keyPressed $ Just modelRef
+  GLFW.setCursorPosCallback window $ Just $ cursorPosHandler $ Just modelRef
 
-  loop window update view modelRef
+  loop window (update 0) view modelRef
 
 --------------------------------------------------------------------------------
 -- Arrays
@@ -122,9 +137,11 @@ vertShader =
   "layout (location = 0) in vec3 a_vPos;\n" ++
   "uniform mat4 u_view;\n" ++
   "uniform mat4 u_projection;\n" ++
+  "out vec3 v_pos;\n" ++
   "void main()\n" ++
   "{\n" ++
   "  gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n" ++
+  "  v_pos = a_vPos;\n" ++
   "}"
   
 -- | fragment shader
@@ -132,9 +149,10 @@ fragShader :: String
 fragShader =
   "#version 330 core\n" ++
   "out vec4 o_vColor;\n" ++
+  "in vec3 v_pos;\n" ++
   "void main()\n" ++
   "{\n" ++
-  "  o_vColor = vec4(0.5, 0.5, 0.5, 1.0);\n" ++
+  "  o_vColor = vec4(0.5 + 0.5 * v_pos, 1);\n" ++
   "}"
 
 --------------------------------------------------------------------------------
@@ -200,14 +218,6 @@ createObject array numComponents primitiveMode = do
       primitiveMode
     )
 
--- | represents a single draw call
-data Object =
-  Object
-    GL.VertexArrayObject
-    GL.NumArrayIndices
-    GL.NumComponents
-    GL.PrimitiveMode
-
 --------------------------------------------------------------------------------
 -- Elm-like data structures
 --------------------------------------------------------------------------------
@@ -224,90 +234,135 @@ loop window update view modelRef = do
   Just frameStart <- GLFW.getTime
 
   -- tick model
-  model <- readIORef modelRef
-  let model' = update model
-  writeIORef modelRef model'
+  modifyIORef' modelRef $ update
+  model' <- readIORef modelRef
 
   -- view new model
   view window model'
 
+  putStrLn $ (++) "pitch" $ show model'.camera.camPitch
+  putStrLn $ (++) "yaw" $ show model'.camera.camYaw
+
   -- end frame timer, wait the difference between expected and actual
   Just frameEnd <- GLFW.getTime
   let
-    dt = frameEnd - frameStart :: Double
-    target = 1 / 30 :: Double
+    dt = double2Float $ frameEnd - frameStart
+    target = 1 / 60 :: Float
   when (dt < target) $ threadDelay $ floor $ (target - dt) * 1000000
+  Just frameEnd' <- GLFW.getTime
+  let
+    dt' = double2Float $ frameEnd' - frameStart
 
-  loop window update view modelRef
+  loop window (Game.update dt') view modelRef
 
 -- | update function
-update :: Model -> Model
-update model =
+update :: Float -> Model -> Model
+update dt model =
   updateVelocity
+    dt
     $ updateAcceleration
+      dt
+      $ updateCameraAngle
+        dt
         model
 
-updateAcceleration :: Model -> Model
-updateAcceleration model = 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 = xn - xp
+    z = zn - zp
+    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 :: Model -> Model
-updateVelocity model = model
+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
+    newPitch = model.camera.camPitch - model.camera.mouseSensitivity * dt * (double2Float $ snd model.cursorDeltaPos)
+    newPitch' = if newPitch >= (pi / 2) then (0.9999 * pi / 2) else newPitch
+    newPitch'' = if newPitch <= ((-1) * pi / 2) then ((-0.9999) * pi / 2) else newPitch
+    newYaw = model.camera.camYaw + model.camera.mouseSensitivity * dt * (double2Float $ fst model.cursorDeltaPos)
+    newYaw' = newYaw - (mod' newYaw pi)
+  in
+  model
+    { cursorDeltaPos = (0, 0)
+    , camera = model.camera
+      { camPitch = model.camera.camPitch + dt * (double2Float $ snd model.cursorDeltaPos)
+      , camYaw = model.camera.camYaw + dt * (double2Float $ fst model.cursorDeltaPos)
+      }
+    }
 
 -- | updates given a keypress. escape case is probably caught by GLFW in the
 -- handler function itself
 updateKeyPressed :: GLFW.Key -> Model -> Model
-updateKeyPressed
-  key
-  (Model
-    objects
-    camera
-    program
-    keys
-    wprops
-  ) =
-  Model
-    objects
-    camera
-    program
-    (nub $ key:keys)
-    wprops
+updateKeyPressed key model =
+  model { keys = key:model.keys }
 
 -- | updates given a keyrelease. escape case is probably caught by GLFW in the
 -- handler function itself
 updateKeyReleased :: GLFW.Key -> Model -> Model
-updateKeyReleased
-  key
-  (Model
-    objects
-    camera
-    program
-    keys
-    wprops
-  ) =
-  Model
-    objects
-    camera
-    program
-    (delete key keys)
-    wprops
+updateKeyReleased key model =
+  model { keys = (delete key model.keys) }
+
+applyToTuples :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
+applyToTuples f (x, y) (a, b) = (f x a, f y b)
+
+-- | updates cursor
+updateCursorPos :: Double -> Double -> Model ->  Model
+updateCursorPos x y model =
+  model
+    { cursorPos = (x, y)
+    , cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y)
+    }
 
 -- | views the model
 view :: GLFW.Window -> Model -> IO ()
-view
-  window
-  (model@(Model
-    objects
-    (Camera
-      camPos
-      camTarget
-      camUp
-      velocity
-    )
-    program
-    _
-    _
-  )) = do
+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))
@@ -318,19 +373,24 @@ view
 
   -- apply transforms
   let
-    viewMatrix = L.lookAt camPos camTarget camUp
-    projectionMatrix = L.perspective 1.4 (fromIntegral w / fromIntegral h) 0.1 100
+    yaw = (L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) model.camera.camReference)
+    viewMatrix =
+      L.lookAt
+        model.camera.camPos
+        (model.camera.camPos + L.rotate (L.axisAngle (L.cross model.wprop.up yaw) model.camera.camPitch) yaw)
+        model.wprop.up
+    projectionMatrix = L.perspective 1.5 (fromIntegral w / fromIntegral h) 0.1 100
 
   viewGLMatrix <- GL.newMatrix GL.RowMajor $ toGLMatrix viewMatrix :: IO (GL.GLmatrix GL.GLfloat)
-  viewLocation <- GL.get $ GL.uniformLocation program "u_view"
+  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 program "u_projection"
+  projectionLocation <- GL.get $ GL.uniformLocation model.program "u_projection"
   GL.uniform projectionLocation $= projectionGLMatrix
 
   -- draw objects
-  drawObjects objects
+  drawObjects model.objects
 
   -- swap to current buffer
   GLFW.swapBuffers window
@@ -338,41 +398,6 @@ view
   -- check for interrupts
   GLFW.pollEvents
 
-toGLMatrix :: L.M44 GL.GLfloat -> [GL.GLfloat]
-toGLMatrix
-  (V4
-    (V4 c00 c01 c02 c03)
-    (V4 c10 c11 c12 c13)
-    (V4 c20 c21 c22 c23)
-    (V4 c30 c31 c32 c33)) =
-  [ c00, c01, c02, c03
-  , c10, c11, c12, c13
-  , c20, c21, c22, c23
-  , c30, c31, c32, c33
-  ]
-
--- | gamestate
-data Model =
-  Model
-    [Object]
-    Camera
-    GL.Program
-    [GLFW.Key]
-    WorldProperties
-
--- | camera
-data Camera =
-  Camera
-    (V3 Float) -- ^ camera location
-    (V3 Float) -- ^ camera target
-    (V3 Float) -- ^ camera up vector
-    (V3 Float) -- ^ velocity
-
-data WorldProperties =
-  WorldProperties
-    Float -- ^ gravity `g`
-    Float -- ^ floor friction
-
 -- | draws objects
 drawObjects :: [Object] -> IO ([Object])
 drawObjects [] = return []
@@ -405,3 +430,9 @@ keyPressed (Just modelRef) window key _ GLFW.KeyState'Pressed _ =
 keyPressed (Just modelRef) window key _ GLFW.KeyState'Released _ =
   modifyIORef' modelRef $ updateKeyReleased key
 keyPressed _ _ _ _ _ _ = return ()
+
+-- | handles cursor position updates
+cursorPosHandler :: Maybe (IORef Model) -> GLFW.CursorPosCallback
+cursorPosHandler (Just modelRef) _ x y =
+  modifyIORef' modelRef $ updateCursorPos x y
+cursorPosHandler Nothing _ _ _ = return ()

src/Game/Types.hs

@@ -0,0 +1,128 @@
+{-# LANGUAGE NamedFieldPuns, OverloadedRecordDot #-}
+{- |
+ - Module      : Game.Types
+ - Description : 
+ - Copyright   : Andromeda 2025
+ - License     : WTFPL
+ - Maintainer  : Matrix @Andromeda:tchncs.de
+ - Stability   : Experimental
+ -}
+module Game.Types
+  ( Object(..)
+
+  , toGLMatrix
+
+  , Model (objects, camera, cursorDeltaPos, cursorPos, program, keys, wprop)
+  , mkModel
+
+  , Camera (camPos, camPitch, camYaw, camReference, mouseSensitivity, camVel, strafeStrength, jumpStrength, hasJumped, airTime)
+  , mkCamera
+
+  , WorldProperties (g, friction, up)
+  , mkWorldProperties
+
+  ) where
+
+import qualified Graphics.UI.GLFW          as GLFW
+import qualified Graphics.Rendering.OpenGL as GL
+
+import qualified Linear as L
+import           Linear      (Quaternion, V3, V3(..), V4(..))
+
+-- | represents a single draw call
+data Object =
+  Object
+    { vao :: GL.VertexArrayObject
+    , numIndicies :: GL.NumArrayIndices
+    , numComponents :: GL.NumComponents
+    , primitiveMode :: GL.PrimitiveMode
+    }
+    deriving Show
+
+toGLMatrix :: L.M44 GL.GLfloat -> [GL.GLfloat]
+toGLMatrix
+  (V4
+    (V4 c00 c01 c02 c03)
+    (V4 c10 c11 c12 c13)
+    (V4 c20 c21 c22 c23)
+    (V4 c30 c31 c32 c33)) =
+  [ c00, c01, c02, c03
+  , c10, c11, c12, c13
+  , c20, c21, c22, c23
+  , c30, c31, c32, c33
+  ]
+
+-- | gamestate
+data Model =
+  Model
+    { camera :: Camera
+    , cursorDeltaPos :: (Double, Double)
+    , cursorPos :: (Double, Double)
+    , keys :: [GLFW.Key]
+    , objects :: [Object]
+    , program :: GL.Program
+    , wprop :: WorldProperties
+    }
+    deriving Show
+
+mkModel :: Camera -> [Object] -> GL.Program -> WorldProperties -> Model
+mkModel camera objects program wprop = Model camera (0,0) (0,0) [] objects program wprop
+
+-- | camera
+data Camera =
+  Camera
+    { camPos :: V3 Float
+    , camPitch :: Float
+    , camYaw :: Float
+    , camReference :: V3 Float
+    , camVel :: V3 Float
+    , mouseSensitivity :: Float
+    , strafeStrength :: Float
+    , jumpStrength :: Float
+    , hasJumped :: Bool
+    , airTime :: Float
+    }
+    deriving Show
+
+mkCamera
+  :: V3 Float
+  -> Float
+  -> Float
+  -> V3 Float
+  -> V3 Float
+  -> Float
+  -> Float
+  -> Float
+  -> Camera
+mkCamera
+  camPos
+  camPitch
+  camYaw
+  camReference
+  camVel
+  mouseSensitivity
+  strafeStrength
+  jumpStrength =
+  Camera
+    camPos
+    camPitch
+    camYaw
+    (L.normalize camReference)
+    (L.normalize camVel)
+    mouseSensitivity
+    strafeStrength
+    jumpStrength
+    False
+    0
+
+data WorldProperties =
+  WorldProperties
+    { g :: Float -- ^ gravity `g`
+    , friction :: Float -- ^ floor friction
+    , up :: V3 Float
+    }
+    deriving Show
+
+mkWorldProperties :: Float -> Float -> V3 Float-> WorldProperties
+mkWorldProperties g friction up =
+  WorldProperties g friction (L.normalize up)