hypercube, format ig

CHANGELOG.md

@@ -20,6 +20,21 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 - use `Double` rather than `FLoat` for internal calculations
     - `cursorPos`, `dt` natively `Double` already
 
+## [0.4.0] - 2025-12-21
+
+### Added
+
+- cube as array of points
+- debug feature where `t` and `g` raise and lower speed respectively
+
+### Changed
+
+- `initResources` now takes `[[V3 GL.GLfloat]]` rather than `[V3 GL.GLfloat]`
+    - to migrate: rather than passing `a` pass `[a]`; behaviour is the same
+- reduce view distance to 1'000 from 10'000
+- color pixels based on normalized coordinates
+- use `haskellPackages.callCabal2nix` in `flake.nix` for brevity, same behaviour
+
 ## [0.3.0] - 2025-12-08
 
 ### Added

flake.nix

@@ -7,45 +7,19 @@
     self,
     ...
   }: let
-    versionString = "0.3.0";
-    package = {
-      mkDerivation,
-      base,
-      bytestring,
-      GLFW-b,
-      lens,
-      lib,
-      linear,
-      OpenGL,
-    }:
-      mkDerivation {
-        pname = "hs-game";
-        version = versionString;
-        src = ./.;
-        isLibrary = false;
-        isExecutable = true;
-        executableHaskellDepends = [
-          base
-          bytestring
-          GLFW-b
-          lens
-          linear
-          OpenGL
-        ];
-        homepage = "https://git.mtgmonkey.net/Andromeda/hs-game";
-        license = lib.licenses.bsd3;
-        mainProgram = "hs-game";
-      };
     system = "x86_64-linux";
     pkgs = nixpkgs.legacyPackages.${system};
   in {
     packages.${system} = {
-      default =
-        pkgs.haskellPackages.callPackage package {};
+      default = pkgs.haskellPackages.callCabal2nix "hs-game" ./. {};
     };
     devShells.${system} = {
       default = pkgs.mkShell {
         packages = [
+          # dev stuff
+          pkgs.haskellPackages.ghcide
+          pkgs.haskellPackages.ormolu
+
           pkgs.cabal-install
           pkgs.libGL
           pkgs.xorg.libX11

hs-game.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               hs-game
-version:            0.3.0
+version:            0.5.0
 -- synopsis:
 -- description:
 homepage:           https://git.mtgmonkey.net/Andromeda/hs-game

src/Game/Internal.hs

@@ -1,28 +1,27 @@
-{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
-{- |
- - Module      : Game.Internal
- - Description : internal functions
- - Copyright   : 2025 Andromeda
- - License     : BSD 3-clause
- - Maintainer  : Matrix @Andromeda:tchncs.de
- - Stability   : Experimental
- -}
-module Game.Internal
-  ( cursorPosHandler
-  , drawObjects
-  , initResources
-  , keyPressed
-  , loop
-  , resizeWindow
-  , shutdownWindow
-  , updateCursorPos
-  , updateKeyPressed
-  , updateKeyReleased
-  )
-  where
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 
-import Game.Internal.LoadShaders
-import Game.Internal.Types
+-- |
+-- - Module      : Game.Internal
+-- - Description : internal functions
+-- - Copyright   : 2025 Andromeda
+-- - License     : BSD 3-clause
+-- - Maintainer  : Matrix @Andromeda:tchncs.de
+-- - Stability   : Experimental
+module Game.Internal
+  ( cursorPosHandler,
+    drawObjects,
+    initResources,
+    keyPressed,
+    loop,
+    resizeWindow,
+    shutdownWindow,
+    updateCursorPos,
+    updateKeyPressed,
+    updateKeyReleased,
+  )
+where
 
 import Control.Concurrent (threadDelay)
 import Control.Monad (when)
@@ -30,37 +29,39 @@ import Data.IORef            (IORef, modifyIORef', readIORef)
 import Data.List (delete)
 import Foreign.Marshal.Array (withArray)
 import Foreign.Ptr (nullPtr, plusPtr)
-import Foreign.Storable      (sizeOf, Storable)
+import Foreign.Storable (Storable, sizeOf)
 import GHC.Float (double2Float)
-
-import qualified Graphics.UI.GLFW          as GLFW
+import Game.Internal.LoadShaders
+import Game.Internal.Types
+import Graphics.Rendering.OpenGL (($=))
 import qualified Graphics.Rendering.OpenGL as GL
-import           Graphics.Rendering.OpenGL as GL (($=))
-
-import Linear (V3(..))
+import qualified Graphics.UI.GLFW as GLFW
+import Linear (V3 (..), V4 (..))
 
 --------------------------------------------------------------------------------
 -- Shader creation and object initialisation
 --------------------------------------------------------------------------------
 
--- | loads models, shaders
-initResources :: [V3 GL.GLfloat] -> IO ([Object], GL.Program)
-initResources array = 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]
-
-  -- load shaders
-  program <- loadShaders
-    [ ShaderInfo GL.VertexShader (StringSource vertShader)
-    , ShaderInfo GL.FragmentShader (StringSource fragShader)
+initResources :: [[V4 GL.GLfloat]] -> IO ([Object], GL.Program)
+initResources arrays = do
+  objects <-
+    listIOsToIOlist
+      [createObject arr 4 GL.TriangleStrip (GL.AttribLocation 0) | arr <- arrays]
+      []
+  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
@@ -69,27 +70,36 @@ initResources array = do
 -- | 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 vec4 a_vPos;\n"
+    ++ "uniform mat4 u_view;\n"
+    ++ "uniform mat4 u_projection;\n"
+    ++ "out vec3 v_pos;\n"
+    ++ glslProjectTo3d
+    ++ "void main()\n"
+    ++ "{\n"
+    ++ "  gl_Position = u_projection * u_view * vec4(projectTo3d(a_vPos), 1.0);\n"
+    ++ "  v_pos = a_vPos.xyz;\n"
+    ++ "}\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"
+    ++ "}\n"
+
+glslProjectTo3d :: String
+glslProjectTo3d =
+  "vec3 projectTo3d(vec4 point)\n"
+    ++ "{\n"
+    ++ "  float perspective = 1.0 / (1.0 + point.w);\n"
+    ++ "  return perspective * point.xyz;\n"
+    ++ "}\n"
 
 --------------------------------------------------------------------------------
 -- Objects
@@ -98,108 +108,89 @@ 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
-  :: Storable (a GL.GLfloat)
-  => [a GL.GLfloat]
-  -> GL.NumComponents
-  -> GL.AttribLocation
-  -> IO GL.BufferObject
+createVBO ::
+  (Storable (a GL.GLfloat)) =>
+  [a GL.GLfloat] ->
+  GL.NumComponents ->
+  GL.AttribLocation ->
+  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 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)
-  => [a GL.GLfloat]
-  -> GL.NumComponents
-  -> GL.PrimitiveMode
-  -> IO Object
-createObject array numComponents primitiveMode = do
+createObject ::
+  (Storable (a GL.GLfloat)) =>
+  [a GL.GLfloat] ->
+  GL.NumComponents ->
+  GL.PrimitiveMode ->
+  GL.AttribLocation ->
+  IO Object
+createObject array numComponents primitiveMode attrLocation = 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 attrLocation
+  return (Object vao (fromIntegral $ length array) numComponents primitiveMode)
 
 --------------------------------------------------------------------------------
 -- Elm-like data structures
 --------------------------------------------------------------------------------
 
 -- | gameloop
-loop
-  :: GLFW.Window -- ^ window to display on
-  -> Float -- ^ dt
-  -> (Float -> Model -> Model) -- ^ update function
-  -> (GLFW.Window -> Model -> IO ()) -- ^ view function
-  -> IORef Model -- ^ model
-  -> IO ()
+loop ::
+  -- | window to display on
+  GLFW.Window ->
+  -- | dt
+  Float ->
+  -- | update function
+  (Float -> Model -> Model) ->
+  -- | 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 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)
@@ -207,24 +198,21 @@ applyToTuples f (x, y) (a, b) = (f x a, f y b)
 -- | updates cursor
 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
+  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)
+            { 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

src/Game/Internal/LoadShaders.hs

@@ -1,4 +1,7 @@
 --------------------------------------------------------------------------------
+
+--------------------------------------------------------------------------------
+
 -- |
 -- Module      :  LoadShaders
 -- Copyright   :  (c) Sven Panne 2013
@@ -10,12 +13,12 @@
 --
 -- Utilities for shader handling, adapted from LoadShaders.cpp which is (c) The
 -- 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
@@ -25,15 +28,14 @@ import Graphics.Rendering.OpenGL
 --------------------------------------------------------------------------------
 
 -- | The source of the shader source code.
-
-data ShaderSource =
+data ShaderSource
+  = -- | The shader source code is directly given as a '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 )
+  | -- | The shader source code is directly given as a 'String'.
+    StringSource String
+  | -- | The shader source code is located in the file at the given 'FilePath'.
+    FileSource FilePath
+  deriving (Eq, Ord, Show)
 
 getSource :: ShaderSource -> IO B.ByteString
 getSource (ByteStringSource bs) = return bs
@@ -43,15 +45,14 @@ 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
@@ -75,12 +76,13 @@ loadCompileAttach program (ShaderInfo shType source : 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)

src/Game/Internal/Types.hs

@@ -1,141 +1,123 @@
-{-# LANGUAGE NamedFieldPuns, OverloadedRecordDot #-}
-{- |
- - Module      : Game.Internal.Types
- - Description : 
- - Copyright   : 2025 Andromeda
- - License     : BSD 3-clause
- - Maintainer  : Matrix @Andromeda:tchncs.de
- - Stability   : Experimental
- -}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+
+-- |
+-- - Module      : Game.Internal.Types
+-- - Description :
+-- - 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
+  ( Object (..),
+    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,
   )
-  , mkModel
+where
 
-  , 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
-    { 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
+data Object = Object
+  { -- | vao of vertex buffer
+    vao :: GL.VertexArrayObject,
+    -- | number of vertices
+    numIndicies :: GL.NumArrayIndices,
+    -- | dimensionallity; vec3, vec4, etc.
+    numComponents :: GL.NumComponents,
+    -- | 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
-  (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) -- ^ 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
+data Model = Model
+  { camera :: Camera,
+    -- | frame-on-frame delta mouse position
+    cursorDeltaPos :: (Double, Double),
+    -- | current mouse position
+    cursorPos :: (Double, Double),
+    -- | currently pressed keys
+    keys :: [GLFW.Key],
+    -- | draw calls
+    objects :: [Object],
+    -- | shader program
+    program :: GL.Program,
+    wprop :: WorldProperties
   }
-    deriving Show
+  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
-    { 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
+data Camera = Camera
+  { -- | position in world space
+    camPos :: V3 Float,
+    -- | pitch in radians, up positive
+    camPitch :: Float,
+    -- | yaw in radians, right positive
+    camYaw :: Float,
+    -- | reference direction; orientation applied to
+    camReference :: V3 Float,
+    -- | velocity in world space
+    camVel :: V3 Float,
+    -- | scale factor for mouse movement
+    mouseSensitivity :: Float,
+    -- | scale factor for strafe
+    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
+  deriving (Show)
 
 -- | smart constructor for Camera
-mkCamera
-  :: V3 Float
-  -> Float
-  -> Float
-  -> V3 Float
-  -> V3 Float
-  -> Float
-  -> Float
-  -> Float
-  -> Camera
-mkCamera
-  camPos
-  camPitch
-  camYaw
-  camReference
-  camVel
-  mouseSensitivity
-  strafeStrength
-  jumpStrength =
+mkCamera ::
+  V3 Float ->
+  Float ->
+  Float ->
+  V3 Float ->
+  V3 Float ->
+  Float ->
+  Float ->
+  Float ->
+  Camera
+mkCamera camPos camPitch camYaw camReference camVel mouseSensitivity strafeStrength jumpStrength =
   Camera
     camPos
     camPitch
@@ -149,15 +131,16 @@ mkCamera
     0
 
 -- | 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
+data WorldProperties = WorldProperties
+  { -- | gravity `g`
+    g :: Float,
+    -- | scale factor for floor friction
+    friction :: Float,
+    -- | global up vector
+    up :: V3 Float
   }
-    deriving Show
+  deriving (Show)
 
 -- | smart constructor for WorldProperties
-mkWorldProperties :: Float -> Float -> V3 Float-> WorldProperties
-mkWorldProperties g friction up =
-  WorldProperties g friction (L.normalize up)
+mkWorldProperties :: Float -> Float -> V3 Float -> WorldProperties
+mkWorldProperties g friction up = WorldProperties g friction (L.normalize up)

src/Main.hs

@@ -1,61 +1,59 @@
-{-# 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
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 
-import Game.Internal.Types
-import Game.Internal
+-- |
+-- - 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 qualified Graphics.UI.GLFW          as GLFW
+import Game.Internal
+import Game.Internal.Types
+import Graphics.Rendering.OpenGL (($=))
 import qualified Graphics.Rendering.OpenGL as GL
-import           Graphics.Rendering.OpenGL as GL (($=))
-
+import qualified Graphics.UI.GLFW as GLFW
+import Linear (V3 (..), V4 (..), _y)
 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 (v3tov4 0) $ map (+ V3 a 0 0) cube | a <- take 100 [0, 2 ..]]
+      [hCube]
 
-  (objects, program) <- initResources testVertices
-
-  -- init model
-  let
-    model =
+  let model =
         mkModel
-        (mkCamera
+          ( mkCamera
               (V3 0 0 3) -- camPos
               0 -- pitch
               0 -- yaw
@@ -67,32 +65,92 @@ main = do
           )
           objects
           program
-        (mkWorldProperties
-          2
-          0.16
-          (V3 0 1 0)
-        )
+          (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
+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
+
+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
+
+-- | TODO optimise cube
+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
+  ]
+
+-- | TODO optimise hCube
+hCube :: [V4 GL.GLfloat]
+hCube =
+  (map (v3tov4 m) cube)
+    ++ (map (v3tov4 p) cube)
+    ++ (map (v3tov4' m) cube)
+    ++ (map (v3tov4' p) cube)
+    ++ (map (v3tov4'' m) cube)
+    ++ (map (v3tov4'' p) cube)
+    ++ (map (v3tov4''' m) cube)
+    ++ (map (v3tov4''' p) cube)
+
 --------------------------------------------------------------------------------
 -- Elm-like data structures
 --------------------------------------------------------------------------------
@@ -100,83 +158,128 @@ testVertices =
 -- | update function
 update :: Float -> Model -> Model
 update dt model =
-  updateVelocity
-    dt
-    $ updateAcceleration
-      dt
-      $ updateCameraAngle
-        dt
+  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
+  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
+      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
+        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)
+   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
+          updateAcceleration dt $
             model
-          { camera = model.camera
-            { airTime = model.camera.airTime + dt
-            , camVel = camVel'
-            , hasJumped = aboveGround
+              { 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
+                { 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
+    { 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
-      }
+  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
@@ -185,17 +288,13 @@ 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
+  let pitch = model.camera.camPitch
       yaw = model.camera.camYaw
       forward = V3 (cos pitch * sin yaw) (sin pitch) (cos pitch * cos yaw)
       viewMatrix =
@@ -203,21 +302,23 @@ view window model = do
           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)
+      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)
+  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