merge development into master

.gitignore

@@ -0,0 +1,2 @@
+dist-newstyle
+result

CHANGELOG.md

@@ -20,6 +20,42 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 - use `Double` rather than `FLoat` for internal calculations
     - `cursorPos`, `dt` natively `Double` already
 
+## [0.4.0] - 2025-12-21
+
+### Added
+
+- cube as array of points
+- debug feature where `t` and `g` raise and lower speed respectively
+
+### Changed
+
+- `initResources` now takes `[[V3 GL.GLfloat]]` rather than `[V3 GL.GLfloat]`
+    - to migrate: rather than passing `a` pass `[a]`; behaviour is the same
+- reduce view distance to 1'000 from 10'000
+- color pixels based on normalized coordinates
+- use `haskellPackages.callCabal2nix` in `flake.nix` for brevity, same behaviour
+
+## [0.3.0] - 2025-12-08
+
+### Added
+
+- Cabal build system
+- `.gitignore` against build artifacts
+
+### Changed
+
+- versioning using the [PVP standard](https://pvp.haskell.org/), though it will remain SemVer compliant
+    - SemVer version A.B.C will become PVP version A.B.C.0
+- `README.md` overhauled to reflect new build system
+
+### Fixed
+
+- a couple non-impactful typos
+
+### Removed
+
+- `Game` module -> moved to `Main`
+
 ## [0.2.1] - 2025-12-08
 
 ### Changed

README.md

@@ -1,21 +1,30 @@
-to run:
+see CHANGELOG.md
 
-```bash
+to run without nix:
-git clone https://git.mtgmonkey.net/Andromeda/hs-game
+- get build tools:
-cd hs-game
+    - with apt: `apt install cabal-install ghc git`
-nix run
+- get source code: `git clone https://git.mtgmonkey.net/Andromeda/hs-game --depth 1; cd hs-game`
-```
+- get dependencies
+    - with apt on x86-64: `apt install g++-x86-64_linux-gnu libgl-dev libx11-dev libxi-dev libxrandr-dev libxxf86vm-dev libxcursor-dev libxinerama-dev libglu1-mesa-dev`
+- run with `cabal run` or build with `cabal build`
+
+to run with nix:
+`nix run git+https://git.mtgmonkey.net/Andromeda/hs-game`
+
+to enter nix development shell:
+`nix develop git+https://git.mtgmonkey.net/Andromeda/hs-game`
+
+build tested on
+- nix
+- Kubuntu 25.10
 
 to release:
-
+- update CHANGELOG.md with new version
-```bash
+- update version in hs-game.cabal
-nix build .#release
+- update version in flake.nix
-```
+- check that it builds
-
+- `git add -A`
-to debug build:
+- `git status` make sure there aren't random files
-
+- `git status -v` make sure all additions are in CHANGELOG.md
-```bash
+- double check that flake, .cabal, and CHANGELOG.md all have the same version
-nix build .#debug
+- release
-```
-
-todo moved to CHANGELOG.md

flake.nix

@@ -2,70 +2,33 @@
   inputs = {
     nixpkgs.url = "nixpkgs/nixpkgs-unstable";
   };
-  outputs = {nixpkgs, ...}: let
+  outputs = {
+    nixpkgs,
+    self,
+    ...
+  }: let
     system = "x86_64-linux";
     pkgs = nixpkgs.legacyPackages.${system};
-    debugGhcOptions = pkgs.lib.concatStringsSep " " (debugGhcFlags ++ commonGhcFlags);
-    debugGhcFlags = [
-      "-O0"
-      "-Wall"
-      "-Widentities"
-      "-Wincomplete-record-updates"
-      "-Wincomplete-uni-patterns"
-      # "-Wmissing-export-lists"
-      "-Wmissing-home-modules"
-      "-Wpartial-fields"
-      "-Wredundant-constraints"
-      "-threaded"
-      "-rtsopts"
-      "-with-rtsopts=-N"
-      "-main-is Game"
-    ];
-    haddockOptions = pkgs.lib.concatStringsSep " " haddockFlags;
-    haddockFlags = [
-      "--html"
-      "--odir docs"
-      "--optghc=-i./src"
-      "src/Game.hs"
-    ];
-    releaseGhcOptions = pkgs.lib.concatStringsSep " " (releaseGhcFlags ++ commonGhcFlags);
-    releaseGhcFlags = [
-      "-O2"
-      "-threaded"
-      "-rtsopts"
-      "-with-rtsopts=-N"
-      "-main-is Game"
-    ];
-    noHaddockOptions = "";
-    commonGhcFlags = [
-      "-i./src"
-    ];
-    ghcPackages = p: [
-      p.GLFW-b
-      p.linear
-      p.OpenGL
-    ];
   in {
     packages.${system} = {
-      debug = pkgs.callPackage ./package.nix {
+      default = pkgs.haskellPackages.callCabal2nix "hs-game" ./. {};
-        ghcOptions = debugGhcOptions;
-        haddockOptions = noHaddockOptions;
-        inherit ghcPackages;
     };
-      release = pkgs.callPackage ./package.nix {
+    devShells.${system} = {
-        ghcOptions = releaseGhcOptions;
+      default = pkgs.mkShell {
-        haddockOptions = noHaddockOptions;
+        packages = [
-        inherit ghcPackages;
+          pkgs.cabal-install
-      };
+          pkgs.libGL
-      docs = pkgs.callPackage ./package.nix {
+          pkgs.xorg.libX11
-        ghcOptions = "--version";
+          pkgs.xorg.libXi
-        inherit haddockOptions;
+          pkgs.xorg.libXrandr
-        inherit ghcPackages;
+          pkgs.xorg.libXxf86vm
-      };
+          pkgs.xorg.libXcursor
-      default = pkgs.callPackage ./package.nix {
+          pkgs.xorg.libXinerama
-        ghcOptions = releaseGhcOptions;
+          pkgs.libGLU
-        inherit haddockOptions;
+        ];
-        inherit ghcPackages;
+        inputsFrom = [
+          self.packages.${system}.default
+        ];
       };
     };
   };

hs-game.cabal

@@ -0,0 +1,38 @@
+cabal-version:      3.0
+name:               hs-game
+version:            0.4.0
+-- synopsis:
+-- description:
+homepage:           https://git.mtgmonkey.net/Andromeda/hs-game
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             andromeda
+maintainer:         @andromeda:tchncs.de
+-- copyright:
+category:           Game
+build-type:         Simple
+extra-doc-files:    CHANGELOG.md
+-- extra-source-files:
+
+common warnings
+    ghc-options: -Wall
+
+common optimizations
+    ghc-options: -O2
+
+executable hs-game
+    import:           optimizations
+    main-is:          Main.hs
+    other-modules:
+        Game.Internal,
+        Game.Internal.LoadShaders,
+        Game.Internal.Types
+    -- other-extensions:
+    build-depends:
+        base       >= 4.18,
+        bytestring >= 0.12,
+        GLFW-b     >= 3.3,
+        lens       >= 5.3,
+        linear     >= 1.23,
+        OpenGL     >= 3.0,
+    hs-source-dirs:   src

package.nix

@@ -1,39 +0,0 @@
-{
-  haskellPackages,
-  lib,
-  stdenv,
-  ghcOptions,
-  haddockOptions,
-  ghcPackages,
-  ...
-}:
-stdenv.mkDerivation {
-  pname = "hs-game";
-  version = "0.1.0";
-  src = ./.;
-  nativeBuildInputs = [
-    (haskellPackages.ghcWithPackages ghcPackages)
-  ];
-  buildInputs = [
-  ];
-  configurePhase = ''
-  '';
-  buildPhase = ''
-    touch Main
-    ghc ${ghcOptions} ./src/Game.hs -o ./Main
-    mkdir ./docs
-    haddock ${haddockOptions}
-  '';
-  installPhase = ''
-    mkdir -p $out/bin
-    cp ./Main $out/bin/hs-game
-    cp ./docs $out/docs -r
-  '';
-
-  meta = {
-    homepage = "https://mtgmonkey.net";
-    license = lib.licenses.bsd3;
-    mainProgram = "hs-game";
-    platforms = ["x86_64-linux"];
-  };
-}

src/Game.hs

@@ -1,223 +0,0 @@
-{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
-{- |
- - Module      : Game
- - Description : runs game
- - Copyright   : 2025 Andromeda
- - License     : BSD 3-clause
- - 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

src/Game/Internal.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
+
 {- |
  - Module      : Game.Internal
  - Description : internal functions
@@ -18,8 +19,7 @@ module Game.Internal
   , updateCursorPos
   , updateKeyPressed
   , updateKeyReleased
-  )
+  ) where
-  where
 
 import Game.Internal.LoadShaders
 import Game.Internal.Types
@@ -30,79 +30,78 @@ import Data.IORef            (IORef, modifyIORef', readIORef)
 import Data.List (delete)
 import Foreign.Marshal.Array (withArray)
 import Foreign.Ptr (nullPtr, plusPtr)
-import Foreign.Storable      (sizeOf, Storable)
+import Foreign.Storable (Storable, sizeOf)
 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 Linear (V3(..))
 
 --------------------------------------------------------------------------------
 -- Shader creation and object initialisation
 --------------------------------------------------------------------------------
-
 -- | loads models, shaders
-initResources :: [V3 GL.GLfloat] -> IO ([Object], GL.Program)
+initResources :: [[V3 GL.GLfloat]] -> IO ([Object], GL.Program)
-initResources array = do
+initResources arrays = do
   -- create objects
-  testObject0 <- createObject (map (+(V3 (-1) (-1) (-1))) array) 3 GL.TriangleStrip
+  objects <- listIOsToIOlist [ createObject arr 3 GL.TriangleStrip | arr <- arrays ] []
-  testObject1 <- createObject (map (+(V3 (1) (1) (1))) array) 3 GL.TriangleStrip
-  testObject2 <- createObject array 3 GL.TriangleStrip
-  let objects = [testObject0, testObject1, testObject2]
-
   -- load shaders
-  program <- loadShaders
+  program <-
+    loadShaders
       [ ShaderInfo GL.VertexShader (StringSource vertShader)
       , ShaderInfo GL.FragmentShader (StringSource fragShader)
       ]
   GL.currentProgram $= Just program
-
   return (objects, program)
 
+listIOsToIOlist :: [IO a] -> [a] -> IO [a]
+listIOsToIOlist [] out = return out
+listIOsToIOlist (io:ios) out = do
+  ioVal <- io
+  listIOsToIOlist ios (ioVal:out)
+
 -- a_ vertex shader input
 -- v_ varying
 -- u_ uniform
 -- o_ fragment shader output
-
 -- | vertex shader
 vertShader :: String
 vertShader =
-  "#version 330 core\n" ++
+  "#version 330 core\n"
-  "layout (location = 0) in vec3 a_vPos;\n" ++
+    ++ "layout (location = 0) in vec3 a_vPos;\n"
-  "uniform mat4 u_view;\n" ++
+    ++ "uniform mat4 u_view;\n"
-  "uniform mat4 u_projection;\n" ++
+    ++ "uniform mat4 u_projection;\n"
-  "out vec3 v_pos;\n" ++
+    ++ "out vec3 v_pos;\n"
-  "void main()\n" ++
+    ++ "void main()\n"
-  "{\n" ++
+    ++ "{\n"
-  "  gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n" ++
+    ++ "  gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n"
-  "  v_pos = a_vPos;\n" ++
+    ++ "  v_pos = a_vPos;\n"
-  "}"
+    ++ "}"
 
 -- | fragment shader
 fragShader :: String
 fragShader =
-  "#version 330 core\n" ++
+  "#version 330 core\n"
-  "out vec4 o_vColor;\n" ++
+    ++ "out vec4 o_vColor;\n"
-  "in vec3 v_pos;\n" ++
+    ++ "in vec3 v_pos;\n"
-  "void main()\n" ++
+    ++ "void main()\n"
-  "{\n" ++
+    ++ "{\n"
-  "  o_vColor = vec4(0.5 + 0.5 * v_pos, 1);\n" ++
+    ++ "  o_vColor = vec4(0.5 + 0.5 * normalize(v_pos), 1);\n"
-  "}"
+    ++ "}"
 
 --------------------------------------------------------------------------------
 -- Objects
 --------------------------------------------------------------------------------
-
 -- | calculates the size in memory of an array
 sizeOfArray :: (Storable a, Num b) => [a] -> b
 sizeOfArray [] = 0
 sizeOfArray (x:xs) = fromIntegral $ (*) (1 + length xs) $ sizeOf x
 
 -- | loads a given array into a given attribute index
-createVBO
+createVBO ::
-  :: Storable (a GL.GLfloat)
+     Storable (a GL.GLfloat)
   => [a GL.GLfloat]
   -> GL.NumComponents
   -> GL.AttribLocation
@@ -111,29 +110,19 @@ createVBO array numComponents attribLocation = do
   -- vbo for buffer
   buffer <- GL.genObjectName
   GL.bindBuffer GL.ArrayBuffer $= Just buffer
-
   -- populate buffer
-  withArray
+  withArray array $ \ptr ->
-    array
-    $ \ptr ->
     GL.bufferData GL.ArrayBuffer $= (sizeOfArray array, ptr, GL.StaticDraw)
-
   -- create attribute pointer to buffer
-  GL.vertexAttribPointer attribLocation $=
+  GL.vertexAttribPointer attribLocation
-    ( GL.ToFloat
+    $= ( GL.ToFloat
-    , GL.VertexArrayDescriptor
+       , GL.VertexArrayDescriptor numComponents GL.Float 0 (plusPtr nullPtr 0))
-        numComponents
-        GL.Float
-        0
-        (plusPtr nullPtr 0)
-    )
   GL.vertexAttribArray attribLocation $= GL.Enabled
-
   return buffer
 
 -- | creates an object from a given array; deals with vbos and everything
-createObject
+createObject ::
-  :: Storable (a GL.GLfloat)
+     Storable (a GL.GLfloat)
   => [a GL.GLfloat]
   -> GL.NumComponents
   -> GL.PrimitiveMode
@@ -142,25 +131,16 @@ createObject array numComponents primitiveMode = do
   -- vao for object
   vao <- GL.genObjectName
   GL.bindVertexArrayObject $= Just vao
-
   -- vbo for vertices
   _ <- createVBO array numComponents $ GL.AttribLocation 0
-
+  return (Object vao (fromIntegral $ length array) numComponents primitiveMode)
-  return
-    (Object
-      vao
-      (fromIntegral $ length array)
-      numComponents
-      primitiveMode
-    )
 
 --------------------------------------------------------------------------------
 -- Elm-like data structures
 --------------------------------------------------------------------------------
-
 -- | gameloop
-loop
+loop ::
-  :: GLFW.Window -- ^ window to display on
+     GLFW.Window -- ^ window to display on
   -> Float -- ^ dt
   -> (Float -> Model -> Model) -- ^ update function
   -> (GLFW.Window -> Model -> IO ()) -- ^ view function
@@ -169,37 +149,29 @@ loop
 loop window dt update view modelRef = do
   -- start frame timer
   Just frameStart <- GLFW.getTime
-
   -- tick model
   modifyIORef' modelRef $ update dt
   model' <- readIORef modelRef
-
   -- view new model
   view window model'
-
   -- end frame timer, wait the difference between expected and actual
   Just frameEnd <- GLFW.getTime
-  let
+  let drawTime = double2Float $ frameEnd - frameStart
-    drawTime = double2Float $ frameEnd - frameStart
       target = 1 / 60 :: Float
   when (drawTime < target) $ threadDelay $ floor $ (target - drawTime) * 1000000
   Just frameEnd' <- GLFW.getTime
-  let
+  let dt' = double2Float $ frameEnd' - frameStart
-    dt' = double2Float $ frameEnd' - frameStart
-
   loop window dt' update view modelRef
 
 -- | updates given a keypress. escape case is probably caught by GLFW in the
 -- handler function itself
 updateKeyPressed :: GLFW.Key -> Model -> Model
-updateKeyPressed key model =
+updateKeyPressed key model = model {keys = key : model.keys}
-  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 =
+updateKeyReleased key model = model {keys = (delete key model.keys)}
-  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)
@@ -207,24 +179,20 @@ applyToTuples f (x, y) (a, b) = (f x a, f y b)
 -- | updates cursor
 updateCursorPos :: Double -> Double -> Model -> Model
 updateCursorPos x y model =
-  let
+  let pyth =
-    pyth = (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos - y)) ** 2) ** 0.5
+        (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos) - y) ** 2)
-  in
+          ** 0.5
-  if pyth < 16 then
+   in if pyth < 16
-    model
+        then model
                { cursorPos = (x, y)
                , cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y)
                }
-  else 
+        else model {cursorPos = (x, y)}
-    model
-      { cursorPos = (x, y)
-      }
 
 -- | draws objects
 drawObjects :: [Object] -> IO ([Object])
 drawObjects [] = return []
-drawObjects
+drawObjects ((Object vao numVertices _ primitiveMode):objects) = do
-  ((Object vao numVertices _ primitiveMode):objects) = do
   GL.bindVertexArrayObject $= Just vao
   GL.drawArrays primitiveMode 0 numVertices
   drawObjects objects
@@ -232,7 +200,6 @@ drawObjects
 --------------------------------------------------------------------------------
 -- interrupts
 --------------------------------------------------------------------------------
-
 -- | shuts down GLFW
 shutdownWindow :: GLFW.WindowCloseCallback
 shutdownWindow window = do

src/Game/Internal/LoadShaders.hs

@@ -12,9 +12,10 @@
 -- Red Book Authors.
 --
 --------------------------------------------------------------------------------
-
+module Game.Internal.LoadShaders
-module Game.Internal.LoadShaders (
+  ( ShaderSource(..)
-   ShaderSource(..), ShaderInfo(..), loadShaders
+  , ShaderInfo(..)
+  , loadShaders
   ) where
 
 import Control.Exception
@@ -23,11 +24,9 @@ import qualified Data.ByteString as B
 import Graphics.Rendering.OpenGL
 
 --------------------------------------------------------------------------------
-
 -- | The source of the shader source code.
-
+data ShaderSource
-data ShaderSource =
+  = ByteStringSource B.ByteString
-     ByteStringSource B.ByteString
      -- ^ The shader source code is directly given as a 'B.ByteString'.
   | StringSource String
      -- ^ The shader source code is directly given as a 'String'.
@@ -41,17 +40,14 @@ getSource (StringSource str) = return $ packUtf8 str
 getSource (FileSource path) = B.readFile path
 
 --------------------------------------------------------------------------------
-
 -- | A description of a shader: The type of the shader plus its source code.
-
+data ShaderInfo =
-data ShaderInfo = ShaderInfo ShaderType ShaderSource
+  ShaderInfo ShaderType ShaderSource
   deriving (Eq, Ord, Show)
 
 --------------------------------------------------------------------------------
-
 -- | Create a new program object from the given shaders, throwing an
 -- 'IOException' if something goes wrong.
-
 loadShaders :: [ShaderInfo] -> IO Program
 loadShaders infos =
   createProgram `bracketOnError` deleteObjectName $ \program -> do
@@ -75,7 +71,8 @@ loadCompileAttach program (ShaderInfo shType source : infos) =
 compileAndCheck :: Shader -> IO ()
 compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile"
 
-checked :: (t -> IO ())
+checked ::
+     (t -> IO ())
   -> (t -> GettableStateVar Bool)
   -> (t -> GettableStateVar String)
   -> String

src/Game/Internal/Types.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE NamedFieldPuns, OverloadedRecordDot #-}
+
 {- |
  - Module      : Game.Internal.Types
  - Description : 
@@ -9,70 +10,52 @@
  -}
 module Game.Internal.Types
   ( Object(..)
-
   , toGLMatrix
-
+  , Model(camera, objects, cursorDeltaPos, cursorPos, program, keys, wprop)
-  , Model ( camera
-          , objects
-          , cursorDeltaPos
-          , cursorPos
-          , program
-          , keys
-          , wprop
-          )
   , mkModel
-
+  , Camera(camPos, camPitch, camYaw, camReference, mouseSensitivity, camVel, strafeStrength, jumpStrength, hasJumped, airTime)
-  , 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 Graphics.UI.GLFW as GLFW
 
 import qualified Linear as L
 import Linear (V3, V3(..), V4(..))
 
 -- | represents a single draw call
-data Object =
+data Object = Object
-  Object
   { vao :: GL.VertexArrayObject -- ^ vao of vertex buffer
   , numIndicies :: GL.NumArrayIndices -- ^ number of vertices
   , numComponents :: GL.NumComponents -- ^ dimensionallity; vec3, vec4, etc.
   , primitiveMode :: GL.PrimitiveMode -- ^ primitive mode to be drawn with
-    }
+  } deriving (Show)
-    deriving Show
 
 -- | converts M44 to a 16array for OpenGL
 toGLMatrix :: L.M44 GL.GLfloat -> [GL.GLfloat]
-toGLMatrix
+toGLMatrix (V4 (V4 c00 c01 c02 c03) (V4 c10 c11 c12 c13) (V4 c20 c21 c22 c23) (V4 c30 c31 c32 c33)) =
-  (V4
+  [ c00
-    (V4 c00 c01 c02 c03)
+  , c01
-    (V4 c10 c11 c12 c13)
+  , c02
-    (V4 c20 c21 c22 c23)
+  , c03
-    (V4 c30 c31 c32 c33)) =
+  , c10
-  [ c00, c01, c02, c03
+  , c11
-  , c10, c11, c12, c13
+  , c12
-  , c20, c21, c22, c23
+  , c13
-  , c30, c31, c32, c33
+  , c20
+  , c21
+  , c22
+  , c23
+  , c30
+  , c31
+  , c32
+  , c33
   ]
 
 -- | gamestate
-data Model =
+data Model = Model
-  Model
   { camera :: Camera
   , cursorDeltaPos :: (Double, Double) -- ^ frame-on-frame delta mouse position
   , cursorPos :: (Double, Double) -- ^ current mouse position
@@ -80,29 +63,15 @@ data Model =
   , objects :: [Object] -- ^ draw calls
   , program :: GL.Program -- ^ shader program
   , wprop :: WorldProperties
-    }
+  } deriving (Show)
-    deriving Show
 
 -- | smart constructor for Model
-mkModel
+mkModel :: Camera -> [Object] -> GL.Program -> WorldProperties -> Model
-  :: Camera
-  -> [Object]
-  -> GL.Program
-  -> WorldProperties
-  -> Model
 mkModel camera objects program wprop =
-  Model
+  Model camera (0, 0) (0, 0) [] objects program wprop
-    camera
-    (0,0)
-    (0,0)
-    []
-    objects
-    program
-    wprop
 
 -- | camera
-data Camera =
+data Camera = Camera
-  Camera
   { camPos :: V3 Float -- ^ position in world space
   , camPitch :: Float -- ^ pitch in radians, up positive
   , camYaw :: Float -- ^ yaw in radians, right positive
@@ -113,12 +82,11 @@ data Camera =
   , jumpStrength :: Float -- ^ scale factor for jump initial velocity
   , hasJumped :: Bool -- ^ whether the camera still has jumping state
   , airTime :: Float -- ^ time since jumping state entered in seconds
-    }
+  } deriving (Show)
-    deriving Show
 
 -- | smart constructor for Camera
-mkCamera
+mkCamera ::
-  :: V3 Float
+     V3 Float
   -> Float
   -> Float
   -> V3 Float
@@ -127,15 +95,7 @@ mkCamera
   -> Float
   -> Float
   -> Camera
-mkCamera
+mkCamera camPos camPitch camYaw camReference camVel mouseSensitivity strafeStrength jumpStrength =
-  camPos
-  camPitch
-  camYaw
-  camReference
-  camVel
-  mouseSensitivity
-  strafeStrength
-  jumpStrength =
   Camera
     camPos
     camPitch
@@ -149,15 +109,12 @@ mkCamera
     0
 
 -- | physical properties of the world
-data WorldProperties =
+data WorldProperties = WorldProperties
-  WorldProperties
   { g :: Float -- ^ gravity `g`
   , friction :: Float -- ^ scale factor for floor friction
   , up :: V3 Float -- ^ global up vector
-    }
+  } deriving (Show)
-    deriving Show
 
 -- | smart constructor for WorldProperties
 mkWorldProperties :: Float -> Float -> V3 Float -> WorldProperties
-mkWorldProperties g friction up =
+mkWorldProperties g friction up = WorldProperties g friction (L.normalize up)
-  WorldProperties g friction (L.normalize up)

src/Main.hs

@@ -0,0 +1,286 @@
+{-# 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