merge development into master

.gitignore

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

CHANGELOG.md

@@ -6,36 +6,101 @@ All notable changes to this project will be documented in this file.
 The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/),
 and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).
 
-## [Unreleased]
+## [Eventual]
 
 ### Added
 
-- test suite for non-IO functions
-- debug/release outputs of Nix flake
+- test suite for non-`IO` functions
 
 ### Changed
 
-- use Rotors rather than Quaternions for rotation; easily extended to 4D
+- use rotors rather than `Linear.Quaternion` for rotation; easily extended to 4D
+- move `Player` out of `Camera`
+- configure with `Properties` objects in the Model
+- 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
 
-- semantic issues
+- 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
+
+- 100% documentation coverage
+- 4 outputs of Nix flake
+    - `debug`: compiles fast, no docs
+    - `release`: runs fast, no docs
+    - `docs`: only docs
+    - `default`: release binary with docs
+
+### Changed
+
+- `initResources` no longer takes a `GLFW.Window` argument
+- BSD 3-clause license adopted rather than WTFPL
+    - reasoning: More professional, widely recognised, effectively identical
+- `CHANGELOG.md` has more formatting, namely inline code
+- clarify a couple entries in the `[0.1.0] - 2025-12-07 Changed` entry
+
+### Fixed
+
+- semantic issues; no warnings are thrown
 
 ## [0.1.0] - 2025-12-07
 
 ### Added
 
-- CHANGELOG.md
-- layer correctly drawn objects in the view function
+- added `CHANGELOG.md`
+- layer correctly drawn objects in `view`
 
 ### Changed
 
 - 8xMSAA rather than 4xMSAA window hint to improve AA
-- todo and changelog in CHANGELOG.md rather than README.md
-- a nubmer fo functions from Game module now in Game.Internal
-- initResources takes an array of objects to draw rather than hardcoded arrays
-- square the far plane of the perspective transform
-- loop function takes delta time
+- todo and changelog in `CHANGELOG.md` rather than `README.md`
+- a nubmer fo functions from `Game` now in `Game.Internal`
+- `initResources` takes an `[V3 GL.GLfloat]` to draw rather than hardcoded arrays
+- square the distance of the far plane of the perspective transform
+- `loop` function takes delta time `dt :: Float`
 
 ### Fixed
 

LICENSE

@@ -0,0 +1,11 @@
+Copyright 2025 Andromeda
+
+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.md

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

flake.nix

@@ -2,12 +2,34 @@
   inputs = {
     nixpkgs.url = "nixpkgs/nixpkgs-unstable";
   };
-  outputs = {nixpkgs, ...}: let
+  outputs = {
+    nixpkgs,
+    self,
+    ...
+  }: let
     system = "x86_64-linux";
     pkgs = nixpkgs.legacyPackages.${system};
   in {
     packages.${system} = {
-      default = pkgs.callPackage ./package.nix {};
+      default = pkgs.haskellPackages.callCabal2nix "hs-game" ./. {};
+    };
+    devShells.${system} = {
+      default = pkgs.mkShell {
+        packages = [
+          pkgs.cabal-install
+          pkgs.libGL
+          pkgs.xorg.libX11
+          pkgs.xorg.libXi
+          pkgs.xorg.libXrandr
+          pkgs.xorg.libXxf86vm
+          pkgs.xorg.libXcursor
+          pkgs.xorg.libXinerama
+          pkgs.libGLU
+        ];
+        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,65 +0,0 @@
-{
-  haskellPackages,
-  lib,
-  stdenv,
-  ...
-}: let
-  ghcExeOptions = lib.concatStringsSep " " ghcFlags;
-  ghcFlags = [
-    "-O"
-    "-Wall"
-    "-Widentities"
-    "-Wincomplete-record-updates"
-    "-Wincomplete-uni-patterns"
-    # "-Wmissing-export-lists"
-    "-Wmissing-home-modules"
-    "-Wpartial-fields"
-    "-Wredundant-constraints"
-    "-threaded"
-    "-rtsopts"
-    "-with-rtsopts=-N"
-    # src
-    "-i./src"
-    "-main-is Game"
-  ];
-  haddockOptions = lib.concatStringsSep " " haddockFlags;
-  haddockFlags = [
-    "--html"
-    "--odir docs"
-    "--optghc=-i./src"
-    "src/Game/Main.hs"
-  ];
-  ghcPackages = p: [
-    p.GLFW-b
-    p.linear
-    p.OpenGL
-  ];
-in
-  stdenv.mkDerivation {
-    pname = "haskengl";
-    version = "0.1.0";
-    src = ./.;
-    nativeBuildInputs = [
-      (haskellPackages.ghcWithPackages ghcPackages)
-    ];
-    buildInputs = [
-    ];
-    configurePhase = ''
-    '';
-    buildPhase = ''
-      ghc ${ghcExeOptions} ./src/Game/Main.hs -o ./Main
-      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.wtfpl;
-      mainProgram = "hs-game";
-      platforms = ["x86_64-linux"];
-    };
-  }

src/Game/Internal.hs

@@ -1,9 +1,10 @@
 {-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
+
 {- |
  - Module      : Game.Internal
- - Description : 'hidden' functions
- - Copyright   : Andromeda 2025
- - License     : WTFPL
+ - Description : internal functions
+ - Copyright   : 2025 Andromeda
+ - License     : BSD 3-clause
  - Maintainer  : Matrix @Andromeda:tchncs.de
  - Stability   : Experimental
  -}
@@ -18,98 +19,89 @@ module Game.Internal
   , updateCursorPos
   , updateKeyPressed
   , updateKeyReleased
-  )
-  where
+  ) where
 
 import Game.Internal.LoadShaders
 import Game.Internal.Types
 
-import Control.Concurrent    (threadDelay)
-import Control.Lens          ((^.), (+~), (&), (%~))
-import Control.Monad         (when)
-import Data.Fixed            (mod')
-import Data.IORef            (atomicModifyIORef', IORef, modifyIORef', newIORef, readIORef, writeIORef)
-import Data.List             (delete)
+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 Foreign.Ptr (nullPtr, plusPtr)
+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 qualified Linear as L
-import           Linear      ( V3(..)
-                             , _x
-                             , _y
-                             , _z
-                             )
+import Linear (V3(..))
 
 --------------------------------------------------------------------------------
 -- Shader creation and object initialisation
 --------------------------------------------------------------------------------
-
 -- | loads models, shaders
-initResources :: GLFW.Window -> [V3 GL.GLfloat] -> IO ([Object], GL.Program)
-initResources window array = do
+initResources :: [[V3 GL.GLfloat]] -> IO ([Object], GL.Program)
+initResources arrays = do
   -- 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]
-
+  objects <- listIOsToIOlist [ createObject arr 3 GL.TriangleStrip | arr <- arrays ] []
   -- load shaders
-  program <- loadShaders
-    [ ShaderInfo GL.VertexShader (StringSource vertShader)
-    , ShaderInfo GL.FragmentShader (StringSource fragShader)
-    ]
+  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" ++
-  "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" ++
-  "}"
-  
+  "#version 330 core\n"
+    ++ "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
 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 * v_pos, 1);\n" ++
-  "}"
+  "#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 * 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
-  :: Storable (a GL.GLfloat)
+createVBO ::
+     Storable (a GL.GLfloat)
   => [a GL.GLfloat]
   -> GL.NumComponents
   -> GL.AttribLocation
@@ -118,29 +110,19 @@ createVBO array numComponents attribLocation = do
   -- vbo for buffer
   buffer <- GL.genObjectName
   GL.bindBuffer GL.ArrayBuffer $= Just buffer
-
   -- populate buffer
-  withArray
-    array
-    $ \ptr ->
-        GL.bufferData GL.ArrayBuffer $= (sizeOfArray array, ptr, GL.StaticDraw)
-
+  withArray array $ \ptr ->
+    GL.bufferData GL.ArrayBuffer $= (sizeOfArray array, ptr, GL.StaticDraw)
   -- create attribute pointer to buffer
-  GL.vertexAttribPointer attribLocation $=
-    ( GL.ToFloat
-    , GL.VertexArrayDescriptor
-        numComponents
-        GL.Float
-        0
-        (plusPtr nullPtr 0)
-    )
+  GL.vertexAttribPointer attribLocation
+    $= ( GL.ToFloat
+       , 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
-  :: Storable (a GL.GLfloat)
+createObject ::
+     Storable (a GL.GLfloat)
   => [a GL.GLfloat]
   -> GL.NumComponents
   -> GL.PrimitiveMode
@@ -149,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
-    )
+  _ <- createVBO array numComponents $ GL.AttribLocation 0
+  return (Object vao (fromIntegral $ length array) numComponents primitiveMode)
 
 --------------------------------------------------------------------------------
 -- Elm-like data structures
 --------------------------------------------------------------------------------
-
 -- | gameloop
-loop
-  :: GLFW.Window -- ^ window to display on
+loop ::
+     GLFW.Window -- ^ window to display on
   -> Float -- ^ dt
   -> (Float -> Model -> Model) -- ^ update function
   -> (GLFW.Window -> Model -> IO ()) -- ^ view function
@@ -176,62 +149,50 @@ 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
-    dt = double2Float $ frameEnd - frameStart
-    target = 1 / 60 :: Float
-  when (dt < target) $ threadDelay $ floor $ (target - dt) * 1000000
+  let 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 = (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos - y)) ** 2) ** 0.5
-  in
-  if pyth < 16 then
-    model
-      { cursorPos = (x, y)
-      , cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y)
-      }
-  else 
-    model
-      { cursorPos = (x, y)
-      }
+  let pyth =
+        (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos) - y) ** 2)
+          ** 0.5
+   in if pyth < 16
+        then model
+               { cursorPos = (x, y)
+               , cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y)
+               }
+        else 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
@@ -239,7 +200,6 @@ drawObjects
 --------------------------------------------------------------------------------
 -- interrupts
 --------------------------------------------------------------------------------
-
 -- | shuts down GLFW
 shutdownWindow :: GLFW.WindowCloseCallback
 shutdownWindow window = do
@@ -254,9 +214,9 @@ resizeWindow _ _ _ = return ()
 keyPressed :: Maybe (IORef Model) -> GLFW.KeyCallback
 keyPressed _ window GLFW.Key'Escape _ GLFW.KeyState'Pressed _ =
   shutdownWindow window
-keyPressed (Just modelRef) window key _ GLFW.KeyState'Pressed _ =
+keyPressed (Just modelRef) _ key _ GLFW.KeyState'Pressed _ =
   modifyIORef' modelRef $ updateKeyPressed key
-keyPressed (Just modelRef) window key _ GLFW.KeyState'Released _ =
+keyPressed (Just modelRef) _ key _ GLFW.KeyState'Released _ =
   modifyIORef' modelRef $ updateKeyReleased key
 keyPressed _ _ _ _ _ _ = return ()
 

src/Game/Internal/LoadShaders.hs

@@ -12,10 +12,11 @@
 -- Red Book Authors.
 --
 --------------------------------------------------------------------------------
-
-module Game.Internal.LoadShaders (
-   ShaderSource(..), ShaderInfo(..), loadShaders
-) where
+module Game.Internal.LoadShaders
+  ( ShaderSource(..)
+  , ShaderInfo(..)
+  , loadShaders
+  ) where
 
 import Control.Exception
 import Control.Monad
@@ -23,17 +24,15 @@ import qualified Data.ByteString as B
 import Graphics.Rendering.OpenGL
 
 --------------------------------------------------------------------------------
-
 -- | The source of the shader source code.
-
-data ShaderSource =
-     ByteStringSource B.ByteString
+data ShaderSource
+  = ByteStringSource B.ByteString
      -- ^ The shader source code is directly given as a 'B.ByteString'.
-   | StringSource String
+  | StringSource String
      -- ^ The shader source code is directly given as a 'String'.
-   | FileSource FilePath
+  | FileSource FilePath
      -- ^ The shader source code is located in the file at the given 'FilePath'.
-   deriving ( Eq, Ord, Show )
+  deriving (Eq, Ord, Show)
 
 getSource :: ShaderSource -> IO B.ByteString
 getSource (ByteStringSource bs) = return bs
@@ -41,49 +40,47 @@ 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 = ShaderInfo ShaderType ShaderSource
-   deriving ( Eq, Ord, Show )
+data ShaderInfo =
+  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
-      loadCompileAttach program infos
-      linkAndCheck program
-      return program
+  createProgram `bracketOnError` deleteObjectName $ \program -> do
+    loadCompileAttach program infos
+    linkAndCheck program
+    return program
 
 linkAndCheck :: Program -> IO ()
 linkAndCheck = checked linkProgram linkStatus programInfoLog "link"
 
 loadCompileAttach :: Program -> [ShaderInfo] -> IO ()
 loadCompileAttach _ [] = return ()
-loadCompileAttach program (ShaderInfo shType source : infos) =
-   createShader shType `bracketOnError` deleteObjectName $ \shader -> do
-      src <- getSource source
-      shaderSourceBS shader $= src
-      compileAndCheck shader
-      attachShader program shader
-      loadCompileAttach program infos
+loadCompileAttach program (ShaderInfo shType source:infos) =
+  createShader shType `bracketOnError` deleteObjectName $ \shader -> do
+    src <- getSource source
+    shaderSourceBS shader $= src
+    compileAndCheck shader
+    attachShader program shader
+    loadCompileAttach program infos
 
 compileAndCheck :: Shader -> IO ()
 compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile"
 
-checked :: (t -> IO ())
-        -> (t -> GettableStateVar Bool)
-        -> (t -> GettableStateVar String)
-        -> String
-        -> t
-        -> IO ()
+checked ::
+     (t -> IO ())
+  -> (t -> GettableStateVar Bool)
+  -> (t -> GettableStateVar String)
+  -> String
+  -> t
+  -> IO ()
 checked action getStatus getInfoLog message object = do
-   action object
-   ok <- get (getStatus object)
-   unless ok $ do
-      infoLog <- get (getInfoLog object)
-      fail (message ++ " log: " ++ infoLog)
+  action object
+  ok <- get (getStatus object)
+  unless ok $ do
+    infoLog <- get (getInfoLog object)
+    fail (message ++ " log: " ++ infoLog)

src/Game/Internal/Types.hs

@@ -1,108 +1,92 @@
 {-# LANGUAGE NamedFieldPuns, OverloadedRecordDot #-}
+
 {- |
- - Module      : Game.Types
+ - Module      : Game.Internal.Types
  - Description : 
- - Copyright   : Andromeda 2025
- - License     : WTFPL
+ - Copyright   : 2025 Andromeda
+ - License     : BSD 3-clause
  - Maintainer  : Matrix @Andromeda:tchncs.de
  - Stability   : Experimental
  -}
 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)
+  , 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      (Quaternion, V3, V3(..), V4(..))
+import Linear (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
+data 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)
 
+-- | 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)) =
-  [ c00, c01, c02, c03
-  , c10, c11, c12, c13
-  , c20, c21, c22, c23
-  , c30, c31, c32, c33
+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
+data Model = Model
+  { camera :: Camera
+  , cursorDeltaPos :: (Double, Double) -- ^ frame-on-frame delta mouse position
+  , cursorPos :: (Double, Double) -- ^ current mouse position
+  , keys :: [GLFW.Key] -- ^ currently pressed keys
+  , objects :: [Object] -- ^ draw calls
+  , program :: GL.Program -- ^ shader program
+  , wprop :: WorldProperties
+  } deriving (Show)
 
+-- | smart constructor for Model
 mkModel :: Camera -> [Object] -> GL.Program -> WorldProperties -> Model
-mkModel camera objects program wprop = Model camera (0,0) (0,0) [] objects program wprop
+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
+data Camera = Camera
+  { camPos :: V3 Float -- ^ position in world space
+  , camPitch :: Float -- ^ pitch in radians, up positive
+  , camYaw :: Float -- ^ yaw in radians, right positive
+  , camReference :: V3 Float -- ^ reference direction; orientation applied to
+  , camVel :: V3 Float -- ^ velocity in world space
+  , mouseSensitivity :: Float -- ^ scale factor for mouse movement
+  , strafeStrength :: Float -- ^ scale factor for strafe
+  , 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)
 
-mkCamera
-  :: V3 Float
+-- | smart constructor for Camera
+mkCamera ::
+     V3 Float
   -> Float
   -> Float
   -> V3 Float
@@ -111,15 +95,7 @@ mkCamera
   -> Float
   -> Float
   -> Camera
-mkCamera
-  camPos
-  camPitch
-  camYaw
-  camReference
-  camVel
-  mouseSensitivity
-  strafeStrength
-  jumpStrength =
+mkCamera camPos camPitch camYaw camReference camVel mouseSensitivity strafeStrength jumpStrength =
   Camera
     camPos
     camPitch
@@ -132,14 +108,13 @@ mkCamera
     False
     0
 
-data WorldProperties =
-  WorldProperties
-    { g :: Float -- ^ gravity `g`
-    , friction :: Float -- ^ floor friction
-    , up :: V3 Float
-    }
-    deriving Show
+-- | physical properties of the world
+data WorldProperties = WorldProperties
+  { g :: Float -- ^ gravity `g`
+  , friction :: Float -- ^ scale factor for floor friction
+  , up :: V3 Float -- ^ global up vector
+  } deriving (Show)
 
-mkWorldProperties :: Float -> Float -> V3 Float-> WorldProperties
-mkWorldProperties g friction up =
-  WorldProperties g friction (L.normalize up)
+-- | smart constructor for WorldProperties
+mkWorldProperties :: Float -> Float -> V3 Float -> WorldProperties
+mkWorldProperties g friction up = WorldProperties g friction (L.normalize up)

src/Game/Main.hs

@@ -1,243 +0,0 @@
-{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
-{- |
- - Module      : Game
- - Description : runs game
- - Copyright   : Andromeda 2025
- - License     : WTFPL
- - Maintainer  : Matrix @Andromeda:tchncs.de
- - Stability   : Experimental
- -}
-module Game (main) where
-
-import Game.Internal.LoadShaders
-import Game.Internal.Types
-import Game.Internal
-
-import Control.Concurrent    (threadDelay)
-import Control.Lens          ((^.), (+~), (&), (%~))
-import Control.Monad         (when)
-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, int2Double)
-
-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(..)
-                             , _x
-                             , _y
-                             , _z
-                             )
-
--- | 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 window 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
-    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 = 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
-      }
-    }
-
--- | 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 }
-
--- | 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
-  drawObjects model.objects
-
-  -- swap to current buffer
-  GLFW.swapBuffers window
-
-  -- check for interrupts
-  GLFW.pollEvents

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