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
+- test suite for non-`IO` functions
-- debug/release outputs of Nix flake
 
 ### 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
+- added `CHANGELOG.md`
-- layer correctly drawn objects in the view function
+- 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
+- todo and changelog in `CHANGELOG.md` rather than `README.md`
-- a nubmer fo functions from Game module now in Game.Internal
+- a nubmer fo functions from `Game` now in `Game.Internal`
-- initResources takes an array of objects to draw rather than hardcoded arrays
+- `initResources` takes an `[V3 GL.GLfloat]` to draw rather than hardcoded arrays
-- square the far plane of the perspective transform
+- square the distance of the far plane of the perspective transform
-- loop function takes delta time
+- `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
+see CHANGELOG.md
-git clone https://git.mtgmonkey.net/Andromeda/hs-game
-cd hs-game
-nix run
-```
 
-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
+ - Description : internal functions
- - Copyright   : Andromeda 2025
+ - Copyright   : 2025 Andromeda
- - License     : WTFPL
+ - 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 (IORef, modifyIORef', readIORef)
-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 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(..))
-import           Linear      ( V3(..)
-                             , _x
-                             , _y
-                             , _z
-                             )
 
 --------------------------------------------------------------------------------
 -- Shader creation and object initialisation
 --------------------------------------------------------------------------------
-
 -- | loads models, shaders
-initResources :: GLFW.Window -> [V3 GL.GLfloat] -> IO ([Object], GL.Program)
+initResources :: [[V3 GL.GLfloat]] -> IO ([Object], GL.Program)
-initResources window array = do
+initResources arrays = do
   -- create objects
-  testObject0 <- createObject (map (+(V3 (-1) (-1) (-1))) array) 3 GL.TriangleStrip
+  objects <- listIOsToIOlist [ createObject arr 3 GL.TriangleStrip | arr <- arrays ] []
-  testObject1 <- createObject (map (+(V3 (1) (1) (1))) array) 3 GL.TriangleStrip
-  testObject2 <- createObject array 3 GL.TriangleStrip
-  let objects = [testObject0, testObject1, testObject2]
-
   -- load shaders
-  program <- loadShaders
+  program <-
+    loadShaders
       [ ShaderInfo GL.VertexShader (StringSource vertShader)
       , ShaderInfo GL.FragmentShader (StringSource fragShader)
       ]
   GL.currentProgram $= Just program
-
   return (objects, program)
 
+listIOsToIOlist :: [IO a] -> [a] -> IO [a]
+listIOsToIOlist [] out = return out
+listIOsToIOlist (io:ios) out = do
+  ioVal <- io
+  listIOsToIOlist ios (ioVal:out)
+
 -- a_ vertex shader input
 -- v_ varying
 -- u_ uniform
 -- o_ fragment shader output
-
 -- | vertex shader
 vertShader :: String
 vertShader =
-  "#version 330 core\n" ++
+  "#version 330 core\n"
-  "layout (location = 0) in vec3 a_vPos;\n" ++
+    ++ "layout (location = 0) in vec3 a_vPos;\n"
-  "uniform mat4 u_view;\n" ++
+    ++ "uniform mat4 u_view;\n"
-  "uniform mat4 u_projection;\n" ++
+    ++ "uniform mat4 u_projection;\n"
-  "out vec3 v_pos;\n" ++
+    ++ "out vec3 v_pos;\n"
-  "void main()\n" ++
+    ++ "void main()\n"
-  "{\n" ++
+    ++ "{\n"
-  "  gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n" ++
+    ++ "  gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n"
-  "  v_pos = a_vPos;\n" ++
+    ++ "  v_pos = a_vPos;\n"
-  "}"
+    ++ "}"
 
 -- | fragment shader
 fragShader :: String
 fragShader =
-  "#version 330 core\n" ++
+  "#version 330 core\n"
-  "out vec4 o_vColor;\n" ++
+    ++ "out vec4 o_vColor;\n"
-  "in vec3 v_pos;\n" ++
+    ++ "in vec3 v_pos;\n"
-  "void main()\n" ++
+    ++ "void main()\n"
-  "{\n" ++
+    ++ "{\n"
-  "  o_vColor = vec4(0.5 + 0.5 * v_pos, 1);\n" ++
+    ++ "  o_vColor = vec4(0.5 + 0.5 * normalize(v_pos), 1);\n"
-  "}"
+    ++ "}"
 
 --------------------------------------------------------------------------------
 -- Objects
 --------------------------------------------------------------------------------
-
 -- | calculates the size in memory of an array
 sizeOfArray :: (Storable a, Num b) => [a] -> b
 sizeOfArray [] = 0
 sizeOfArray (x:xs) = fromIntegral $ (*) (1 + length xs) $ sizeOf x
 
 -- | loads a given array into a given attribute index
-createVBO
+createVBO ::
-  :: Storable (a GL.GLfloat)
+     Storable (a GL.GLfloat)
   => [a GL.GLfloat]
   -> GL.NumComponents
   -> GL.AttribLocation
@@ -118,29 +110,19 @@ createVBO array numComponents attribLocation = do
   -- vbo for buffer
   buffer <- GL.genObjectName
   GL.bindBuffer GL.ArrayBuffer $= Just buffer
-
   -- populate buffer
-  withArray
+  withArray array $ \ptr ->
-    array
-    $ \ptr ->
     GL.bufferData GL.ArrayBuffer $= (sizeOfArray array, ptr, GL.StaticDraw)
-
   -- create attribute pointer to buffer
-  GL.vertexAttribPointer attribLocation $=
+  GL.vertexAttribPointer attribLocation
-    ( GL.ToFloat
+    $= ( GL.ToFloat
-    , GL.VertexArrayDescriptor
+       , GL.VertexArrayDescriptor numComponents GL.Float 0 (plusPtr nullPtr 0))
-        numComponents
-        GL.Float
-        0
-        (plusPtr nullPtr 0)
-    )
   GL.vertexAttribArray attribLocation $= GL.Enabled
-
   return buffer
 
 -- | creates an object from a given array; deals with vbos and everything
-createObject
+createObject ::
-  :: Storable (a GL.GLfloat)
+     Storable (a GL.GLfloat)
   => [a GL.GLfloat]
   -> GL.NumComponents
   -> GL.PrimitiveMode
@@ -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
+  _ <- createVBO array numComponents $ GL.AttribLocation 0
-
+  return (Object vao (fromIntegral $ length array) numComponents primitiveMode)
-  return
-    (Object
-      vao
-      (fromIntegral $ length array)
-      numComponents
-      primitiveMode
-    )
 
 --------------------------------------------------------------------------------
 -- Elm-like data structures
 --------------------------------------------------------------------------------
-
 -- | gameloop
-loop
+loop ::
-  :: GLFW.Window -- ^ window to display on
+     GLFW.Window -- ^ window to display on
   -> Float -- ^ dt
   -> (Float -> Model -> Model) -- ^ update function
   -> (GLFW.Window -> Model -> IO ()) -- ^ view function
@@ -176,37 +149,29 @@ loop
 loop window dt update view modelRef = do
   -- start frame timer
   Just frameStart <- GLFW.getTime
-
   -- tick model
   modifyIORef' modelRef $ update dt
   model' <- readIORef modelRef
-
   -- view new model
   view window model'
-
   -- end frame timer, wait the difference between expected and actual
   Just frameEnd <- GLFW.getTime
-  let
+  let drawTime = double2Float $ frameEnd - frameStart
-    dt = double2Float $ frameEnd - frameStart
       target = 1 / 60 :: Float
-  when (dt < target) $ threadDelay $ floor $ (target - dt) * 1000000
+  when (drawTime < target) $ threadDelay $ floor $ (target - drawTime) * 1000000
   Just frameEnd' <- GLFW.getTime
-  let
+  let dt' = double2Float $ frameEnd' - frameStart
-    dt' = double2Float $ frameEnd' - frameStart
-
   loop window dt' update view modelRef
 
 -- | updates given a keypress. escape case is probably caught by GLFW in the
 -- handler function itself
 updateKeyPressed :: GLFW.Key -> Model -> Model
-updateKeyPressed key model =
+updateKeyPressed key model = model {keys = key : model.keys}
-  model { keys = key:model.keys }
 
 -- | updates given a keyrelease. escape case is probably caught by GLFW in the
 -- handler function itself
 updateKeyReleased :: GLFW.Key -> Model -> Model
-updateKeyReleased key model =
+updateKeyReleased key model = model {keys = (delete key model.keys)}
-  model { keys = (delete key model.keys) }
 
 applyToTuples :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
 applyToTuples f (x, y) (a, b) = (f x a, f y b)
@@ -214,24 +179,20 @@ applyToTuples f (x, y) (a, b) = (f x a, f y b)
 -- | updates cursor
 updateCursorPos :: Double -> Double -> Model -> Model
 updateCursorPos x y model =
-  let
+  let pyth =
-    pyth = (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos - y)) ** 2) ** 0.5
+        (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos) - y) ** 2)
-  in
+          ** 0.5
-  if pyth < 16 then
+   in if pyth < 16
-    model
+        then model
                { cursorPos = (x, y)
                , cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y)
                }
-  else 
+        else model {cursorPos = (x, y)}
-    model
-      { cursorPos = (x, y)
-      }
 
 -- | draws objects
 drawObjects :: [Object] -> IO ([Object])
 drawObjects [] = return []
-drawObjects
+drawObjects ((Object vao numVertices _ primitiveMode):objects) = do
-  ((Object vao numVertices _ primitiveMode):objects) = do
   GL.bindVertexArrayObject $= Just vao
   GL.drawArrays primitiveMode 0 numVertices
   drawObjects objects
@@ -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
-module Game.Internal.LoadShaders (
+  ( ShaderSource(..)
-   ShaderSource(..), ShaderInfo(..), loadShaders
+  , ShaderInfo(..)
-) where
+  , 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
-data ShaderSource =
+  = ByteStringSource B.ByteString
-     ByteStringSource B.ByteString
      -- ^ The shader source code is directly given as a 'B.ByteString'.
   | StringSource String
      -- ^ The shader source code is directly given as a 'String'.
   | 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,17 +40,14 @@ getSource (StringSource str) = return $ packUtf8 str
 getSource (FileSource path) = B.readFile path
 
 --------------------------------------------------------------------------------
-
 -- | A description of a shader: The type of the shader plus its source code.
-
+data ShaderInfo =
-data ShaderInfo = ShaderInfo ShaderType ShaderSource
+  ShaderInfo ShaderType ShaderSource
-   deriving ( Eq, Ord, Show )
+  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
@@ -64,7 +60,7 @@ linkAndCheck = checked linkProgram linkStatus programInfoLog "link"
 
 loadCompileAttach :: Program -> [ShaderInfo] -> IO ()
 loadCompileAttach _ [] = return ()
-loadCompileAttach program (ShaderInfo shType source : infos) =
+loadCompileAttach program (ShaderInfo shType source:infos) =
   createShader shType `bracketOnError` deleteObjectName $ \shader -> do
     src <- getSource source
     shaderSourceBS shader $= src
@@ -75,7 +71,8 @@ loadCompileAttach program (ShaderInfo shType source : infos) =
 compileAndCheck :: Shader -> IO ()
 compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile"
 
-checked :: (t -> IO ())
+checked ::
+     (t -> IO ())
   -> (t -> GettableStateVar Bool)
   -> (t -> GettableStateVar String)
   -> String

src/Game/Internal/Types.hs

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