Andromeda/hs-game
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Compare commits

base: Andromeda:master
Branches Tags
Andromeda:master Andromeda:development
Andromeda:v0.5.0 Andromeda:v0.4.0 Andromeda:v0.3.0 Andromeda:v0.2.1 Andromeda:v0.2.0 Andromeda:v0.1.0
..
compare: Andromeda:8cabc29195b5c7644a21916cb1e1962d4cf8e12d
Branches Tags
Andromeda:development Andromeda:master
Andromeda:v0.5.0 Andromeda:v0.4.0 Andromeda:v0.3.0 Andromeda:v0.2.1 Andromeda:v0.2.0 Andromeda:v0.1.0

2 Commits
master ... 8cabc29195

Author SHA1 Message Date
mtgmonkey
8cabc29195 draw multiple sets of points, debug features 2025-12-21 12:20:08 +01:00
mtgmonkey
a13a8610dc use hindent 2025-12-13 19:39:43 +01:00
6 changed files with 281 additions and 375 deletions
Expand all files Collapse all files

4
flake.nix
View File

@@ -16,10 +16,6 @@
devShells.${system} = { devShells.${system} = {
default = pkgs.mkShell { default = pkgs.mkShell {
packages = [ packages = [
# dev stuff
pkgs.haskellPackages.ghcide
pkgs.haskellPackages.ormolu
pkgs.cabal-install pkgs.cabal-install
pkgs.libGL pkgs.libGL
pkgs.xorg.libX11 pkgs.xorg.libX11

2
hs-game.cabal
View File

@@ -1,6 +1,6 @@
cabal-version: 3.0 cabal-version: 3.0
name: hs-game name: hs-game
version: 0.5.0 version: 0.4.0
-- synopsis: -- synopsis:
-- description: -- description:
homepage: https://git.mtgmonkey.net/Andromeda/hs-game homepage: https://git.mtgmonkey.net/Andromeda/hs-game

153
src/Game/Internal.hs
View File

@@ -1,27 +1,28 @@
{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
-- | {- |
-- - Module : Game.Internal - Module : Game.Internal
-- - Description : internal functions - Description : internal functions
-- - Copyright : 2025 Andromeda - Copyright : 2025 Andromeda
-- - License : BSD 3-clause - License : BSD 3-clause
-- - Maintainer : Matrix @Andromeda:tchncs.de - Maintainer : Matrix @Andromeda:tchncs.de
-- - Stability : Experimental - Stability : Experimental
-}
module Game.Internal module Game.Internal
( cursorPosHandler, ( cursorPosHandler
drawObjects, , drawObjects
initResources, , initResources
keyPressed, , keyPressed
loop, , loop
resizeWindow, , resizeWindow
shutdownWindow, , shutdownWindow
updateCursorPos, , updateCursorPos
updateKeyPressed, , updateKeyPressed
updateKeyReleased, , updateKeyReleased
) ) where
where
import Game.Internal.LoadShaders
import Game.Internal.Types
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Monad (when) import Control.Monad (when)
@@ -31,56 +32,53 @@ import Foreign.Marshal.Array (withArray)
import Foreign.Ptr (nullPtr, plusPtr) import Foreign.Ptr (nullPtr, plusPtr)
import Foreign.Storable (Storable, sizeOf) import Foreign.Storable (Storable, sizeOf)
import GHC.Float (double2Float) import GHC.Float (double2Float)
import Game.Internal.LoadShaders
import Game.Internal.Types
import Graphics.Rendering.OpenGL (($=))
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL (($=))
import qualified Graphics.UI.GLFW as GLFW import qualified Graphics.UI.GLFW as GLFW
import Linear (V3 (..), V4 (..))
import Linear (V3(..))
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Shader creation and object initialisation -- Shader creation and object initialisation
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | loads models, shaders
initResources :: [[V4 GL.GLfloat]] -> IO ([Object], GL.Program) initResources :: [[V3 GL.GLfloat]] -> IO ([Object], GL.Program)
initResources arrays = do initResources arrays = do
objects <- -- create objects
listIOsToIOlist objects <- listIOsToIOlist [ createObject arr 3 GL.TriangleStrip | arr <- arrays ] []
[createObject arr 4 GL.TriangleStrip (GL.AttribLocation 0) | arr <- arrays] -- load shaders
[]
program <- program <-
loadShaders loadShaders
[ ShaderInfo GL.VertexShader (StringSource vertShader), [ ShaderInfo GL.VertexShader (StringSource vertShader)
ShaderInfo GL.FragmentShader (StringSource fragShader) , ShaderInfo GL.FragmentShader (StringSource fragShader)
] ]
GL.currentProgram $= Just program GL.currentProgram $= Just program
return (objects, program) return (objects, program)
listIOsToIOlist :: [IO a] -> [a] -> IO [a] listIOsToIOlist :: [IO a] -> [a] -> IO [a]
listIOsToIOlist [] out = return out listIOsToIOlist [] out = return out
listIOsToIOlist (io : ios) out = do listIOsToIOlist (io:ios) out = do
ioVal <- io ioVal <- io
listIOsToIOlist ios (ioVal : out) listIOsToIOlist ios (ioVal:out)
-- a_ vertex shader input -- a_ vertex shader input
-- v_ varying -- v_ varying
-- u_ uniform -- u_ uniform
-- o_ fragment shader output -- o_ fragment shader output
-- | vertex shader -- | vertex shader
vertShader :: String vertShader :: String
vertShader = vertShader =
"#version 330 core\n" "#version 330 core\n"
++ "layout (location = 0) in vec4 a_vPos;\n" ++ "layout (location = 0) in vec3 a_vPos;\n"
++ "uniform mat4 u_view;\n" ++ "uniform mat4 u_view;\n"
++ "uniform mat4 u_projection;\n" ++ "uniform mat4 u_projection;\n"
++ "out vec3 v_pos;\n" ++ "out vec3 v_pos;\n"
++ glslProjectTo3d
++ "void main()\n" ++ "void main()\n"
++ "{\n" ++ "{\n"
++ " gl_Position = u_projection * u_view * vec4(projectTo3d(a_vPos), 1.0);\n" ++ " gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n"
++ " v_pos = a_vPos.xyz;\n" ++ " v_pos = a_vPos;\n"
++ "}\n" ++ "}"
-- | fragment shader -- | fragment shader
fragShader :: String fragShader :: String
@@ -91,32 +89,23 @@ fragShader =
++ "void main()\n" ++ "void main()\n"
++ "{\n" ++ "{\n"
++ " o_vColor = vec4(0.5 + 0.5 * normalize(v_pos), 1);\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 -- Objects
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | calculates the size in memory of an array -- | calculates the size in memory of an array
sizeOfArray :: (Storable a, Num b) => [a] -> b sizeOfArray :: (Storable a, Num b) => [a] -> b
sizeOfArray [] = 0 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 -- | loads a given array into a given attribute index
createVBO :: createVBO ::
(Storable (a GL.GLfloat)) => Storable (a GL.GLfloat)
[a GL.GLfloat] -> => [a GL.GLfloat]
GL.NumComponents -> -> GL.NumComponents
GL.AttribLocation -> -> GL.AttribLocation
IO GL.BufferObject -> IO GL.BufferObject
createVBO array numComponents attribLocation = do createVBO array numComponents attribLocation = do
-- vbo for buffer -- vbo for buffer
buffer <- GL.genObjectName buffer <- GL.genObjectName
@@ -126,45 +115,37 @@ createVBO array numComponents attribLocation = do
GL.bufferData GL.ArrayBuffer $= (sizeOfArray array, ptr, GL.StaticDraw) GL.bufferData GL.ArrayBuffer $= (sizeOfArray array, ptr, GL.StaticDraw)
-- create attribute pointer to buffer -- create attribute pointer to buffer
GL.vertexAttribPointer attribLocation GL.vertexAttribPointer attribLocation
$= ( GL.ToFloat, $= ( GL.ToFloat
GL.VertexArrayDescriptor numComponents GL.Float 0 (plusPtr nullPtr 0) , GL.VertexArrayDescriptor numComponents GL.Float 0 (plusPtr nullPtr 0))
)
GL.vertexAttribArray attribLocation $= GL.Enabled GL.vertexAttribArray attribLocation $= GL.Enabled
return buffer return buffer
-- | creates an object from a given array; deals with vbos and everything -- | creates an object from a given array; deals with vbos and everything
createObject :: createObject ::
(Storable (a GL.GLfloat)) => Storable (a GL.GLfloat)
[a GL.GLfloat] -> => [a GL.GLfloat]
GL.NumComponents -> -> GL.NumComponents
GL.PrimitiveMode -> -> GL.PrimitiveMode
GL.AttribLocation -> -> IO Object
IO Object createObject array numComponents primitiveMode = do
createObject array numComponents primitiveMode attrLocation = do
-- vao for object -- vao for object
vao <- GL.genObjectName vao <- GL.genObjectName
GL.bindVertexArrayObject $= Just vao GL.bindVertexArrayObject $= Just vao
-- vbo for vertices -- vbo for vertices
_ <- createVBO array numComponents attrLocation _ <- createVBO array numComponents $ GL.AttribLocation 0
return (Object vao (fromIntegral $ length array) numComponents primitiveMode) return (Object vao (fromIntegral $ length array) numComponents primitiveMode)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Elm-like data structures -- Elm-like data structures
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | gameloop -- | gameloop
loop :: loop ::
-- | window to display on GLFW.Window -- ^ window to display on
GLFW.Window -> -> Float -- ^ dt
-- | dt -> (Float -> Model -> Model) -- ^ update function
Float -> -> (GLFW.Window -> Model -> IO ()) -- ^ view function
-- | update function -> IORef Model -- ^ model
(Float -> Model -> Model) -> -> IO ()
-- | view function
(GLFW.Window -> Model -> IO ()) ->
-- | model
IORef Model ->
IO ()
loop window dt update view modelRef = do loop window dt update view modelRef = do
-- start frame timer -- start frame timer
Just frameStart <- GLFW.getTime Just frameStart <- GLFW.getTime
@@ -202,17 +183,16 @@ updateCursorPos x y model =
(((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos) - y) ** 2) (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos) - y) ** 2)
** 0.5 ** 0.5
in if pyth < 16 in if pyth < 16
then then model
model { cursorPos = (x, y)
{ cursorPos = (x, y), , cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y)
cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y)
} }
else model {cursorPos = (x, y)} else model {cursorPos = (x, y)}
-- | draws objects -- | draws objects
drawObjects :: [Object] -> IO ([Object]) drawObjects :: [Object] -> IO ([Object])
drawObjects [] = return [] drawObjects [] = return []
drawObjects ((Object vao numVertices _ primitiveMode) : objects) = do drawObjects ((Object vao numVertices _ primitiveMode):objects) = do
GL.bindVertexArrayObject $= Just vao GL.bindVertexArrayObject $= Just vao
GL.drawArrays primitiveMode 0 numVertices GL.drawArrays primitiveMode 0 numVertices
drawObjects objects drawObjects objects
@@ -220,7 +200,6 @@ drawObjects ((Object vao numVertices _ primitiveMode) : objects) = do
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- interrupts -- interrupts
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | shuts down GLFW -- | shuts down GLFW
shutdownWindow :: GLFW.WindowCloseCallback shutdownWindow :: GLFW.WindowCloseCallback
shutdownWindow window = do shutdownWindow window = do

47
src/Game/Internal/LoadShaders.hs
View File

@@ -1,7 +1,4 @@
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- | -- |
-- Module : LoadShaders -- Module : LoadShaders
-- Copyright : (c) Sven Panne 2013 -- Copyright : (c) Sven Panne 2013
@@ -13,12 +10,13 @@
-- --
-- Utilities for shader handling, adapted from LoadShaders.cpp which is (c) The -- Utilities for shader handling, adapted from LoadShaders.cpp which is (c) The
-- Red Book Authors. -- Red Book Authors.
--
--------------------------------------------------------------------------------
module Game.Internal.LoadShaders module Game.Internal.LoadShaders
( ShaderSource (..), ( ShaderSource(..)
ShaderInfo (..), , ShaderInfo(..)
loadShaders, , loadShaders
) ) where
where
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
@@ -26,15 +24,14 @@ import qualified Data.ByteString as B
import Graphics.Rendering.OpenGL import Graphics.Rendering.OpenGL
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | The source of the shader source code. -- | The source of the shader source code.
data ShaderSource data ShaderSource
= -- | The shader source code is directly given as a 'B.ByteString'. = ByteStringSource B.ByteString
ByteStringSource B.ByteString -- ^ The shader source code is directly given as a 'B.ByteString'.
| -- | The shader source code is directly given as a 'String'. | StringSource String
StringSource String -- ^ The shader source code is directly given as a 'String'.
| -- | The shader source code is located in the file at the given 'FilePath'. | FileSource FilePath
FileSource FilePath -- ^ The shader source code is located in the file at the given 'FilePath'.
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
getSource :: ShaderSource -> IO B.ByteString getSource :: ShaderSource -> IO B.ByteString
@@ -43,14 +40,12 @@ getSource (StringSource str) = return $ packUtf8 str
getSource (FileSource path) = B.readFile path getSource (FileSource path) = B.readFile path
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | A description of a shader: The type of the shader plus its source code. -- | A description of a shader: The type of the shader plus its source code.
data ShaderInfo data ShaderInfo =
= ShaderInfo ShaderType ShaderSource ShaderInfo ShaderType ShaderSource
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Create a new program object from the given shaders, throwing an -- | Create a new program object from the given shaders, throwing an
-- 'IOException' if something goes wrong. -- 'IOException' if something goes wrong.
loadShaders :: [ShaderInfo] -> IO Program loadShaders :: [ShaderInfo] -> IO Program
@@ -65,7 +60,7 @@ linkAndCheck = checked linkProgram linkStatus programInfoLog "link"
loadCompileAttach :: Program -> [ShaderInfo] -> IO () loadCompileAttach :: Program -> [ShaderInfo] -> IO ()
loadCompileAttach _ [] = return () loadCompileAttach _ [] = return ()
loadCompileAttach program (ShaderInfo shType source : infos) = loadCompileAttach program (ShaderInfo shType source:infos) =
createShader shType `bracketOnError` deleteObjectName $ \shader -> do createShader shType `bracketOnError` deleteObjectName $ \shader -> do
src <- getSource source src <- getSource source
shaderSourceBS shader $= src shaderSourceBS shader $= src
@@ -77,12 +72,12 @@ compileAndCheck :: Shader -> IO ()
compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile" compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile"
checked :: checked ::
(t -> IO ()) -> (t -> IO ())
(t -> GettableStateVar Bool) -> -> (t -> GettableStateVar Bool)
(t -> GettableStateVar String) -> -> (t -> GettableStateVar String)
String -> -> String
t -> -> t
IO () -> IO ()
checked action getStatus getInfoLog message object = do checked action getStatus getInfoLog message object = do
action object action object
ok <- get (getStatus object) ok <- get (getStatus object)

172
src/Game/Internal/Types.hs
View File

@@ -1,80 +1,69 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns, OverloadedRecordDot #-}
{-# LANGUAGE OverloadedRecordDot #-}
-- | {- |
-- - Module : Game.Internal.Types - Module : Game.Internal.Types
-- - Description : - Description :
-- - Copyright : 2025 Andromeda - Copyright : 2025 Andromeda
-- - License : BSD 3-clause - License : BSD 3-clause
-- - Maintainer : Matrix @Andromeda:tchncs.de - Maintainer : Matrix @Andromeda:tchncs.de
-- - Stability : Experimental - Stability : Experimental
-}
module Game.Internal.Types module Game.Internal.Types
( Object (..), ( Object(..)
toGLMatrix, , toGLMatrix
Model (camera, objects, cursorDeltaPos, cursorPos, program, keys, wprop), , Model(camera, objects, cursorDeltaPos, cursorPos, program, keys, wprop)
mkModel, , mkModel
Camera (camPos, camPitch, camYaw, camReference, mouseSensitivity, camVel, strafeStrength, jumpStrength, hasJumped, airTime), , Camera(camPos, camPitch, camYaw, camReference, mouseSensitivity, camVel, strafeStrength, jumpStrength, hasJumped, airTime)
mkCamera, , mkCamera
WorldProperties (g, friction, up), , WorldProperties(g, friction, up)
mkWorldProperties, , mkWorldProperties
) ) where
where
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLFW as GLFW import qualified Graphics.UI.GLFW as GLFW
import Linear (V3 (..), V4 (..))
import qualified Linear as L import qualified Linear as L
import Linear (V3, V3(..), V4(..))
-- | represents a single draw call -- | represents a single draw call
data Object = Object data Object = Object
{ -- | vao of vertex buffer { vao :: GL.VertexArrayObject -- ^ vao of vertex buffer
vao :: GL.VertexArrayObject, , numIndicies :: GL.NumArrayIndices -- ^ number of vertices
-- | number of vertices , numComponents :: GL.NumComponents -- ^ dimensionallity; vec3, vec4, etc.
numIndicies :: GL.NumArrayIndices, , primitiveMode :: GL.PrimitiveMode -- ^ primitive mode to be drawn with
-- | dimensionallity; vec3, vec4, etc. } deriving (Show)
numComponents :: GL.NumComponents,
-- | primitive mode to be drawn with
primitiveMode :: GL.PrimitiveMode
}
deriving (Show)
-- | converts M44 to a 16array for OpenGL -- | converts M44 to a 16array for OpenGL
toGLMatrix :: L.M44 GL.GLfloat -> [GL.GLfloat] 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)) = toGLMatrix (V4 (V4 c00 c01 c02 c03) (V4 c10 c11 c12 c13) (V4 c20 c21 c22 c23) (V4 c30 c31 c32 c33)) =
[ c00, [ c00
c01, , c01
c02, , c02
c03, , c03
c10, , c10
c11, , c11
c12, , c12
c13, , c13
c20, , c20
c21, , c21
c22, , c22
c23, , c23
c30, , c30
c31, , c31
c32, , c32
c33 , c33
] ]
-- | gamestate -- | gamestate
data Model = Model data Model = Model
{ camera :: Camera, { camera :: Camera
-- | frame-on-frame delta mouse position , cursorDeltaPos :: (Double, Double) -- ^ frame-on-frame delta mouse position
cursorDeltaPos :: (Double, Double), , cursorPos :: (Double, Double) -- ^ current mouse position
-- | current mouse position , keys :: [GLFW.Key] -- ^ currently pressed keys
cursorPos :: (Double, Double), , objects :: [Object] -- ^ draw calls
-- | currently pressed keys , program :: GL.Program -- ^ shader program
keys :: [GLFW.Key], , wprop :: WorldProperties
-- | draw calls } deriving (Show)
objects :: [Object],
-- | shader program
program :: GL.Program,
wprop :: WorldProperties
}
deriving (Show)
-- | smart constructor for Model -- | smart constructor for Model
mkModel :: Camera -> [Object] -> GL.Program -> WorldProperties -> Model mkModel :: Camera -> [Object] -> GL.Program -> WorldProperties -> Model
@@ -83,40 +72,29 @@ mkModel camera objects program wprop =
-- | camera -- | camera
data Camera = Camera data Camera = Camera
{ -- | position in world space { camPos :: V3 Float -- ^ position in world space
camPos :: V3 Float, , camPitch :: Float -- ^ pitch in radians, up positive
-- | pitch in radians, up positive , camYaw :: Float -- ^ yaw in radians, right positive
camPitch :: Float, , camReference :: V3 Float -- ^ reference direction; orientation applied to
-- | yaw in radians, right positive , camVel :: V3 Float -- ^ velocity in world space
camYaw :: Float, , mouseSensitivity :: Float -- ^ scale factor for mouse movement
-- | reference direction; orientation applied to , strafeStrength :: Float -- ^ scale factor for strafe
camReference :: V3 Float, , jumpStrength :: Float -- ^ scale factor for jump initial velocity
-- | velocity in world space , hasJumped :: Bool -- ^ whether the camera still has jumping state
camVel :: V3 Float, , airTime :: Float -- ^ time since jumping state entered in seconds
-- | scale factor for mouse movement } deriving (Show)
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 -- | smart constructor for Camera
mkCamera :: mkCamera ::
V3 Float -> V3 Float
Float -> -> Float
Float -> -> Float
V3 Float -> -> V3 Float
V3 Float -> -> V3 Float
Float -> -> Float
Float -> -> Float
Float -> -> Float
Camera -> Camera
mkCamera camPos camPitch camYaw camReference camVel mouseSensitivity strafeStrength jumpStrength = mkCamera camPos camPitch camYaw camReference camVel mouseSensitivity strafeStrength jumpStrength =
Camera Camera
camPos camPos
@@ -132,14 +110,10 @@ mkCamera camPos camPitch camYaw camReference camVel mouseSensitivity strafeStren
-- | physical properties of the world -- | physical properties of the world
data WorldProperties = WorldProperties data WorldProperties = WorldProperties
{ -- | gravity `g` { g :: Float -- ^ gravity `g`
g :: Float, , friction :: Float -- ^ scale factor for floor friction
-- | scale factor for floor friction , up :: V3 Float -- ^ global up vector
friction :: Float, } deriving (Show)
-- | global up vector
up :: V3 Float
}
deriving (Show)
-- | smart constructor for WorldProperties -- | smart constructor for WorldProperties
mkWorldProperties :: Float -> Float -> V3 Float -> WorldProperties mkWorldProperties :: Float -> Float -> V3 Float -> WorldProperties

210
src/Main.hs
View File

@@ -1,29 +1,30 @@
{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
-- | {- |
-- - Module : Game - Module : Game
-- - Description : runs game - Description : runs game
-- - Copyright : 2025 Andromeda - Copyright : 2025 Andromeda
-- - License : BSD 3-clause - License : BSD 3-clause
-- - Maintainer : Matrix @Andromeda:tchncs.de - Maintainer : Matrix @Andromeda:tchncs.de
-- - Stability : Experimental - Stability : Experimental
-}
module Main module Main
( main, ( main
) ) where
where
import Game.Internal
import Game.Internal.Types
import Control.Lens ((^.)) import Control.Lens ((^.))
import Data.IORef (newIORef) import Data.IORef (newIORef)
import GHC.Float (double2Float) import GHC.Float (double2Float)
import Game.Internal
import Game.Internal.Types
import Graphics.Rendering.OpenGL (($=))
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL (($=))
import qualified Graphics.UI.GLFW as GLFW import qualified Graphics.UI.GLFW as GLFW
import Linear (V3 (..), V4 (..), _y)
import qualified Linear as L import qualified Linear as L
import Linear (V3(..), _y)
-- | Main function runs game -- | Main function runs game
main :: IO () main :: IO ()
@@ -46,14 +47,12 @@ main = do
GLFW.setKeyCallback window $ Just (keyPressed Nothing) GLFW.setKeyCallback window $ Just (keyPressed Nothing)
GLFW.setCursorInputMode window GLFW.CursorInputMode'Hidden GLFW.setCursorInputMode window GLFW.CursorInputMode'Hidden
GLFW.setCursorPosCallback window $ Just (cursorPosHandler Nothing) GLFW.setCursorPosCallback window $ Just (cursorPosHandler Nothing)
(objects, program) <- (objects, program) <- initResources
initResources $ [ map (+ V3 a 0 0) cube | a <- take 100 [0,2..]]
-- [map (v3tov4 0) $ map (+ V3 a 0 0) cube | a <- take 100 [0, 2 ..]] -- init model
[hCube]
let model = let model =
mkModel mkModel
( mkCamera (mkCamera
(V3 0 0 3) -- camPos (V3 0 0 3) -- camPos
0 -- pitch 0 -- pitch
0 -- yaw 0 -- yaw
@@ -77,111 +76,81 @@ main = do
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
top :: [V3 GL.GLfloat] top :: [V3 GL.GLfloat]
top = top =
[ V3 p 0 p, [ V3 p 0 p
V3 p 0 m, , V3 p 0 m
V3 m 0 p, , V3 m 0 p
V3 m 0 m , V3 m 0 m
] ]
side :: [V3 GL.GLfloat] side :: [V3 GL.GLfloat]
side = side =
[ V3 0 p p, [ V3 0 p p
V3 0 p m, , V3 0 p m
V3 0 m p, , V3 0 m p
V3 0 m m , V3 0 m m
] ]
front :: [V3 GL.GLfloat] front :: [V3 GL.GLfloat]
front = front =
[ V3 p p 0, [ V3 p p 0
V3 p m 0, , V3 p m 0
V3 m p 0, , V3 m p 0
V3 m m 0 , V3 m m 0
] ]
m = (0 - p) m = (0 - p)
p = 0.5 p = 0.5
v3tov4 :: GL.GLfloat -> V3 GL.GLfloat -> V4 GL.GLfloat -- TODO optimise cube
v3tov4 w (V3 x y z) = V4 x y z w -- | cube vertices
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 GL.GLfloat]
cube = cube =
[ V3 p p p, -- front [ V3 p p p -- front
V3 p m p, , V3 p m p
V3 m p p, , V3 m p p
V3 m m p, -- down , V3 m m p -- down
V3 m m m, , V3 m m m
V3 p m p, , V3 p m p
V3 p m m, -- right , V3 p m m -- right
V3 p p m, , V3 p p m
V3 p m p, , V3 p m p
V3 p p p, -- up , V3 p p p -- up
V3 m p p, , V3 m p p
V3 p p m, , V3 p p m
V3 m p m, -- back , V3 m p m -- back
V3 p m m, , V3 p m m
V3 p p m, , V3 p p m
V3 m m m, -- left , V3 m m m -- left
V3 m p m, , V3 m p m
V3 m m p, , V3 m m p
V3 m p 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 -- Elm-like data structures
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | update function -- | update function
update :: Float -> Model -> Model update :: Float -> Model -> Model
update dt model = update dt model =
updateVelocity dt $ updateVelocity dt
updateAcceleration dt $ $ updateAcceleration dt
updateSpeed dt $ $ updateSpeed dt
updateCameraAngle dt model $ updateCameraAngle dt model
updateSpeed :: Float -> Model -> Model updateSpeed :: Float -> Model -> Model
updateSpeed dt model = updateSpeed dt model =
if elem GLFW.Key'T model.keys if elem GLFW.Key'T model.keys then
then
model model
{ camera = { camera =
model.camera model.camera
{ jumpStrength = model.camera.jumpStrength * 1.1, { jumpStrength = model.camera.jumpStrength * 1.1
strafeStrength = model.camera.strafeStrength * 1.1 , strafeStrength = model.camera.strafeStrength * 1.1
} }
} }
else else if elem GLFW.Key'G model.keys then
if elem GLFW.Key'G model.keys
then
model model
{ camera = { camera =
model.camera model.camera
{ jumpStrength = model.camera.jumpStrength * 0.99, { jumpStrength = model.camera.jumpStrength * 0.99
strafeStrength = model.camera.strafeStrength * 0.99 , strafeStrength = model.camera.strafeStrength * 0.99
} }
} }
else model else model
@@ -217,37 +186,33 @@ updateAcceleration dt model =
camVel' = friction * (model.camera.camVel + movement' + jump) camVel' = friction * (model.camera.camVel + movement' + jump)
aboveGround = (model.camera.camPos + dt L.*^ camVel') ^. _y > 0 aboveGround = (model.camera.camPos + dt L.*^ camVel') ^. _y > 0
in if (elem GLFW.Key'Space model.keys) && (model.camera.hasJumped == False) in if (elem GLFW.Key'Space model.keys) && (model.camera.hasJumped == False)
then then updateAcceleration dt
updateAcceleration dt $ $ model
model
{ camera = { camera =
model.camera model.camera
{ airTime = dt, { airTime = dt
camVel = , camVel =
model.camera.camVel model.camera.camVel
+ (V3 0 model.camera.jumpStrength 0), + (V3 0 model.camera.jumpStrength 0)
hasJumped = True , hasJumped = True
} }
} }
else else if aboveGround
if aboveGround then model
then
model
{ camera = { camera =
model.camera model.camera
{ airTime = model.camera.airTime + dt, { airTime = model.camera.airTime + dt
camVel = camVel', , camVel = camVel'
hasJumped = aboveGround , hasJumped = aboveGround
} }
} }
else else model
model
{ camera = { camera =
model.camera model.camera
{ airTime = 0, { airTime = 0
camVel = camVel' * (V3 1 0 1), , camVel = camVel' * (V3 1 0 1)
camPos = model.camera.camPos * (V3 1 0 1), , camPos = model.camera.camPos * (V3 1 0 1)
hasJumped = aboveGround , hasJumped = aboveGround
} }
} }
@@ -256,8 +221,7 @@ updateVelocity dt model =
model model
{ camera = { camera =
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 updateCameraAngle :: Float -> Model -> Model
@@ -278,8 +242,8 @@ updateCameraAngle dt model =
model.camera.camYaw model.camera.camYaw
+ scaleFactor * (double2Float $ fst model.cursorDeltaPos) + scaleFactor * (double2Float $ fst model.cursorDeltaPos)
in model in model
{ cursorDeltaPos = (0, 0), { cursorDeltaPos = (0, 0)
camera = model.camera {camPitch = newPitch'', camYaw = newYaw} , camera = model.camera {camPitch = newPitch'', camYaw = newYaw}
} }
-- | views the model -- | views the model
@@ -305,14 +269,12 @@ view window model = do
projectionMatrix = projectionMatrix =
L.perspective 1.2 (fromIntegral w / fromIntegral h) 0.01 1000 L.perspective 1.2 (fromIntegral w / fromIntegral h) 0.01 1000
viewGLMatrix <- viewGLMatrix <-
GL.newMatrix GL.RowMajor $ toGLMatrix viewMatrix :: GL.newMatrix GL.RowMajor $ toGLMatrix viewMatrix :: IO
IO
(GL.GLmatrix GL.GLfloat) (GL.GLmatrix GL.GLfloat)
viewLocation <- GL.get $ GL.uniformLocation model.program "u_view" viewLocation <- GL.get $ GL.uniformLocation model.program "u_view"
GL.uniform viewLocation $= viewGLMatrix GL.uniform viewLocation $= viewGLMatrix
projectionGLMatrix <- projectionGLMatrix <-
GL.newMatrix GL.RowMajor $ toGLMatrix projectionMatrix :: GL.newMatrix GL.RowMajor $ toGLMatrix projectionMatrix :: IO
IO
(GL.GLmatrix GL.GLfloat) (GL.GLmatrix GL.GLfloat)
projectionLocation <- GL.get $ GL.uniformLocation model.program "u_projection" projectionLocation <- GL.get $ GL.uniformLocation model.program "u_projection"
GL.uniform projectionLocation $= projectionGLMatrix GL.uniform projectionLocation $= projectionGLMatrix