From 852244a49159097a83fc99edcdad26f84f999098 Mon Sep 17 00:00:00 2001 From: mtgmonkey Date: Sun, 7 Dec 2025 23:52:20 +0100 Subject: add changelog; see changelog <3 --- src/Game/Internal.hs | 267 +++++++++++++++++++++++++++++++++++++++ src/Game/Internal/LoadShaders.hs | 89 +++++++++++++ src/Game/Internal/Types.hs | 145 +++++++++++++++++++++ src/Game/LoadShaders.hs | 89 ------------- src/Game/Main.hs | 253 +++++-------------------------------- src/Game/Types.hs | 128 ------------------- 6 files changed, 530 insertions(+), 441 deletions(-) create mode 100644 src/Game/Internal.hs create mode 100644 src/Game/Internal/LoadShaders.hs create mode 100644 src/Game/Internal/Types.hs delete mode 100644 src/Game/LoadShaders.hs delete mode 100644 src/Game/Types.hs (limited to 'src') diff --git a/src/Game/Internal.hs b/src/Game/Internal.hs new file mode 100644 index 0000000..bb9da57 --- /dev/null +++ b/src/Game/Internal.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-} +{- | + - Module : Game.Internal + - Description : 'hidden' functions + - Copyright : Andromeda 2025 + - License : WTFPL + - 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 + +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) + +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 + ) + +-------------------------------------------------------------------------------- +-- Shader creation and object initialisation +-------------------------------------------------------------------------------- + +-- | loads models, shaders +initResources :: GLFW.Window -> [V3 GL.GLfloat] -> IO ([Object], GL.Program) +initResources window 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) + ] + GL.currentProgram $= Just program + + return (objects, program) + +-- a_ vertex shader input +-- v_ varying +-- u_ uniform +-- o_ fragment shader output + +-- | vertex shader +vertShader :: String +vertShader = + "#version 330 core\n" ++ + "layout (location = 0) in vec3 a_vPos;\n" ++ + "uniform mat4 u_view;\n" ++ + "uniform mat4 u_projection;\n" ++ + "out vec3 v_pos;\n" ++ + "void main()\n" ++ + "{\n" ++ + " gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n" ++ + " v_pos = a_vPos;\n" ++ + "}" + +-- | 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" ++ + "}" + +-------------------------------------------------------------------------------- +-- Objects +-------------------------------------------------------------------------------- + +-- | calculates the size in memory of an array +sizeOfArray :: (Storable a, Num b) => [a] -> b +sizeOfArray [] = 0 +sizeOfArray (x:xs) = fromIntegral $ (*) (1 + length xs) $ sizeOf x + +-- | loads a given array into a given attribute index +createVBO + :: Storable (a GL.GLfloat) + => [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 -> + 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.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 + -- 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 + ) + +-------------------------------------------------------------------------------- +-- 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 dt update view modelRef = do + -- start frame timer + Just frameStart <- GLFW.getTime + + -- tick model + modifyIORef' modelRef $ update dt + model' <- readIORef modelRef + + -- view new model + view window model' + + -- end frame timer, wait the difference between expected and actual + Just frameEnd <- GLFW.getTime + let + dt = double2Float $ frameEnd - frameStart + target = 1 / 60 :: Float + when (dt < target) $ threadDelay $ floor $ (target - dt) * 1000000 + Just frameEnd' <- GLFW.getTime + 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 } + +-- | 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) } + +applyToTuples :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c) +applyToTuples f (x, y) (a, b) = (f x a, f y b) + +-- | updates cursor +updateCursorPos :: Double -> Double -> Model -> Model +updateCursorPos x y model = + let + pyth = (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos - y)) ** 2) ** 0.5 + in + if pyth < 16 then + model + { cursorPos = (x, y) + , cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y) + } + else + model + { cursorPos = (x, y) + } + +-- | draws objects +drawObjects :: [Object] -> IO ([Object]) +drawObjects [] = return [] +drawObjects + ((Object vao numVertices _ primitiveMode):objects) = do + GL.bindVertexArrayObject $= Just vao + GL.drawArrays primitiveMode 0 numVertices + drawObjects objects + +-------------------------------------------------------------------------------- +-- interrupts +-------------------------------------------------------------------------------- + +-- | shuts down GLFW +shutdownWindow :: GLFW.WindowCloseCallback +shutdownWindow window = do + GLFW.destroyWindow window + GLFW.terminate + +-- | resizes viewport with window +resizeWindow :: GLFW.WindowSizeCallback +resizeWindow _ _ _ = return () + +-- | handles key presses +keyPressed :: Maybe (IORef Model) -> GLFW.KeyCallback +keyPressed _ window GLFW.Key'Escape _ GLFW.KeyState'Pressed _ = + shutdownWindow window +keyPressed (Just modelRef) window key _ GLFW.KeyState'Pressed _ = + modifyIORef' modelRef $ updateKeyPressed key +keyPressed (Just modelRef) window key _ GLFW.KeyState'Released _ = + modifyIORef' modelRef $ updateKeyReleased key +keyPressed _ _ _ _ _ _ = return () + +-- | handles cursor position updates +cursorPosHandler :: Maybe (IORef Model) -> GLFW.CursorPosCallback +cursorPosHandler (Just modelRef) _ x y = + modifyIORef' modelRef $ updateCursorPos x y +cursorPosHandler Nothing _ _ _ = return () diff --git a/src/Game/Internal/LoadShaders.hs b/src/Game/Internal/LoadShaders.hs new file mode 100644 index 0000000..ded2da9 --- /dev/null +++ b/src/Game/Internal/LoadShaders.hs @@ -0,0 +1,89 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : LoadShaders +-- Copyright : (c) Sven Panne 2013 +-- License : BSD3 +-- +-- Maintainer : Sven Panne +-- Stability : stable +-- Portability : portable +-- +-- Utilities for shader handling, adapted from LoadShaders.cpp which is (c) The +-- Red Book Authors. +-- +-------------------------------------------------------------------------------- + +module Game.Internal.LoadShaders ( + ShaderSource(..), ShaderInfo(..), loadShaders +) where + +import Control.Exception +import Control.Monad +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'. + deriving ( Eq, Ord, Show ) + +getSource :: ShaderSource -> IO B.ByteString +getSource (ByteStringSource bs) = return bs +getSource (StringSource str) = return $ packUtf8 str +getSource (FileSource path) = B.readFile path + +-------------------------------------------------------------------------------- + +-- | A description of a shader: The type of the shader plus its source code. + +data ShaderInfo = ShaderInfo ShaderType ShaderSource + deriving ( Eq, Ord, Show ) + +-------------------------------------------------------------------------------- + +-- | Create a new program object from the given shaders, throwing an +-- 'IOException' if something goes wrong. + +loadShaders :: [ShaderInfo] -> IO Program +loadShaders infos = + createProgram `bracketOnError` deleteObjectName $ \program -> do + loadCompileAttach program infos + linkAndCheck program + return program + +linkAndCheck :: Program -> IO () +linkAndCheck = checked linkProgram linkStatus programInfoLog "link" + +loadCompileAttach :: Program -> [ShaderInfo] -> IO () +loadCompileAttach _ [] = return () +loadCompileAttach program (ShaderInfo shType source : infos) = + createShader shType `bracketOnError` deleteObjectName $ \shader -> do + src <- getSource source + shaderSourceBS shader $= src + compileAndCheck shader + attachShader program shader + loadCompileAttach program infos + +compileAndCheck :: Shader -> IO () +compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile" + +checked :: (t -> IO ()) + -> (t -> GettableStateVar Bool) + -> (t -> GettableStateVar String) + -> String + -> t + -> IO () +checked action getStatus getInfoLog message object = do + action object + ok <- get (getStatus object) + unless ok $ do + infoLog <- get (getInfoLog object) + fail (message ++ " log: " ++ infoLog) diff --git a/src/Game/Internal/Types.hs b/src/Game/Internal/Types.hs new file mode 100644 index 0000000..719905e --- /dev/null +++ b/src/Game/Internal/Types.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE NamedFieldPuns, OverloadedRecordDot #-} +{- | + - Module : Game.Types + - Description : + - Copyright : Andromeda 2025 + - License : WTFPL + - 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 + +import qualified Graphics.UI.GLFW as GLFW +import qualified Graphics.Rendering.OpenGL as GL + +import qualified Linear as L +import Linear (Quaternion, V3, V3(..), V4(..)) + +-- | represents a single draw call +data Object = + Object + { vao :: GL.VertexArrayObject + , numIndicies :: GL.NumArrayIndices + , numComponents :: GL.NumComponents + , primitiveMode :: GL.PrimitiveMode + } + deriving Show + +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 + ] + +-- | gamestate +data Model = + Model + { camera :: Camera + , cursorDeltaPos :: (Double, Double) + , cursorPos :: (Double, Double) + , keys :: [GLFW.Key] + , objects :: [Object] + , program :: GL.Program + , wprop :: WorldProperties + } + deriving Show + +mkModel :: Camera -> [Object] -> GL.Program -> WorldProperties -> Model +mkModel camera objects program wprop = Model camera (0,0) (0,0) [] objects program wprop + +-- | camera +data Camera = + Camera + { camPos :: V3 Float + , camPitch :: Float + , camYaw :: Float + , camReference :: V3 Float + , camVel :: V3 Float + , mouseSensitivity :: Float + , strafeStrength :: Float + , jumpStrength :: Float + , hasJumped :: Bool + , airTime :: Float + } + deriving Show + +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 + camYaw + (L.normalize camReference) + (L.normalize camVel) + mouseSensitivity + strafeStrength + jumpStrength + False + 0 + +data WorldProperties = + WorldProperties + { g :: Float -- ^ gravity `g` + , friction :: Float -- ^ floor friction + , up :: V3 Float + } + deriving Show + +mkWorldProperties :: Float -> Float -> V3 Float-> WorldProperties +mkWorldProperties g friction up = + WorldProperties g friction (L.normalize up) diff --git a/src/Game/LoadShaders.hs b/src/Game/LoadShaders.hs deleted file mode 100644 index 3d24e78..0000000 --- a/src/Game/LoadShaders.hs +++ /dev/null @@ -1,89 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : LoadShaders --- Copyright : (c) Sven Panne 2013 --- License : BSD3 --- --- Maintainer : Sven Panne --- Stability : stable --- Portability : portable --- --- Utilities for shader handling, adapted from LoadShaders.cpp which is (c) The --- Red Book Authors. --- --------------------------------------------------------------------------------- - -module Game.LoadShaders ( - ShaderSource(..), ShaderInfo(..), loadShaders -) where - -import Control.Exception -import Control.Monad -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'. - deriving ( Eq, Ord, Show ) - -getSource :: ShaderSource -> IO B.ByteString -getSource (ByteStringSource bs) = return bs -getSource (StringSource str) = return $ packUtf8 str -getSource (FileSource path) = B.readFile path - --------------------------------------------------------------------------------- - --- | A description of a shader: The type of the shader plus its source code. - -data ShaderInfo = ShaderInfo ShaderType ShaderSource - deriving ( Eq, Ord, Show ) - --------------------------------------------------------------------------------- - --- | Create a new program object from the given shaders, throwing an --- 'IOException' if something goes wrong. - -loadShaders :: [ShaderInfo] -> IO Program -loadShaders infos = - createProgram `bracketOnError` deleteObjectName $ \program -> do - loadCompileAttach program infos - linkAndCheck program - return program - -linkAndCheck :: Program -> IO () -linkAndCheck = checked linkProgram linkStatus programInfoLog "link" - -loadCompileAttach :: Program -> [ShaderInfo] -> IO () -loadCompileAttach _ [] = return () -loadCompileAttach program (ShaderInfo shType source : infos) = - createShader shType `bracketOnError` deleteObjectName $ \shader -> do - src <- getSource source - shaderSourceBS shader $= src - compileAndCheck shader - attachShader program shader - loadCompileAttach program infos - -compileAndCheck :: Shader -> IO () -compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile" - -checked :: (t -> IO ()) - -> (t -> GettableStateVar Bool) - -> (t -> GettableStateVar String) - -> String - -> t - -> IO () -checked action getStatus getInfoLog message object = do - action object - ok <- get (getStatus object) - unless ok $ do - infoLog <- get (getInfoLog object) - fail (message ++ " log: " ++ infoLog) diff --git a/src/Game/Main.hs b/src/Game/Main.hs index 5ba5bd7..7aeb2a5 100644 --- a/src/Game/Main.hs +++ b/src/Game/Main.hs @@ -9,8 +9,9 @@ -} module Game (main) where -import Game.LoadShaders -import Game.Types +import Game.Internal.LoadShaders +import Game.Internal.Types +import Game.Internal import Control.Concurrent (threadDelay) import Control.Lens ((^.), (+~), (&), (%~)) @@ -21,7 +22,7 @@ import Data.List (delete) import Foreign.Marshal.Array (withArray) import Foreign.Ptr (nullPtr, plusPtr) import Foreign.Storable (sizeOf, Storable) -import GHC.Float (double2Float) +import GHC.Float (double2Float, int2Double) import qualified Graphics.UI.GLFW as GLFW import qualified Graphics.Rendering.OpenGL as GL @@ -45,8 +46,8 @@ main = do GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 3 GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core - -- 4x MSAA - GLFW.windowHint $ GLFW.WindowHint'Samples $ Just 4 + -- MSAA + GLFW.windowHint $ GLFW.WindowHint'Samples $ Just 8 -- create window monitor <- GLFW.getPrimaryMonitor @@ -57,9 +58,10 @@ main = do 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 + (objects, program) <- initResources window testVertices -- init model let @@ -71,7 +73,7 @@ main = do 0 -- yaw (V3 0 0 (-1)) -- reference vector (V3 0 0 0) -- velocity - 0.08 -- mouse sensitivity + 2 -- mouse sensitivity 16 -- strafe strength 12 -- jump strength ) @@ -88,7 +90,7 @@ main = do GLFW.setKeyCallback window $ Just $ keyPressed $ Just modelRef GLFW.setCursorPosCallback window $ Just $ cursorPosHandler $ Just modelRef - loop window (update 0) view modelRef + loop window 0 update view modelRef -------------------------------------------------------------------------------- -- Arrays @@ -103,158 +105,10 @@ testVertices = , V3 0.5 0.5 0 ] --------------------------------------------------------------------------------- --- Shader creation and object initialisation --------------------------------------------------------------------------------- - --- | loads models, shaders -initResources :: GLFW.Window -> IO ([Object], GL.Program) -initResources window = do - -- create objects - testObject0 <- createObject (map (+(V3 (-1) (-1) (-1))) testVertices) 3 GL.TriangleStrip - testObject1 <- createObject (map (+(V3 (1) (1) (1))) testVertices) 3 GL.TriangleStrip - testObject2 <- createObject testVertices 3 GL.TriangleStrip - let objects = [testObject0, testObject1, testObject2] - - -- load shaders - program <- loadShaders - [ ShaderInfo GL.VertexShader (StringSource vertShader) - , ShaderInfo GL.FragmentShader (StringSource fragShader) - ] - GL.currentProgram $= Just program - - return (objects, program) - --- a_ vertex shader input --- v_ varying --- u_ uniform --- o_ fragment shader output - --- | vertex shader -vertShader :: String -vertShader = - "#version 330 core\n" ++ - "layout (location = 0) in vec3 a_vPos;\n" ++ - "uniform mat4 u_view;\n" ++ - "uniform mat4 u_projection;\n" ++ - "out vec3 v_pos;\n" ++ - "void main()\n" ++ - "{\n" ++ - " gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n" ++ - " v_pos = a_vPos;\n" ++ - "}" - --- | 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" ++ - "}" - --------------------------------------------------------------------------------- --- Objects --------------------------------------------------------------------------------- - --- | calculates the size in memory of an array -sizeOfArray :: (Storable a, Num b) => [a] -> b -sizeOfArray [] = 0 -sizeOfArray (x:xs) = fromIntegral $ (*) (1 + length xs) $ sizeOf x - --- | loads a given array into a given attribute index -createVBO - :: Storable (a GL.GLfloat) - => [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 -> - 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.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 - -- 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 - ) - -------------------------------------------------------------------------------- -- Elm-like data structures -------------------------------------------------------------------------------- --- | gameloop -loop - :: GLFW.Window -- ^ window to display on - -> (Model -> Model) -- ^ update function - -> (GLFW.Window -> Model -> IO ()) -- ^ view function - -> IORef Model -- ^ model - -> IO () -loop window update view modelRef = do - -- start frame timer - Just frameStart <- GLFW.getTime - - -- tick model - modifyIORef' modelRef $ update - model' <- readIORef modelRef - - -- view new model - view window model' - - putStrLn $ (++) "pitch" $ show model'.camera.camPitch - putStrLn $ (++) "yaw" $ show model'.camera.camYaw - - -- end frame timer, wait the difference between expected and actual - Just frameEnd <- GLFW.getTime - let - dt = double2Float $ frameEnd - frameStart - target = 1 / 60 :: Float - when (dt < target) $ threadDelay $ floor $ (target - dt) * 1000000 - Just frameEnd' <- GLFW.getTime - let - dt' = double2Float $ frameEnd' - frameStart - - loop window (Game.update dt') view modelRef - -- | update function update :: Float -> Model -> Model update dt model = @@ -275,8 +129,8 @@ updateAcceleration dt model = 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 = xn - xp - z = zn - zp + 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 @@ -323,17 +177,19 @@ updateVelocity dt model = updateCameraAngle :: Float -> Model -> Model updateCameraAngle dt model = let - newPitch = model.camera.camPitch - model.camera.mouseSensitivity * dt * (double2Float $ snd model.cursorDeltaPos) - newPitch' = if newPitch >= (pi / 2) then (0.9999 * pi / 2) else newPitch - newPitch'' = if newPitch <= ((-1) * pi / 2) then ((-0.9999) * pi / 2) else newPitch - newYaw = model.camera.camYaw + model.camera.mouseSensitivity * dt * (double2Float $ fst model.cursorDeltaPos) - newYaw' = newYaw - (mod' newYaw pi) + 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 = model.camera.camPitch + dt * (double2Float $ snd model.cursorDeltaPos) - , camYaw = model.camera.camYaw + dt * (double2Float $ fst model.cursorDeltaPos) + { camPitch = newPitch'' + , camYaw = newYaw } } @@ -343,23 +199,6 @@ updateKeyPressed :: GLFW.Key -> Model -> Model 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) } - -applyToTuples :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c) -applyToTuples f (x, y) (a, b) = (f x a, f y b) - --- | updates cursor -updateCursorPos :: Double -> Double -> Model -> Model -updateCursorPos x y model = - model - { cursorPos = (x, y) - , cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y) - } - -- | views the model view :: GLFW.Window -> Model -> IO () view window model = do @@ -371,15 +210,20 @@ view window model = do GL.clearColor $= GL.Color4 1 0 1 1 GL.clear [GL.ColorBuffer, GL.DepthBuffer] + -- depth + GL.depthFunc $= Just GL.Less + -- apply transforms let - yaw = (L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) model.camera.camReference) + 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 + L.rotate (L.axisAngle (L.cross model.wprop.up yaw) model.camera.camPitch) yaw) + (model.camera.camPos - forward) model.wprop.up - projectionMatrix = L.perspective 1.5 (fromIntegral w / fromIntegral h) 0.1 100 + 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" @@ -397,42 +241,3 @@ view window model = do -- check for interrupts GLFW.pollEvents - --- | draws objects -drawObjects :: [Object] -> IO ([Object]) -drawObjects [] = return [] -drawObjects - ((Object vao numVertices _ primitiveMode):objects) = do - GL.bindVertexArrayObject $= Just vao - GL.drawArrays primitiveMode 0 numVertices - drawObjects objects - --------------------------------------------------------------------------------- --- interrupts --------------------------------------------------------------------------------- - --- | shuts down GLFW -shutdownWindow :: GLFW.WindowCloseCallback -shutdownWindow window = do - GLFW.destroyWindow window - GLFW.terminate - --- | resizes viewport with window -resizeWindow :: GLFW.WindowSizeCallback -resizeWindow _ _ _ = return () - --- | handles key presses -keyPressed :: Maybe (IORef Model) -> GLFW.KeyCallback -keyPressed _ window GLFW.Key'Escape _ GLFW.KeyState'Pressed _ = - shutdownWindow window -keyPressed (Just modelRef) window key _ GLFW.KeyState'Pressed _ = - modifyIORef' modelRef $ updateKeyPressed key -keyPressed (Just modelRef) window key _ GLFW.KeyState'Released _ = - modifyIORef' modelRef $ updateKeyReleased key -keyPressed _ _ _ _ _ _ = return () - --- | handles cursor position updates -cursorPosHandler :: Maybe (IORef Model) -> GLFW.CursorPosCallback -cursorPosHandler (Just modelRef) _ x y = - modifyIORef' modelRef $ updateCursorPos x y -cursorPosHandler Nothing _ _ _ = return () diff --git a/src/Game/Types.hs b/src/Game/Types.hs deleted file mode 100644 index 738205f..0000000 --- a/src/Game/Types.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE NamedFieldPuns, OverloadedRecordDot #-} -{- | - - Module : Game.Types - - Description : - - Copyright : Andromeda 2025 - - License : WTFPL - - Maintainer : Matrix @Andromeda:tchncs.de - - Stability : Experimental - -} -module Game.Types - ( Object(..) - - , toGLMatrix - - , Model (objects, camera, cursorDeltaPos, cursorPos, program, keys, wprop) - , mkModel - - , Camera (camPos, camPitch, camYaw, camReference, mouseSensitivity, camVel, strafeStrength, jumpStrength, hasJumped, airTime) - , mkCamera - - , WorldProperties (g, friction, up) - , mkWorldProperties - - ) where - -import qualified Graphics.UI.GLFW as GLFW -import qualified Graphics.Rendering.OpenGL as GL - -import qualified Linear as L -import Linear (Quaternion, V3, V3(..), V4(..)) - --- | represents a single draw call -data Object = - Object - { vao :: GL.VertexArrayObject - , numIndicies :: GL.NumArrayIndices - , numComponents :: GL.NumComponents - , primitiveMode :: GL.PrimitiveMode - } - deriving Show - -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 - ] - --- | gamestate -data Model = - Model - { camera :: Camera - , cursorDeltaPos :: (Double, Double) - , cursorPos :: (Double, Double) - , keys :: [GLFW.Key] - , objects :: [Object] - , program :: GL.Program - , wprop :: WorldProperties - } - deriving Show - -mkModel :: Camera -> [Object] -> GL.Program -> WorldProperties -> Model -mkModel camera objects program wprop = Model camera (0,0) (0,0) [] objects program wprop - --- | camera -data Camera = - Camera - { camPos :: V3 Float - , camPitch :: Float - , camYaw :: Float - , camReference :: V3 Float - , camVel :: V3 Float - , mouseSensitivity :: Float - , strafeStrength :: Float - , jumpStrength :: Float - , hasJumped :: Bool - , airTime :: Float - } - deriving Show - -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 - camYaw - (L.normalize camReference) - (L.normalize camVel) - mouseSensitivity - strafeStrength - jumpStrength - False - 0 - -data WorldProperties = - WorldProperties - { g :: Float -- ^ gravity `g` - , friction :: Float -- ^ floor friction - , up :: V3 Float - } - deriving Show - -mkWorldProperties :: Float -> Float -> V3 Float-> WorldProperties -mkWorldProperties g friction up = - WorldProperties g friction (L.normalize up) -- cgit v1.3.1