From 20ecde081bf47c7790e93dd2282d5e666e01b9ce Mon Sep 17 00:00:00 2001 From: mtgmonkey Date: Mon, 8 Dec 2025 13:40:11 +0100 Subject: release v0.2.0 --- src/Game.hs | 223 +++++++++++++++++++++++++++++++++++++++++ src/Game/Internal.hs | 31 +++--- src/Game/Internal/Types.hs | 74 ++++++++------ src/Game/Main.hs | 243 --------------------------------------------- 4 files changed, 281 insertions(+), 290 deletions(-) create mode 100644 src/Game.hs delete mode 100644 src/Game/Main.hs (limited to 'src') diff --git a/src/Game.hs b/src/Game.hs new file mode 100644 index 0000000..f120a6f --- /dev/null +++ b/src/Game.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-} +{- | + - Module : Game + - Description : runs game + - Copyright : 2025 Andromeda + - License : BSD 3-clause + - Maintainer : Matrix @Andromeda:tchncs.de + - Stability : Experimental + -} +module Game (main) where + +import Game.Internal.Types +import Game.Internal + +import Control.Lens ((^.)) +import Data.IORef (newIORef) +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(..), _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 testVertices + + -- init model + let + model = + mkModel + (mkCamera + (V3 0 0 3) -- camPos + 0 -- pitch + 0 -- yaw + (V3 0 0 (-1)) -- reference vector + (V3 0 0 0) -- velocity + 2 -- mouse sensitivity + 16 -- strafe strength + 12 -- jump strength + ) + objects + program + (mkWorldProperties + 2 + 0.16 + (V3 0 1 0) + ) + modelRef <- newIORef model + + -- add callbacks with io ref to model + GLFW.setKeyCallback window $ Just $ keyPressed $ Just modelRef + GLFW.setCursorPosCallback window $ Just $ cursorPosHandler $ Just modelRef + + loop window 0 update view modelRef + +-------------------------------------------------------------------------------- +-- Arrays +-------------------------------------------------------------------------------- + +-- | centered unit square +testVertices :: [V3 GL.GLfloat] +testVertices = + [ V3 (-0.5) (-0.5) 0 + , V3 0.5 (-0.5) 0 + , V3 (-0.5) 0.5 0 + , V3 0.5 0.5 0 + ] + +-------------------------------------------------------------------------------- +-- Elm-like data structures +-------------------------------------------------------------------------------- + +-- | update function +update :: Float -> Model -> Model +update dt model = + updateVelocity + dt + $ updateAcceleration + dt + $ updateCameraAngle + dt + model + +updateAcceleration :: Float -> Model -> Model +updateAcceleration dt model = + let + zp = if elem GLFW.Key'S model.keys then 1 else 0 + zn = if elem GLFW.Key'W model.keys then 1 else 0 + xp = if elem GLFW.Key'D model.keys then 1 else 0 + xn = if elem GLFW.Key'A model.keys then 1 else 0 + x = xp - xn + z = zp - zn + friction = V3 (1 - model.wprop.friction) 1 (1 - model.wprop.friction) + movement = L.normalize (V3 x 0 z) L.^* (dt * model.camera.strafeStrength) + movement' = L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) movement + jump = + if model.camera.hasJumped then + V3 0 (0 - model.wprop.g * model.camera.airTime) 0 + else + V3 0 0 0 + camVel' = friction * (model.camera.camVel + movement' + jump) + aboveGround = (model.camera.camPos + dt L.*^ camVel') ^. _y > 0 + in + if + (elem GLFW.Key'Space model.keys) + && (model.camera.hasJumped == False) + then + updateAcceleration dt $ model { camera = model.camera { airTime = dt, camVel = model.camera.camVel + (V3 0 model.camera.jumpStrength 0), hasJumped = True } } + else + if aboveGround then + model + { camera = model.camera + { airTime = model.camera.airTime + dt + , camVel = camVel' + , hasJumped = aboveGround + } + } + else + model + { camera = model.camera + { airTime = 0 + , camVel = camVel' * (V3 1 0 1) + , camPos = model.camera.camPos * (V3 1 0 1) + , hasJumped = aboveGround + } + } + +updateVelocity :: Float -> Model -> Model +updateVelocity dt model = + model + { camera = model.camera + { camPos = model.camera.camPos + dt L.*^ model.camera.camVel + } + } + +updateCameraAngle :: Float -> Model -> Model +updateCameraAngle dt model = + let + scaleFactor = model.camera.mouseSensitivity * dt + newPitch = model.camera.camPitch - + scaleFactor * (double2Float $ snd model.cursorDeltaPos) -- mouse sensitivity, update pitch + newPitch' = if newPitch > 1.56 then 1.56 else newPitch + newPitch'' = if newPitch' < (-1.56) then (-1.56) else newPitch' + newYaw = model.camera.camYaw + + scaleFactor * (double2Float $ fst model.cursorDeltaPos) + in + model + { cursorDeltaPos = (0, 0) + , camera = model.camera + { camPitch = newPitch'' + , camYaw = newYaw + } + } + +-- | views the model +view :: GLFW.Window -> Model -> IO () +view window model = do + -- fit viewport to window + (w, h) <- GLFW.getFramebufferSize window + GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) + + -- clear screen + GL.clearColor $= GL.Color4 1 0 1 1 + GL.clear [GL.ColorBuffer, GL.DepthBuffer] + + -- depth + GL.depthFunc $= Just GL.Less + + -- apply transforms + let + pitch = model.camera.camPitch + yaw = model.camera.camYaw + forward = V3 (cos pitch * sin yaw) (sin pitch) (cos pitch * cos yaw) + viewMatrix = + L.lookAt + model.camera.camPos + (model.camera.camPos - forward) + model.wprop.up + projectionMatrix = L.perspective 1.5 (fromIntegral w / fromIntegral h) 0.01 10000 + + viewGLMatrix <- GL.newMatrix GL.RowMajor $ toGLMatrix viewMatrix :: IO (GL.GLmatrix GL.GLfloat) + viewLocation <- GL.get $ GL.uniformLocation model.program "u_view" + GL.uniform viewLocation $= viewGLMatrix + + projectionGLMatrix <- GL.newMatrix GL.RowMajor $ toGLMatrix projectionMatrix :: IO (GL.GLmatrix GL.GLfloat) + projectionLocation <- GL.get $ GL.uniformLocation model.program "u_projection" + GL.uniform projectionLocation $= projectionGLMatrix + + -- draw objects; returns IO [] + _ <- drawObjects model.objects + + -- swap to current buffer + GLFW.swapBuffers window + + -- check for interrupts + GLFW.pollEvents diff --git a/src/Game/Internal.hs b/src/Game/Internal.hs index bb9da57..61832a9 100644 --- a/src/Game/Internal.hs +++ b/src/Game/Internal.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-} {- | - Module : Game.Internal - - Description : 'hidden' functions - - Copyright : Andromeda 2025 - - License : WTFPL + - Description : internal functions + - Copyright : 2025 Andromeda + - License : BSD 3-clause - Maintainer : Matrix @Andromeda:tchncs.de - Stability : Experimental -} @@ -25,10 +25,8 @@ 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.IORef (IORef, modifyIORef', readIORef) import Data.List (delete) import Foreign.Marshal.Array (withArray) import Foreign.Ptr (nullPtr, plusPtr) @@ -39,20 +37,15 @@ 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 - ) +import Linear (V3(..)) -------------------------------------------------------------------------------- -- Shader creation and object initialisation -------------------------------------------------------------------------------- -- | loads models, shaders -initResources :: GLFW.Window -> [V3 GL.GLfloat] -> IO ([Object], GL.Program) -initResources window array = do +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 @@ -151,7 +144,7 @@ createObject array numComponents primitiveMode = do GL.bindVertexArrayObject $= Just vao -- vbo for vertices - createVBO array numComponents $ GL.AttribLocation 0 + _ <- createVBO array numComponents $ GL.AttribLocation 0 return (Object @@ -187,9 +180,9 @@ loop window dt update view modelRef = do -- end frame timer, wait the difference between expected and actual Just frameEnd <- GLFW.getTime let - dt = double2Float $ frameEnd - frameStart + drawTime = double2Float $ frameEnd - frameStart target = 1 / 60 :: Float - when (dt < target) $ threadDelay $ floor $ (target - dt) * 1000000 + when (drawTime < target) $ threadDelay $ floor $ (target - drawTime) * 1000000 Just frameEnd' <- GLFW.getTime let dt' = double2Float $ frameEnd' - frameStart @@ -254,9 +247,9 @@ resizeWindow _ _ _ = return () keyPressed :: Maybe (IORef Model) -> GLFW.KeyCallback keyPressed _ window GLFW.Key'Escape _ GLFW.KeyState'Pressed _ = shutdownWindow window -keyPressed (Just modelRef) window key _ GLFW.KeyState'Pressed _ = +keyPressed (Just modelRef) _ key _ GLFW.KeyState'Pressed _ = modifyIORef' modelRef $ updateKeyPressed key -keyPressed (Just modelRef) window key _ GLFW.KeyState'Released _ = +keyPressed (Just modelRef) _ key _ GLFW.KeyState'Released _ = modifyIORef' modelRef $ updateKeyReleased key keyPressed _ _ _ _ _ _ = return () diff --git a/src/Game/Internal/Types.hs b/src/Game/Internal/Types.hs index 719905e..ad220e4 100644 --- a/src/Game/Internal/Types.hs +++ b/src/Game/Internal/Types.hs @@ -1,9 +1,9 @@ {-# LANGUAGE NamedFieldPuns, OverloadedRecordDot #-} {- | - - Module : Game.Types + - Module : Game.Internal.Types - Description : - - Copyright : Andromeda 2025 - - License : WTFPL + - Copyright : 2025 Andromeda + - License : BSD 3-clause - Maintainer : Matrix @Andromeda:tchncs.de - Stability : Experimental -} @@ -44,18 +44,19 @@ 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(..)) +import Linear (V3, V3(..), V4(..)) -- | represents a single draw call data Object = Object - { vao :: GL.VertexArrayObject - , numIndicies :: GL.NumArrayIndices - , numComponents :: GL.NumComponents - , primitiveMode :: GL.PrimitiveMode + { 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 +-- | converts M44 to a 16array for OpenGL toGLMatrix :: L.M44 GL.GLfloat -> [GL.GLfloat] toGLMatrix (V4 @@ -73,34 +74,49 @@ toGLMatrix data Model = Model { camera :: Camera - , cursorDeltaPos :: (Double, Double) - , cursorPos :: (Double, Double) - , keys :: [GLFW.Key] - , objects :: [Object] - , program :: GL.Program + , 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 -mkModel :: Camera -> [Object] -> GL.Program -> WorldProperties -> Model -mkModel camera objects program wprop = Model camera (0,0) (0,0) [] objects program wprop +-- | smart constructor for Model +mkModel + :: Camera + -> [Object] + -> GL.Program + -> WorldProperties + -> Model +mkModel camera objects program wprop = + Model + camera + (0,0) + (0,0) + [] + objects + program + wprop -- | 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 + { 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 +-- | smart constructor for Camera mkCamera :: V3 Float -> Float @@ -132,14 +148,16 @@ mkCamera False 0 +-- | physical properties of the world data WorldProperties = WorldProperties - { g :: Float -- ^ gravity `g` - , friction :: Float -- ^ floor friction - , up :: V3 Float + { g :: Float -- ^ gravity `g` + , friction :: Float -- ^ scale factor for floor friction + , up :: V3 Float -- ^ global up vector } deriving Show +-- | smart constructor for WorldProperties mkWorldProperties :: Float -> Float -> V3 Float-> WorldProperties mkWorldProperties g friction up = WorldProperties g friction (L.normalize up) diff --git a/src/Game/Main.hs b/src/Game/Main.hs deleted file mode 100644 index 7aeb2a5..0000000 --- a/src/Game/Main.hs +++ /dev/null @@ -1,243 +0,0 @@ -{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-} -{- | - - Module : Game - - Description : runs game - - Copyright : Andromeda 2025 - - License : WTFPL - - Maintainer : Matrix @Andromeda:tchncs.de - - Stability : Experimental - -} -module Game (main) where - -import Game.Internal.LoadShaders -import Game.Internal.Types -import Game.Internal - -import Control.Concurrent (threadDelay) -import Control.Lens ((^.), (+~), (&), (%~)) -import Control.Monad (when) -import Data.Fixed (mod') -import Data.IORef (atomicModifyIORef', IORef, modifyIORef', newIORef, readIORef, writeIORef) -import Data.List (delete) -import Foreign.Marshal.Array (withArray) -import Foreign.Ptr (nullPtr, plusPtr) -import Foreign.Storable (sizeOf, Storable) -import GHC.Float (double2Float, int2Double) - -import qualified Graphics.UI.GLFW as GLFW -import qualified Graphics.Rendering.OpenGL as GL -import Graphics.Rendering.OpenGL as GL (($=)) - -import qualified Linear as L -import Linear ( V3(..) - , _x - , _y - , _z - ) - --- | Main function runs game -main :: IO () -main = do - GLFW.init - GLFW.defaultWindowHints - - -- OpenGL core >=3.3 - GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor 3 - GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 3 - GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core - - -- MSAA - GLFW.windowHint $ GLFW.WindowHint'Samples $ Just 8 - - -- create window - monitor <- GLFW.getPrimaryMonitor - Just window <- GLFW.createWindow 256 256 "hs-game" monitor Nothing - GLFW.makeContextCurrent $ Just window - - -- add callbacks - GLFW.setWindowCloseCallback window $ Just shutdownWindow - GLFW.setWindowSizeCallback window $ Just resizeWindow - GLFW.setKeyCallback window $ Just (keyPressed Nothing) - GLFW.setCursorInputMode window GLFW.CursorInputMode'Hidden - GLFW.setCursorPosCallback window $ Just (cursorPosHandler Nothing) - - (objects, program) <- initResources window testVertices - - -- init model - let - model = - mkModel - (mkCamera - (V3 0 0 3) -- camPos - 0 -- pitch - 0 -- yaw - (V3 0 0 (-1)) -- reference vector - (V3 0 0 0) -- velocity - 2 -- mouse sensitivity - 16 -- strafe strength - 12 -- jump strength - ) - objects - program - (mkWorldProperties - 2 - 0.16 - (V3 0 1 0) - ) - modelRef <- newIORef model - - -- add callbacks with io ref to model - GLFW.setKeyCallback window $ Just $ keyPressed $ Just modelRef - GLFW.setCursorPosCallback window $ Just $ cursorPosHandler $ Just modelRef - - loop window 0 update view modelRef - --------------------------------------------------------------------------------- --- Arrays --------------------------------------------------------------------------------- - --- | centered unit square -testVertices :: [V3 GL.GLfloat] -testVertices = - [ V3 (-0.5) (-0.5) 0 - , V3 0.5 (-0.5) 0 - , V3 (-0.5) 0.5 0 - , V3 0.5 0.5 0 - ] - --------------------------------------------------------------------------------- --- Elm-like data structures --------------------------------------------------------------------------------- - --- | update function -update :: Float -> Model -> Model -update dt model = - updateVelocity - dt - $ updateAcceleration - dt - $ updateCameraAngle - dt - model - -updateAcceleration :: Float -> Model -> Model -updateAcceleration dt model = - let - yaw = (L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) model.camera.camReference) - front = L.normalize $ (V3 1 0 1) * (L.rotate (L.axisAngle (L.cross model.wprop.up yaw) model.camera.camPitch) yaw) - zp = if elem GLFW.Key'S model.keys then 1 else 0 - zn = if elem GLFW.Key'W model.keys then 1 else 0 - xp = if elem GLFW.Key'D model.keys then 1 else 0 - xn = if elem GLFW.Key'A model.keys then 1 else 0 - x = xp - xn - z = zp - zn - friction = V3 (1 - model.wprop.friction) 1 (1 - model.wprop.friction) - movement = L.normalize (V3 x 0 z) L.^* (dt * model.camera.strafeStrength) - movement' = L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) movement - jump = - if model.camera.hasJumped then - V3 0 (0 - model.wprop.g * model.camera.airTime) 0 - else - V3 0 0 0 - camVel' = friction * (model.camera.camVel + movement' + jump) - aboveGround = (model.camera.camPos + dt L.*^ camVel') ^. _y > 0 - in - if - (elem GLFW.Key'Space model.keys) - && (model.camera.hasJumped == False) - then - updateAcceleration dt $ model { camera = model.camera { airTime = dt, camVel = model.camera.camVel + (V3 0 model.camera.jumpStrength 0), hasJumped = True } } - else - if aboveGround then - model - { camera = model.camera - { airTime = model.camera.airTime + dt - , camVel = camVel' - , hasJumped = aboveGround - } - } - else - model - { camera = model.camera - { airTime = 0 - , camVel = camVel' * (V3 1 0 1) - , camPos = model.camera.camPos * (V3 1 0 1) - , hasJumped = aboveGround - } - } - -updateVelocity :: Float -> Model -> Model -updateVelocity dt model = - model - { camera = model.camera - { camPos = model.camera.camPos + dt L.*^ model.camera.camVel - } - } - -updateCameraAngle :: Float -> Model -> Model -updateCameraAngle dt model = - let - scaleFactor = model.camera.mouseSensitivity * dt - newPitch = model.camera.camPitch - - scaleFactor * (double2Float $ snd model.cursorDeltaPos) -- mouse sensitivity, update pitch - newPitch' = if newPitch > 1.56 then 1.56 else newPitch - newPitch'' = if newPitch' < (-1.56) then (-1.56) else newPitch' - newYaw = model.camera.camYaw + - scaleFactor * (double2Float $ fst model.cursorDeltaPos) - in - model - { cursorDeltaPos = (0, 0) - , camera = model.camera - { camPitch = newPitch'' - , camYaw = newYaw - } - } - --- | updates given a keypress. escape case is probably caught by GLFW in the --- handler function itself -updateKeyPressed :: GLFW.Key -> Model -> Model -updateKeyPressed key model = - model { keys = key:model.keys } - --- | views the model -view :: GLFW.Window -> Model -> IO () -view window model = do - -- fit viewport to window - (w, h) <- GLFW.getFramebufferSize window - GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) - - -- clear screen - GL.clearColor $= GL.Color4 1 0 1 1 - GL.clear [GL.ColorBuffer, GL.DepthBuffer] - - -- depth - GL.depthFunc $= Just GL.Less - - -- apply transforms - let - pitch = model.camera.camPitch - yaw = model.camera.camYaw - forward = V3 (cos pitch * sin yaw) (sin pitch) (cos pitch * cos yaw) - viewMatrix = - L.lookAt - model.camera.camPos - (model.camera.camPos - forward) - model.wprop.up - projectionMatrix = L.perspective 1.5 (fromIntegral w / fromIntegral h) 0.01 10000 - - viewGLMatrix <- GL.newMatrix GL.RowMajor $ toGLMatrix viewMatrix :: IO (GL.GLmatrix GL.GLfloat) - viewLocation <- GL.get $ GL.uniformLocation model.program "u_view" - GL.uniform viewLocation $= viewGLMatrix - - projectionGLMatrix <- GL.newMatrix GL.RowMajor $ toGLMatrix projectionMatrix :: IO (GL.GLmatrix GL.GLfloat) - projectionLocation <- GL.get $ GL.uniformLocation model.program "u_projection" - GL.uniform projectionLocation $= projectionGLMatrix - - -- draw objects - drawObjects model.objects - - -- swap to current buffer - GLFW.swapBuffers window - - -- check for interrupts - GLFW.pollEvents -- cgit v1.3.1