summaryrefslogtreecommitdiff
path: root/src/Game
diff options
context:
space:
mode:
Diffstat (limited to 'src/Game')
-rw-r--r--src/Game/Internal.hs155
-rw-r--r--src/Game/Internal/LoadShaders.hs47
-rw-r--r--src/Game/Internal/Types.hs172
3 files changed, 213 insertions, 161 deletions
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
generated by cgit v1.3.1 (git 2.54.0) at 2026-09-04 06:07:22 +0000