diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Game/Main.hs | 287 | ||||
| -rw-r--r-- | src/Game/Types.hs | 128 |
2 files changed, 287 insertions, 128 deletions
diff --git a/src/Game/Main.hs b/src/Game/Main.hs index 89cab32..5ba5bd7 100644 --- a/src/Game/Main.hs +++ b/src/Game/Main.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fwarn-name-shadowing #-} +{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-} {- | - Module : Game - Description : runs game @@ -10,21 +10,29 @@ module Game (main) where import Game.LoadShaders +import Game.Types import Control.Concurrent (threadDelay) +import Control.Lens ((^.), (+~), (&), (%~)) import Control.Monad (when) -import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) -import Data.List (delete, nub) +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 (V2, V3, V4, M44, V2(..), V3(..), V4(..)) +import Linear ( V3(..) + , _x + , _y + , _z + ) -- | Main function runs game main :: IO () @@ -49,31 +57,38 @@ main = do GLFW.setWindowCloseCallback window $ Just shutdownWindow GLFW.setWindowSizeCallback window $ Just resizeWindow GLFW.setKeyCallback window $ Just (keyPressed Nothing) + GLFW.setCursorPosCallback window $ Just (cursorPosHandler Nothing) (objects, program) <- initResources window -- init model - let model = - Model - objects - (Camera - (V3 0 0 3) - (V3 0 0 0) - (V3 0 1 0) - (V3 0 0 0) - ) - program - [] - (WorldProperties - 600 - 300 - ) + let + model = + mkModel + (mkCamera + (V3 0 0 3) -- camPos + 0 -- pitch + 0 -- yaw + (V3 0 0 (-1)) -- reference vector + (V3 0 0 0) -- velocity + 0.08 -- mouse sensitivity + 16 -- strafe strength + 12 -- jump strength + ) + objects + program + (mkWorldProperties + 2 + 0.16 + (V3 0 1 0) + ) modelRef <- newIORef model - -- add key callback with io ref to model + -- add callbacks with io ref to model GLFW.setKeyCallback window $ Just $ keyPressed $ Just modelRef + GLFW.setCursorPosCallback window $ Just $ cursorPosHandler $ Just modelRef - loop window update view modelRef + loop window (update 0) view modelRef -------------------------------------------------------------------------------- -- Arrays @@ -122,9 +137,11 @@ vertShader = "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 @@ -132,9 +149,10 @@ 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, 0.5, 1.0);\n" ++ + " o_vColor = vec4(0.5 + 0.5 * v_pos, 1);\n" ++ "}" -------------------------------------------------------------------------------- @@ -200,14 +218,6 @@ createObject array numComponents primitiveMode = do primitiveMode ) --- | represents a single draw call -data Object = - Object - GL.VertexArrayObject - GL.NumArrayIndices - GL.NumComponents - GL.PrimitiveMode - -------------------------------------------------------------------------------- -- Elm-like data structures -------------------------------------------------------------------------------- @@ -224,90 +234,135 @@ loop window update view modelRef = do Just frameStart <- GLFW.getTime -- tick model - model <- readIORef modelRef - let model' = update model - writeIORef modelRef 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 = frameEnd - frameStart :: Double - target = 1 / 30 :: Double + 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 update view modelRef + loop window (Game.update dt') view modelRef -- | update function -update :: Model -> Model -update model = +update :: Float -> Model -> Model +update dt model = updateVelocity + dt $ updateAcceleration + dt + $ updateCameraAngle + dt model -updateAcceleration :: Model -> Model -updateAcceleration model = model +updateAcceleration :: Float -> Model -> Model +updateAcceleration dt model = + let + yaw = (L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) model.camera.camReference) + front = L.normalize $ (V3 1 0 1) * (L.rotate (L.axisAngle (L.cross model.wprop.up yaw) model.camera.camPitch) yaw) + zp = if elem GLFW.Key'S model.keys then 1 else 0 + zn = if elem GLFW.Key'W model.keys then 1 else 0 + xp = if elem GLFW.Key'D model.keys then 1 else 0 + xn = if elem GLFW.Key'A model.keys then 1 else 0 + x = xn - xp + z = zn - zp + friction = V3 (1 - model.wprop.friction) 1 (1 - model.wprop.friction) + movement = L.normalize (V3 x 0 z) L.^* (dt * model.camera.strafeStrength) + movement' = L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) movement + jump = + if model.camera.hasJumped then + V3 0 (0 - model.wprop.g * model.camera.airTime) 0 + else + V3 0 0 0 + camVel' = friction * (model.camera.camVel + movement' + jump) + aboveGround = (model.camera.camPos + dt L.*^ camVel') ^. _y > 0 + in + if + (elem GLFW.Key'Space model.keys) + && (model.camera.hasJumped == False) + then + updateAcceleration dt $ model { camera = model.camera { airTime = dt, camVel = model.camera.camVel + (V3 0 model.camera.jumpStrength 0), hasJumped = True } } + else + if aboveGround then + model + { camera = model.camera + { airTime = model.camera.airTime + dt + , camVel = camVel' + , hasJumped = aboveGround + } + } + else + model + { camera = model.camera + { airTime = 0 + , camVel = camVel' * (V3 1 0 1) + , camPos = model.camera.camPos * (V3 1 0 1) + , hasJumped = aboveGround + } + } -updateVelocity :: Model -> Model -updateVelocity model = model - +updateVelocity :: Float -> Model -> Model +updateVelocity dt model = + model + { camera = model.camera + { camPos = model.camera.camPos + dt L.*^ model.camera.camVel + } + } + +updateCameraAngle :: Float -> Model -> Model +updateCameraAngle dt model = + let + 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) + 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) + } + } -- | updates given a keypress. escape case is probably caught by GLFW in the -- handler function itself updateKeyPressed :: GLFW.Key -> Model -> Model -updateKeyPressed - key - (Model - objects - camera - program - keys - wprops - ) = - Model - objects - camera - program - (nub $ key:keys) - wprops +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 - objects - camera - program - keys - wprops - ) = - Model - objects - camera - program - (delete key keys) - wprops +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@(Model - objects - (Camera - camPos - camTarget - camUp - velocity - ) - program - _ - _ - )) = do +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)) @@ -318,19 +373,24 @@ view -- apply transforms let - viewMatrix = L.lookAt camPos camTarget camUp - projectionMatrix = L.perspective 1.4 (fromIntegral w / fromIntegral h) 0.1 100 + yaw = (L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) model.camera.camReference) + viewMatrix = + L.lookAt + model.camera.camPos + (model.camera.camPos + L.rotate (L.axisAngle (L.cross model.wprop.up yaw) model.camera.camPitch) yaw) + model.wprop.up + projectionMatrix = L.perspective 1.5 (fromIntegral w / fromIntegral h) 0.1 100 viewGLMatrix <- GL.newMatrix GL.RowMajor $ toGLMatrix viewMatrix :: IO (GL.GLmatrix GL.GLfloat) - viewLocation <- GL.get $ GL.uniformLocation program "u_view" + viewLocation <- GL.get $ GL.uniformLocation model.program "u_view" GL.uniform viewLocation $= viewGLMatrix projectionGLMatrix <- GL.newMatrix GL.RowMajor $ toGLMatrix projectionMatrix :: IO (GL.GLmatrix GL.GLfloat) - projectionLocation <- GL.get $ GL.uniformLocation program "u_projection" + projectionLocation <- GL.get $ GL.uniformLocation model.program "u_projection" GL.uniform projectionLocation $= projectionGLMatrix -- draw objects - drawObjects objects + drawObjects model.objects -- swap to current buffer GLFW.swapBuffers window @@ -338,41 +398,6 @@ view -- check for interrupts GLFW.pollEvents -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 - [Object] - Camera - GL.Program - [GLFW.Key] - WorldProperties - --- | camera -data Camera = - Camera - (V3 Float) -- ^ camera location - (V3 Float) -- ^ camera target - (V3 Float) -- ^ camera up vector - (V3 Float) -- ^ velocity - -data WorldProperties = - WorldProperties - Float -- ^ gravity `g` - Float -- ^ floor friction - -- | draws objects drawObjects :: [Object] -> IO ([Object]) drawObjects [] = return [] @@ -405,3 +430,9 @@ keyPressed (Just modelRef) window key _ GLFW.KeyState'Pressed _ = 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 new file mode 100644 index 0000000..738205f --- /dev/null +++ b/src/Game/Types.hs @@ -0,0 +1,128 @@ +{-# 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) |