Merge branch 'master' into development

.gitignore

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

CHANGELOG.md

@@ -20,50 +20,7 @@ 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
+## [0.2.0-pre0] - 2025-12-07
-
-### 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
-
-- break Git by using it wrong
-- fix Git (maybe)
-
-## [0.2.0] - 2025-12-07
 
 ### Added
 

README.md

@@ -1,30 +1,21 @@
-see CHANGELOG.md
+to run:
 
-to run without nix:
+```bash
-- get build tools:
+git clone https://git.mtgmonkey.net/Andromeda/hs-game
-    - with apt: `apt install cabal-install ghc git`
+cd hs-game
-- get source code: `git clone https://git.mtgmonkey.net/Andromeda/hs-game --depth 1; cd hs-game`
+nix run
-- 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
+
-- update version in hs-game.cabal
+```bash
-- update version in flake.nix
+nix build .#release
-- check that it builds
+```
-- `git add -A`
+
-- `git status` make sure there aren't random files
+to debug build:
-- `git status -v` make sure all additions are in CHANGELOG.md
+
-- double check that flake, .cabal, and CHANGELOG.md all have the same version
+```bash
-- release
+nix build .#debug
+```
+
+todo moved to CHANGELOG.md

flake.nix

@@ -2,39 +2,70 @@
   inputs = {
     nixpkgs.url = "nixpkgs/nixpkgs-unstable";
   };
-  outputs = {
+  outputs = {nixpkgs, ...}: let
-    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} = {
-      default =
+      debug = pkgs.callPackage ./package.nix {
-        pkgs.haskell.packages.ghc912.callCabal2nix "hs-game" ./. {
+        ghcOptions = debugGhcOptions;
-        };
+        haddockOptions = noHaddockOptions;
-    };
+        inherit ghcPackages;
-    devShells.${system} = {
+      };
-      default = pkgs.mkShell {
+      release = pkgs.callPackage ./package.nix {
-        packages = [
+        ghcOptions = releaseGhcOptions;
-          # dev stuff
+        haddockOptions = noHaddockOptions;
-          pkgs.haskellPackages.ghcide
+        inherit ghcPackages;
-          pkgs.haskellPackages.ormolu
+      };
-
+      docs = pkgs.callPackage ./package.nix {
-          pkgs.cabal-install
+        ghcOptions = "--version";
-          pkgs.libGL
+        inherit haddockOptions;
-          pkgs.xorg.libX11
+        inherit ghcPackages;
-          pkgs.xorg.libXi
+      };
-          pkgs.xorg.libXrandr
+      default = pkgs.callPackage ./package.nix {
-          pkgs.xorg.libXxf86vm
+        ghcOptions = releaseGhcOptions;
-          pkgs.xorg.libXcursor
+        inherit haddockOptions;
-          pkgs.xorg.libXinerama
+        inherit ghcPackages;
-          pkgs.libGLU
-        ];
-        inputsFrom = [
-          self.packages.${system}.default
-        ];
       };
     };
   };

hs-game.cabal

@@ -1,38 +0,0 @@
-cabal-version:      3.0
-name:               hs-game
-version:            0.5.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

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

@@ -0,0 +1,223 @@
+{-# 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,155 +1,95 @@
-{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
-{-# LANGUAGE MultilineStrings #-}
+{- |
-{-# LANGUAGE NamedFieldPuns #-}
+ - Module      : Game.Internal
-{-# LANGUAGE OverloadedRecordDot #-}
+ - Description : internal functions
-
+ - Copyright   : 2025 Andromeda
--- |
+ - License     : BSD 3-clause
--- - Module      : Game.Internal
+ - Maintainer  : Matrix @Andromeda:tchncs.de
--- - Description : internal functions
+ - Stability   : Experimental
--- - Copyright   : 2025 Andromeda
+ -}
--- - License     : BSD 3-clause
--- - Maintainer  : Matrix @Andromeda:tchncs.de
--- - Stability   : Experimental
 module Game.Internal
-  ( cursorPosHandler,
+  ( cursorPosHandler
-    drawObjects,
+  , drawObjects
-    initResources,
+  , initResources
-    keyPressed,
+  , keyPressed
-    loop,
+  , loop
-    resizeWindow,
+  , resizeWindow
-    shutdownWindow,
+  , shutdownWindow
-    updateCursorPos,
+  , updateCursorPos
-    updateKeyPressed,
+  , updateKeyPressed
-    updateKeyReleased,
+  , updateKeyReleased
   )
-where
+  where
 
-import Control.Concurrent (threadDelay)
-import Control.Monad (when)
-import Data.IORef (IORef, modifyIORef', readIORef)
-import Data.List (delete)
-import Foreign.Marshal.Array (withArray)
-import Foreign.Ptr (nullPtr, plusPtr)
-import Foreign.Storable (Storable, sizeOf)
-import GHC.Float (double2Float)
 import Game.Internal.LoadShaders
 import Game.Internal.Types
-import Graphics.Rendering.OpenGL (($=))
+
+import Control.Concurrent    (threadDelay)
+import Control.Monad         (when)
+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 GHC.Float             (double2Float)
+
+import qualified Graphics.UI.GLFW          as GLFW
 import qualified Graphics.Rendering.OpenGL as GL
-import qualified Graphics.UI.GLFW as GLFW
+import           Graphics.Rendering.OpenGL as GL (($=))
-import Linear (V3 (..), V4 (..))
+
+import Linear (V3(..))
 
 --------------------------------------------------------------------------------
 -- Shader creation and object initialisation
 --------------------------------------------------------------------------------
 
-initResources :: [V4 GL.GLfloat] -> IO (Object, GL.Program)
+-- | loads models, shaders
-initResources arr = do
+initResources :: [V3 GL.GLfloat] -> IO ([Object], GL.Program)
-  object <-
+initResources array = do
-    createObject arr 4 GL.Triangles (GL.AttribLocation 0)
+  -- create objects
+  testObject0 <- createObject (map (+(V3 (-1) (-1) (-1))) array) 3 GL.TriangleStrip
+  testObject1 <- createObject (map (+(V3 (1) (1) (1))) array) 3 GL.TriangleStrip
+  testObject2 <- createObject array 3 GL.TriangleStrip
+  let objects = [testObject0, testObject1, testObject2]
 
-  -- compile shader program
+  -- load shaders
-  program <-
+  program <- loadShaders
-    loadShaders
+    [ ShaderInfo GL.VertexShader (StringSource vertShader)
-      [ ShaderInfo GL.VertexShader (StringSource vertShader),
+    , ShaderInfo GL.FragmentShader (StringSource fragShader)
-        ShaderInfo GL.FragmentShader (StringSource fragShader)
+    ]
-      ]
   GL.currentProgram $= Just program
 
-  -- alpha
+  return (objects, program)
-  GL.blend $= GL.Enabled
-  GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
-
-  return (object, 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
+  "layout (location = 0) in vec3 a_vPos;\n" ++
-
+  "uniform mat4 u_view;\n" ++
-  layout (location = 0) in vec4 a_vPos;
+  "uniform mat4 u_projection;\n" ++
-
+  "out vec3 v_pos;\n" ++
-  uniform mat4 u_view;
+  "void main()\n" ++
-  uniform mat4 u_projection;
+  "{\n" ++
-  uniform vec4 u_cam;
+  "  gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n" ++
-
+  "  v_pos = a_vPos;\n" ++
-  out vec3 v_pos;
+  "}"
-  out float v_w;
+  
-  out float v_alpha;
+-- | fragment shader
-
-  vec3 orthoFrom4d(vec4 point)
-  {
-    return point.xyz;
-  }
-
-  // creates a simple 3d coordinate from a 4d
-  vec3 projectFrom4d(vec4 point)
-  {
-    // TODO don't do camera ops in shader, prefer linear algebra
-    // also use a reasonable projection for god's sake
-    vec4 view = abs(u_cam - point);
-    float perspective = 1.0 / abs(u_cam.w - view.w);
-
-    return perspective * (point.xyz);
-  }
-
-  void main()
-  {
-    vec3 vPos = orthoFrom4d(a_vPos);
-
-    // TODO don't set constant inside of shader :/
-    float wHorizon = 3;
-    float alpha = (wHorizon - abs(u_cam.w - a_vPos.w)) / wHorizon;
-
-    // cull invisible things
-    if (alpha < -1) {
-      gl_Position = vec4(0.0);
-      alpha = 0.0;
-    } else {
-      alpha = max(alpha, 0.0);
-      gl_Position = u_projection * u_view * vec4(vPos, 1.0);
-    }
-
-    v_pos = vPos;
-    v_w = a_vPos.w;
-    v_alpha = alpha;
-  }
-  """
-
 fragShader :: String
 fragShader =
-  """
+  "#version 330 core\n" ++
-  #version 330 core
+  "out vec4 o_vColor;\n" ++
-
+  "in vec3 v_pos;\n" ++
-  uniform vec4 u_cam;
+  "void main()\n" ++
-
+  "{\n" ++
-  out vec4 o_vColor;
+  "  o_vColor = vec4(0.5 + 0.5 * v_pos, 1);\n" ++
-
+  "}"
-  in vec3 v_pos;
-  in float v_w;
-  in float v_alpha;
-
-  void main()
-  {
-    // the normal vector of the face
-    // yoinked from https://stackoverflow.com/questions/14980712/how-to-get-flat-normals-on-a-cube/14981446#14981446
-    vec3 norm = normalize(cross(dFdx(v_pos), dFdy(v_pos)));
-
-    // creates a color based on the normal direction
-    o_vColor = vec4((0.5 + 0.5 * norm) / 2, v_alpha);
-  }
-  """
 
 --------------------------------------------------------------------------------
 -- Objects
@@ -158,111 +98,133 @@ fragShader =
 -- | 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
+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] ->
+  => [a GL.GLfloat]
-  GL.NumComponents ->
+  -> GL.NumComponents
-  GL.AttribLocation ->
+  -> GL.AttribLocation
-  IO GL.BufferObject
+  -> IO GL.BufferObject
 createVBO array numComponents attribLocation = do
   -- vbo for buffer
   buffer <- GL.genObjectName
   GL.bindBuffer GL.ArrayBuffer $= Just buffer
+
   -- populate buffer
-  withArray array $ \ptr ->
+  withArray
-    GL.bufferData GL.ArrayBuffer $= (sizeOfArray array, ptr, GL.StaticDraw)
+    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 numComponents GL.Float 0 (plusPtr nullPtr 0)
+    , GL.VertexArrayDescriptor
-       )
+        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] ->
+  => [a GL.GLfloat]
-  GL.NumComponents ->
+  -> GL.NumComponents
-  GL.PrimitiveMode ->
+  -> GL.PrimitiveMode
-  GL.AttribLocation ->
+  -> IO Object
-  IO Object
+createObject array numComponents primitiveMode = do
-createObject array numComponents primitiveMode attrLocation = do
   -- vao for object
   vao <- GL.genObjectName
   GL.bindVertexArrayObject $= Just vao
+
   -- vbo for vertices
-  _ <- createVBO array numComponents attrLocation
+  _ <- 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
-  -- | window to display on
+  :: GLFW.Window -- ^ window to display on
-  GLFW.Window ->
+  -> Float -- ^ dt
-  -- | dt
+  -> (Float -> Model -> Model) -- ^ update function
-  Float ->
+  -> (GLFW.Window -> Model -> IO ()) -- ^ view function
-  -- | update function
+  -> IORef Model -- ^ model
-  (Float -> Model -> Model) ->
+  -> IO ()
-  -- | view function
-  (GLFW.Window -> Model -> IO ()) ->
-  -- | model
-  IORef Model ->
-  IO ()
 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 drawTime = double2Float $ frameEnd - frameStart
+  let
-      target = 1 / 60 :: Float
+    drawTime = double2Float $ frameEnd - frameStart
+    target = 1 / 60 :: Float
   when (drawTime < target) $ threadDelay $ floor $ (target - drawTime) * 1000000
   Just frameEnd' <- GLFW.getTime
-  let dt' = double2Float $ frameEnd' - frameStart
+  let
+    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 = model {keys = key : model.keys}
+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 = model {keys = (delete key model.keys)}
+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 :: Double -> Double -> Model ->  Model
 updateCursorPos x y model =
-  let pyth =
+  let
-        (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos) - y) ** 2)
+    pyth = (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos - y)) ** 2) ** 0.5
-          ** 0.5
+  in
-   in if pyth < 16
+  if pyth < 16 then
-        then
+    model
-          model
+      { cursorPos = (x, y)
-            { cursorPos = (x, y),
+      , cursorDeltaPos = applyToTuples (-) 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 ((Object vao numVertices _ primitiveMode) : objects) = do
+drawObjects
+  ((Object vao numVertices _ primitiveMode):objects) = do
   GL.bindVertexArrayObject $= Just vao
   GL.drawArrays primitiveMode 0 numVertices
   drawObjects objects

src/Game/Internal/LoadShaders.hs

@@ -1,7 +1,4 @@
 --------------------------------------------------------------------------------
-
---------------------------------------------------------------------------------
-
 -- |
 -- Module      :  LoadShaders
 -- Copyright   :  (c) Sven Panne 2013
@@ -13,12 +10,12 @@
 --
 -- Utilities for shader handling, adapted from LoadShaders.cpp which is (c) The
 -- Red Book Authors.
-module Game.Internal.LoadShaders
+--
-  ( ShaderSource (..),
+--------------------------------------------------------------------------------
-    ShaderInfo (..),
+
-    loadShaders,
+module Game.Internal.LoadShaders (
-  )
+   ShaderSource(..), ShaderInfo(..), loadShaders
-where
+) where
 
 import Control.Exception
 import Control.Monad
@@ -28,14 +25,15 @@ import Graphics.Rendering.OpenGL
 --------------------------------------------------------------------------------
 
 -- | The source of the shader source code.
-data ShaderSource
+
-  = -- | The shader source code is directly given as a 'B.ByteString'.
+data ShaderSource =
-    ByteStringSource B.ByteString
+     ByteStringSource B.ByteString
-  | -- | The shader source code is directly given as a 'String'.
+     -- ^ The shader source code is directly given as a 'B.ByteString'.
-    StringSource String
+   | StringSource String
-  | -- | The shader source code is located in the file at the given 'FilePath'.
+     -- ^ The shader source code is directly given as a 'String'.
-    FileSource FilePath
+   | FileSource FilePath
-  deriving (Eq, Ord, Show)
+     -- ^ The shader source code is located in the file at the given 'FilePath'.
+   deriving ( Eq, Ord, Show )
 
 getSource :: ShaderSource -> IO B.ByteString
 getSource (ByteStringSource bs) = return bs
@@ -45,20 +43,21 @@ getSource (FileSource path) = B.readFile path
 --------------------------------------------------------------------------------
 
 -- | A description of a shader: The type of the shader plus its source code.
-data ShaderInfo
+
-  = ShaderInfo ShaderType ShaderSource
+data ShaderInfo = ShaderInfo ShaderType ShaderSource
-  deriving (Eq, Ord, Show)
+   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
+   createProgram `bracketOnError` deleteObjectName $ \program -> do
-    loadCompileAttach program infos
+      loadCompileAttach program infos
-    linkAndCheck program
+      linkAndCheck program
-    return program
+      return program
 
 linkAndCheck :: Program -> IO ()
 linkAndCheck = checked linkProgram linkStatus programInfoLog "link"
@@ -66,26 +65,25 @@ linkAndCheck = checked linkProgram linkStatus programInfoLog "link"
 loadCompileAttach :: Program -> [ShaderInfo] -> IO ()
 loadCompileAttach _ [] = return ()
 loadCompileAttach program (ShaderInfo shType source : infos) =
-  createShader shType `bracketOnError` deleteObjectName $ \shader -> do
+   createShader shType `bracketOnError` deleteObjectName $ \shader -> do
-    src <- getSource source
+      src <- getSource source
-    shaderSourceBS shader $= src
+      shaderSourceBS shader $= src
-    compileAndCheck shader
+      compileAndCheck shader
-    attachShader program shader
+      attachShader program shader
-    loadCompileAttach program infos
+      loadCompileAttach program infos
 
 compileAndCheck :: Shader -> IO ()
 compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile"
 
-checked ::
+checked :: (t -> IO ())
-  (t -> IO ()) ->
+        -> (t -> GettableStateVar Bool)
-  (t -> GettableStateVar Bool) ->
+        -> (t -> GettableStateVar String)
-  (t -> GettableStateVar String) ->
+        -> String
-  String ->
+        -> t
-  t ->
+        -> IO ()
-  IO ()
 checked action getStatus getInfoLog message object = do
-  action object
+   action object
-  ok <- get (getStatus object)
+   ok <- get (getStatus object)
-  unless ok $ do
+   unless ok $ do
-    infoLog <- get (getInfoLog object)
+      infoLog <- get (getInfoLog object)
-    fail (message ++ " log: " ++ infoLog)
+      fail (message ++ " log: " ++ infoLog)

src/Game/Internal/Types.hs

@@ -1,122 +1,141 @@
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NamedFieldPuns, OverloadedRecordDot #-}
-{-# LANGUAGE OverloadedRecordDot #-}
+{- |
-
+ - Module      : Game.Internal.Types
--- |
+ - Description : 
--- - Module      : Game.Internal.Types
+ - Copyright   : 2025 Andromeda
--- - Description :
+ - License     : BSD 3-clause
--- - Copyright   : 2025 Andromeda
+ - Maintainer  : Matrix @Andromeda:tchncs.de
--- - License     : BSD 3-clause
+ - Stability   : Experimental
--- - Maintainer  : Matrix @Andromeda:tchncs.de
+ -}
--- - Stability   : Experimental
 module Game.Internal.Types
-  ( Object (..),
+  ( Object(..)
-    toGLMatrix,
-    Model (camera, objects, cursorDeltaPos, cursorPos, keys, program, wprop),
-    mkModel,
-    Camera (camPos, camPitch, camYaw, camReference, mouseSensitivity, camVel, strafeStrength, jumpStrength, hasJumped, airTime),
-    mkCamera,
-    WorldProperties (g, friction, up),
-    mkWorldProperties,
-  )
-where
 
+  , toGLMatrix
+
+  , Model ( camera
+          , objects
+          , 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 Graphics.UI.GLFW as GLFW
+
-import Linear (V3 (..), V4 (..))
 import qualified Linear as L
+import           Linear      (V3, V3(..), V4(..))
 
 -- | represents a single draw call
-data Object = Object
+data Object =
-  { -- | vao of vertex buffer
+  Object
-    vao :: GL.VertexArrayObject,
+    { vao :: GL.VertexArrayObject       -- ^ vao of vertex buffer
-    -- | number of vertices
+    , numIndicies :: GL.NumArrayIndices -- ^ number of vertices
-    numIndicies :: GL.NumArrayIndices,
+    , numComponents :: GL.NumComponents -- ^ dimensionallity; vec3, vec4, etc.
-    -- | dimensionallity; vec3, vec4, etc.
+    , primitiveMode :: GL.PrimitiveMode -- ^ primitive mode to be drawn with
-    numComponents :: GL.NumComponents,
+    }
-    -- | primitive mode to be drawn with
+    deriving Show
-    primitiveMode :: GL.PrimitiveMode
-  }
-  deriving (Show)
 
 -- | converts M44 to a 16array for OpenGL
 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)) =
+toGLMatrix
-  [ c00,
+  (V4
-    c01,
+    (V4 c00 c01 c02 c03)
-    c02,
+    (V4 c10 c11 c12 c13)
-    c03,
+    (V4 c20 c21 c22 c23)
-    c10,
+    (V4 c30 c31 c32 c33)) =
-    c11,
+  [ c00, c01, c02, c03
-    c12,
+  , c10, c11, c12, c13
-    c13,
+  , c20, c21, c22, c23
-    c20,
+  , c30, c31, c32, c33
-    c21,
-    c22,
-    c23,
-    c30,
-    c31,
-    c32,
-    c33
   ]
 
 -- | gamestate
-data Model = Model
+data Model =
-  { camera :: Camera,
+  Model
-    -- | frame-on-frame delta mouse position
+    { camera :: Camera
-    cursorDeltaPos :: (Double, Double),
+    , cursorDeltaPos :: (Double, Double) -- ^ frame-on-frame delta mouse position
-    -- | current mouse position
+    , cursorPos :: (Double, Double)      -- ^ current mouse position
-    cursorPos :: (Double, Double),
+    , keys :: [GLFW.Key]                 -- ^ currently pressed keys
-    -- | currently pressed keys
+    , objects :: [Object]                -- ^ draw calls
-    keys :: [GLFW.Key],
+    , program :: GL.Program              -- ^ shader program
-    -- | draw calls
+    , wprop :: WorldProperties
-    objects :: [Object],
+    }
-    program :: GL.Program,
+    deriving Show
-    wprop :: WorldProperties
-  }
-  deriving (Show)
 
 -- | smart constructor for Model
-mkModel :: Camera -> [Object] -> GL.Program -> WorldProperties -> Model
+mkModel
+  :: Camera
+  -> [Object]
+  -> GL.Program
+  -> WorldProperties
+  -> Model
 mkModel camera objects program wprop =
-  Model camera (0, 0) (0, 0) [] objects program wprop
+  Model
+    camera
+    (0,0)
+    (0,0)
+    []
+    objects
+    program
+    wprop
 
 -- | camera
-data Camera = Camera
+data Camera =
-  { -- | position in world space
+  Camera
-    camPos :: V4 Float,
+    { camPos :: V3 Float        -- ^ position in world space
-    -- | pitch in radians, up positive
+    , camPitch :: Float         -- ^ pitch in radians, up positive
-    camPitch :: Float,
+    , camYaw :: Float           -- ^ yaw in radians, right positive
-    -- | yaw in radians, right positive
+    , camReference :: V3 Float  -- ^ reference direction; orientation applied to
-    camYaw :: Float,
+    , camVel :: V3 Float        -- ^ velocity in world space
-    -- | reference direction; orientation applied to
+    , mouseSensitivity :: Float -- ^ scale factor for mouse movement
-    camReference :: V3 Float,
+    , strafeStrength :: Float   -- ^ scale factor for strafe
-    -- | velocity in world space
+    , jumpStrength :: Float     -- ^ scale factor for jump initial velocity
-    camVel :: V3 Float,
+    , hasJumped :: Bool         -- ^ whether the camera still has jumping state
-    -- | scale factor for mouse movement
+    , airTime :: Float          -- ^ time since jumping state entered in seconds
-    mouseSensitivity :: Float,
+    }
-    -- | scale factor for strafe
+    deriving Show
-    strafeStrength :: Float,
-    -- | scale factor for jump initial velocity
-    jumpStrength :: Float,
-    -- | whether the camera still has jumping state
-    hasJumped :: Bool,
-    -- | time since jumping state entered in seconds
-    airTime :: Float
-  }
-  deriving (Show)
 
 -- | smart constructor for Camera
-mkCamera ::
+mkCamera
-  V4 Float ->
+  :: V3 Float
-  Float ->
+  -> Float
-  Float ->
+  -> Float
-  V3 Float ->
+  -> V3 Float
-  V3 Float ->
+  -> V3 Float
-  Float ->
+  -> Float
-  Float ->
+  -> Float
-  Float ->
+  -> Float
-  Camera
+  -> Camera
-mkCamera camPos camPitch camYaw camReference camVel mouseSensitivity strafeStrength jumpStrength =
+mkCamera
+  camPos
+  camPitch
+  camYaw
+  camReference
+  camVel
+  mouseSensitivity
+  strafeStrength
+  jumpStrength =
   Camera
     camPos
     camPitch
@@ -130,16 +149,15 @@ mkCamera camPos camPitch camYaw camReference camVel mouseSensitivity strafeStren
     0
 
 -- | physical properties of the world
-data WorldProperties = WorldProperties
+data WorldProperties =
-  { -- | gravity `g`
+  WorldProperties
-    g :: Float,
+    { g :: Float        -- ^ gravity `g`
-    -- | scale factor for floor friction
+    , friction :: Float -- ^ scale factor for floor friction
-    friction :: Float,
+    , up :: V3 Float    -- ^ global up vector
-    -- | global up vector
+    }
-    up :: V3 Float
+    deriving Show
-  }
-  deriving (Show)
 
 -- | smart constructor for WorldProperties
-mkWorldProperties :: Float -> Float -> V3 Float -> WorldProperties
+mkWorldProperties :: Float -> Float -> V3 Float-> WorldProperties
-mkWorldProperties g friction up = WorldProperties g friction (L.normalize up)
+mkWorldProperties g friction up =
+  WorldProperties g friction (L.normalize up)

src/Main.hs

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