From 2a3c9bdafb22f0ee5353c8ca7761e897b09f1e83 Mon Sep 17 00:00:00 2001 From: andromeda Date: Fri, 6 Feb 2026 01:18:36 +0100 Subject: [PATCH] hypercube, format ig --- flake.nix | 4 + hs-game.cabal | 2 +- src/Game/Internal.hs | 155 +++++++++-------- src/Game/Internal/LoadShaders.hs | 47 +++--- src/Game/Internal/Types.hs | 172 +++++++++++-------- src/Main.hs | 276 ++++++++++++++++++------------- 6 files changed, 375 insertions(+), 281 deletions(-) diff --git a/flake.nix b/flake.nix index fa7666c..526a535 100644 --- a/flake.nix +++ b/flake.nix @@ -16,6 +16,10 @@ devShells.${system} = { default = pkgs.mkShell { packages = [ + # dev stuff + pkgs.haskellPackages.ghcide + pkgs.haskellPackages.ormolu + pkgs.cabal-install pkgs.libGL pkgs.xorg.libX11 diff --git a/hs-game.cabal b/hs-game.cabal index 8975d95..515ed6d 100644 --- a/hs-game.cabal +++ b/hs-game.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hs-game -version: 0.4.0 +version: 0.5.0 -- synopsis: -- description: homepage: https://git.mtgmonkey.net/Andromeda/hs-game diff --git a/src/Game/Internal.hs b/src/Game/Internal.hs index 39f3fd4..e606505 100644 --- a/src/Game/Internal.hs +++ b/src/Game/Internal.hs @@ -1,28 +1,27 @@ -{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} -{- | - - Module : Game.Internal - - Description : internal functions - - Copyright : 2025 Andromeda - - License : BSD 3-clause - - Maintainer : Matrix @Andromeda:tchncs.de - - Stability : Experimental - -} +-- | +-- - 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 Game.Internal.LoadShaders -import Game.Internal.Types + ( cursorPosHandler, + drawObjects, + initResources, + keyPressed, + loop, + resizeWindow, + shutdownWindow, + updateCursorPos, + updateKeyPressed, + updateKeyReleased, + ) +where import Control.Concurrent (threadDelay) import Control.Monad (when) @@ -32,53 +31,56 @@ import Foreign.Marshal.Array (withArray) import Foreign.Ptr (nullPtr, plusPtr) import Foreign.Storable (Storable, sizeOf) import GHC.Float (double2Float) - -import qualified Graphics.Rendering.OpenGL as GL +import Game.Internal.LoadShaders +import Game.Internal.Types import Graphics.Rendering.OpenGL (($=)) +import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.UI.GLFW as GLFW - -import Linear (V3(..)) +import Linear (V3 (..), V4 (..)) -------------------------------------------------------------------------------- -- Shader creation and object initialisation -------------------------------------------------------------------------------- --- | loads models, shaders -initResources :: [[V3 GL.GLfloat]] -> IO ([Object], GL.Program) + +initResources :: [[V4 GL.GLfloat]] -> IO ([Object], GL.Program) initResources arrays = do - -- create objects - objects <- listIOsToIOlist [ createObject arr 3 GL.TriangleStrip | arr <- arrays ] [] - -- load shaders + objects <- + listIOsToIOlist + [createObject arr 4 GL.TriangleStrip (GL.AttribLocation 0) | arr <- arrays] + [] program <- loadShaders - [ ShaderInfo GL.VertexShader (StringSource vertShader) - , ShaderInfo GL.FragmentShader (StringSource fragShader) + [ 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 +listIOsToIOlist (io : ios) out = do ioVal <- io - listIOsToIOlist ios (ioVal:out) + 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" + ++ "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(a_vPos.xyz, 1.0);\n" - ++ " v_pos = a_vPos;\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 @@ -89,23 +91,32 @@ fragShader = ++ "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 -------------------------------------------------------------------------------- + -- | 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 + (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 @@ -115,37 +126,45 @@ createVBO array numComponents attribLocation = do 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.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 + (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 + _ <- 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 () + -- | 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 @@ -183,16 +202,17 @@ updateCursorPos x y model = (((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) - } + 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 @@ -200,6 +220,7 @@ drawObjects ((Object vao numVertices _ primitiveMode):objects) = do -------------------------------------------------------------------------------- -- interrupts -------------------------------------------------------------------------------- + -- | shuts down GLFW shutdownWindow :: GLFW.WindowCloseCallback shutdownWindow window = do diff --git a/src/Game/Internal/LoadShaders.hs b/src/Game/Internal/LoadShaders.hs index 86b549f..43d423b 100644 --- a/src/Game/Internal/LoadShaders.hs +++ b/src/Game/Internal/LoadShaders.hs @@ -1,4 +1,7 @@ -------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- + -- | -- Module : LoadShaders -- Copyright : (c) Sven Panne 2013 @@ -10,13 +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 + ( ShaderSource (..), + ShaderInfo (..), + loadShaders, + ) +where import Control.Exception import Control.Monad @@ -24,14 +26,15 @@ import qualified Data.ByteString as B import Graphics.Rendering.OpenGL -------------------------------------------------------------------------------- + -- | The source of the shader source code. data ShaderSource - = 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'. + = -- | The shader source code is directly given as a 'B.ByteString'. + ByteStringSource B.ByteString + | -- | 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 @@ -40,12 +43,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 = - ShaderInfo ShaderType ShaderSource +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 @@ -60,7 +65,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 @@ -72,12 +77,12 @@ compileAndCheck :: Shader -> IO () compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile" checked :: - (t -> IO ()) - -> (t -> GettableStateVar Bool) - -> (t -> GettableStateVar String) - -> String - -> t - -> IO () + (t -> IO ()) -> + (t -> GettableStateVar Bool) -> + (t -> GettableStateVar String) -> + String -> + t -> + IO () checked action getStatus getInfoLog message object = do action object ok <- get (getStatus object) diff --git a/src/Game/Internal/Types.hs b/src/Game/Internal/Types.hs index 8095cfb..b8e7229 100644 --- a/src/Game/Internal/Types.hs +++ b/src/Game/Internal/Types.hs @@ -1,69 +1,80 @@ -{-# LANGUAGE NamedFieldPuns, OverloadedRecordDot #-} +{-# 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 +-- - 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) - , mkModel - , Camera(camPos, camPitch, camYaw, camReference, mouseSensitivity, camVel, strafeStrength, jumpStrength, hasJumped, airTime) - , mkCamera - , WorldProperties(g, friction, up) - , mkWorldProperties - ) where + ( 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, + ) +where 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 - } deriving (Show) + { -- | 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) -- | 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 + [ 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 - } deriving (Show) + { 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) -- | smart constructor for Model mkModel :: Camera -> [Object] -> GL.Program -> WorldProperties -> Model @@ -72,29 +83,40 @@ mkModel camera 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 - } deriving (Show) + { -- | 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) -- | smart constructor for Camera mkCamera :: - V3 Float - -> Float - -> Float - -> V3 Float - -> V3 Float - -> Float - -> Float - -> Float - -> Camera + V3 Float -> + Float -> + Float -> + V3 Float -> + V3 Float -> + Float -> + Float -> + Float -> + Camera mkCamera camPos camPitch camYaw camReference camVel mouseSensitivity strafeStrength jumpStrength = Camera camPos @@ -110,10 +132,14 @@ mkCamera camPos camPitch camYaw camReference camVel mouseSensitivity strafeStren -- | 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) + { -- | gravity `g` + g :: Float, + -- | scale factor for floor friction + friction :: Float, + -- | global up vector + up :: V3 Float + } + deriving (Show) -- | smart constructor for WorldProperties mkWorldProperties :: Float -> Float -> V3 Float -> WorldProperties diff --git a/src/Main.hs b/src/Main.hs index 6dec8ad..2786f86 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,30 +1,29 @@ -{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} -{- | - - Module : Game - - Description : runs game - - Copyright : 2025 Andromeda - - License : BSD 3-clause - - Maintainer : Matrix @Andromeda:tchncs.de - - Stability : Experimental - -} +-- | +-- - Module : 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 + ( main, + ) +where import Control.Lens ((^.)) import Data.IORef (newIORef) import GHC.Float (double2Float) - -import qualified Graphics.Rendering.OpenGL as GL +import Game.Internal +import Game.Internal.Types import Graphics.Rendering.OpenGL (($=)) +import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.UI.GLFW as GLFW - +import Linear (V3 (..), V4 (..), _y) import qualified Linear as L -import Linear (V3(..), _y) -- | Main function runs game main :: IO () @@ -47,21 +46,23 @@ main = do 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 + (objects, program) <- + initResources $ + -- [map (v3tov4 0) $ map (+ V3 a 0 0) cube | a <- take 100 [0, 2 ..]] + [hCube] + 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 - ) + ( 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)) @@ -76,84 +77,114 @@ main = do -------------------------------------------------------------------------------- top :: [V3 GL.GLfloat] top = - [ V3 p 0 p - , V3 p 0 m - , V3 m 0 p - , V3 m 0 m + [ 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 + [ 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 + [ 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 +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 + [ 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 -------------------------------------------------------------------------------- + -- | update function update :: Float -> Model -> Model update dt model = - updateVelocity dt - $ updateAcceleration dt - $ updateSpeed dt - $ updateCameraAngle 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 + 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 = @@ -186,42 +217,47 @@ updateAcceleration dt model = 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 - } + 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 - } + } + 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} + { camPos = model.camera.camPos + dt L.*^ model.camera.camVel + } } updateCameraAngle :: Float -> Model -> Model @@ -242,8 +278,8 @@ updateCameraAngle dt model = model.camera.camYaw + scaleFactor * (double2Float $ fst model.cursorDeltaPos) in model - { cursorDeltaPos = (0, 0) - , camera = model.camera {camPitch = newPitch'', camYaw = newYaw} + { cursorDeltaPos = (0, 0), + camera = model.camera {camPitch = newPitch'', camYaw = newYaw} } -- | views the model @@ -269,13 +305,15 @@ view window model = do projectionMatrix = L.perspective 1.2 (fromIntegral w / fromIntegral h) 0.01 1000 viewGLMatrix <- - GL.newMatrix GL.RowMajor $ toGLMatrix viewMatrix :: IO - (GL.GLmatrix GL.GLfloat) + 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) + 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 []