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

Compare commits

base: Andromeda:development
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
developmen ... 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 314 additions and 518 deletions
Expand all files Collapse all files

8
flake.nix
View File

@@ -11,17 +11,11 @@
pkgs = nixpkgs.legacyPackages.${system}; pkgs = nixpkgs.legacyPackages.${system};
in { in {
packages.${system} = { packages.${system} = {
default = default = pkgs.haskellPackages.callCabal2nix "hs-game" ./. {};
pkgs.haskell.packages.ghc912.callCabal2nix "hs-game" ./. {
};
}; };
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

227
src/Game/Internal.hs
View File

@@ -1,28 +1,28 @@
{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
{-# LANGUAGE MultilineStrings #-}
{-# 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)
@@ -32,35 +32,29 @@ 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 arr = do initResources arrays = do
object <- -- create objects
createObject arr 4 GL.Triangles (GL.AttribLocation 0) objects <- listIOsToIOlist [ createObject arr 3 GL.TriangleStrip | arr <- arrays ] []
-- load shaders
-- compile shader program
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)
-- alpha
GL.blend $= GL.Enabled
GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
return (object, program)
listIOsToIOlist :: [IO a] -> [a] -> IO [a] listIOsToIOlist :: [IO a] -> [a] -> IO [a]
listIOsToIOlist [] out = return out listIOsToIOlist [] out = return out
@@ -72,89 +66,34 @@ listIOsToIOlist (io : ios) out = do
-- v_ varying -- v_ varying
-- u_ uniform -- u_ uniform
-- o_ fragment shader output -- o_ fragment shader output
-- | vertex shader
vertShader :: String vertShader :: String
vertShader = vertShader =
""" "#version 330 core\n"
#version 330 core ++ "layout (location = 0) in vec3 a_vPos;\n"
++ "uniform mat4 u_view;\n"
layout (location = 0) in vec4 a_vPos; ++ "uniform mat4 u_projection;\n"
++ "out vec3 v_pos;\n"
uniform mat4 u_view; ++ "void main()\n"
uniform mat4 u_projection; ++ "{\n"
uniform vec4 u_cam; ++ " gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n"
++ " v_pos = a_vPos;\n"
out vec3 v_pos; ++ "}"
out float v_w;
out float v_alpha;
vec3 orthoFrom4d(vec4 point)
{
return point.xyz;
}
// creates a simple 3d coordinate from a 4d
vec3 projectFrom4d(vec4 point)
{
// TODO don't do camera ops in shader, prefer linear algebra
// also use a reasonable projection for god's sake
vec4 view = abs(u_cam - point);
float perspective = 1.0 / abs(u_cam.w - view.w);
return perspective * (point.xyz);
}
void main()
{
vec3 vPos = orthoFrom4d(a_vPos);
// TODO don't set constant inside of shader :/
float wHorizon = 3;
float alpha = (wHorizon - abs(u_cam.w - a_vPos.w)) / wHorizon;
// cull invisible things
if (alpha < -1) {
gl_Position = vec4(0.0);
alpha = 0.0;
} else {
alpha = max(alpha, 0.0);
gl_Position = u_projection * u_view * vec4(vPos, 1.0);
}
v_pos = vPos;
v_w = a_vPos.w;
v_alpha = alpha;
}
"""
-- | fragment shader
fragShader :: String fragShader :: String
fragShader = fragShader =
""" "#version 330 core\n"
#version 330 core ++ "out vec4 o_vColor;\n"
++ "in vec3 v_pos;\n"
uniform vec4 u_cam; ++ "void main()\n"
++ "{\n"
out vec4 o_vColor; ++ " o_vColor = vec4(0.5 + 0.5 * normalize(v_pos), 1);\n"
++ "}"
in vec3 v_pos;
in float v_w;
in float v_alpha;
void main()
{
// the normal vector of the face
// yoinked from https://stackoverflow.com/questions/14980712/how-to-get-flat-normals-on-a-cube/14981446#14981446
vec3 norm = normalize(cross(dFdx(v_pos), dFdy(v_pos)));
// creates a color based on the normal direction
o_vColor = vec4((0.5 + 0.5 * norm) / 2, v_alpha);
}
"""
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- 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
@@ -162,11 +101,11 @@ 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
@@ -176,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
@@ -252,10 +183,9 @@ 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)}
@@ -270,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

45
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
@@ -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)

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

@@ -1,79 +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, keys, program, 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],
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
@@ -82,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 :: V4 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 ::
V4 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
@@ -131,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

295
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 (..), (*^), _w, _xyz, _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 ()
@@ -36,7 +37,6 @@ main = do
GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
-- MSAA -- MSAA
GLFW.windowHint $ GLFW.WindowHint'Samples $ Just 8 GLFW.windowHint $ GLFW.WindowHint'Samples $ Just 8
-- alpha
-- create window -- create window
monitor <- GLFW.getPrimaryMonitor monitor <- GLFW.getPrimaryMonitor
Just window <- GLFW.createWindow 256 256 "hs-game" monitor Nothing Just window <- GLFW.createWindow 256 256 "hs-game" monitor Nothing
@@ -47,22 +47,13 @@ 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)
(object, program) <- (objects, program) <- initResources
initResources $ [ map (+ V3 a 0 0) cube | a <- take 100 [0,2..]]
concat -- init model
( [hCube]
++ [map (\v -> (V4 a 0 0 a) + (rotate4 0 1 (a * g90 / 24) v)) hCube | a <- take 1000 [0, 2 ..]]
++ [map (\v -> (V4 a 2 0 a) + (rotate4 0 2 (a * g90 / 24) v)) hCube | a <- take 1000 [0, 2 ..]]
++ [map (\v -> (V4 a 4 0 a) + (rotate4 0 3 (a * g90 / 24) v)) hCube | a <- take 1000 [0, 2 ..]]
++ [map (\v -> (V4 a (-2) 0 a) + (rotate4 1 0 (a * g90 / 24) v)) hCube | a <- take 1000 [0, 2 ..]]
++ [map (\v -> (V4 a (-4) 0 a) + (rotate4 2 0 (a * g90 / 24) v)) hCube | a <- take 1000 [0, 2 ..]]
++ [map (\v -> (V4 a (-6) 0 a) + (rotate4 3 0 (a * g90 / 24) v)) hCube | a <- take 1000 [0, 2 ..]]
)
let model = let model =
mkModel mkModel
(mkCamera (mkCamera
(V4 0 0 3 0) -- camPos (V3 0 0 3) -- camPos
0 -- pitch 0 -- pitch
0 -- yaw 0 -- yaw
(V3 0 0 (-1)) -- reference vector (V3 0 0 (-1)) -- reference vector
@@ -71,7 +62,7 @@ main = do
16 -- strafe strength 16 -- strafe strength
12 -- jump strength 12 -- jump strength
) )
[object] objects
program program
(mkWorldProperties 2 0.16 (V3 0 1 0)) (mkWorldProperties 2 0.16 (V3 0 1 0))
modelRef <- newIORef model modelRef <- newIORef model
@@ -83,150 +74,83 @@ main = do
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Arrays -- Arrays
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
top :: [V3 GL.GLfloat]
top =
[ V3 p 0 p
, V3 p 0 m
, V3 m 0 p
, V3 m 0 m
]
side :: [V3 GL.GLfloat]
side =
[ V3 0 p p
, V3 0 p m
, V3 0 m p
, V3 0 m m
]
front :: [V3 GL.GLfloat]
front =
[ V3 p p 0
, V3 p m 0
, V3 m p 0
, V3 m m 0
]
m = (0 - p) m = (0 - p)
p = 0.5 p = 0.5
g90 = pi / 2 -- TODO optimise cube
-- | cube vertices
v3tov4 :: GL.GLfloat -> V3 GL.GLfloat -> V4 GL.GLfloat
v3tov4 w (V3 x y z) = V4 x y z w
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
rotate :: V3 GL.GLfloat -> GL.GLfloat -> V3 GL.GLfloat -> V3 GL.GLfloat
rotate axis angle point = L.fromQuaternion (L.axisAngle axis angle) L.!* point
rotate4 :: Int -> Int -> GL.GLfloat -> V4 GL.GLfloat -> V4 GL.GLfloat
rotate4 i0 i1 angle (V4 x y z w) =
let coords = [x, y, z, w]
cos' = cos angle
sin' = sin angle
xi = coords !! i0
xj = coords !! i1
coords' =
[ if k == i0
then cos' * xi - sin' * xj
else
if k == i1
then sin' * xi + cos' * xj
else coords !! k
| k <- [0 .. 3]
]
in V4 (coords' !! 0) (coords' !! 1) (coords' !! 2) (coords' !! 3)
cycle3r :: V3 GL.GLfloat -> V3 GL.GLfloat
cycle3r (V3 a b c) = V3 c a b
cycle3l :: V3 GL.GLfloat -> V3 GL.GLfloat
cycle3l (V3 a b c) = V3 b c a
face :: [V3 GL.GLfloat]
face =
[ V3 m m 0,
V3 p m 0,
V3 m p 0,
V3 m p 0,
V3 p m 0,
V3 p p 0
]
-- | cube, side length 1, centered on 0 0 0
cube :: [V3 GL.GLfloat] cube :: [V3 GL.GLfloat]
cube = cube =
concatMap [ V3 p p p -- front
( \faceSpec -> , V3 p m p
map , V3 m p p
(\v -> (rotate (fst faceSpec) g90 v) L.^+^ (rotate (fst faceSpec) g90 (snd faceSpec))) , V3 m m p -- down
face , V3 m m m
) , V3 p m p
[ (V3 0 0 1, V3 0 0 p), , V3 p m m -- right
(V3 0 1 0, V3 0 0 p), , V3 p p m
(V3 1 0 0, V3 0 0 p), , V3 p m p
(V3 0 0 (-1), V3 0 0 m), -- no clue , V3 p p p -- up
(V3 0 (-1) 0, V3 0 0 p), , V3 m p p
(V3 (-1) 0 0, V3 0 0 p) , V3 p p m
] , V3 m p m -- back
, V3 p m m
hCube :: [V4 GL.GLfloat] , V3 p p m
hCube = , V3 m m m -- left
concatMap , V3 m p m
( \(w, i0, i1) -> , V3 m m p
map , V3 m p p
(rotate4 i0 i1 g90 . v3tov4 w)
cube
)
[ (p, 3, 0),
(p, 0, 3),
(p, 1, 3),
(p, 2, 3),
(m, 3, 0),
(m, 0, 3),
(m, 1, 3),
(m, 2, 3)
] ]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- 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 =
updateW dt $ updateVelocity dt
updateVelocity dt $ $ updateAcceleration dt
updateAcceleration dt $ $ updateSpeed dt
updateSpeed dt $ $ updateCameraAngle dt model
updateCameraAngle dt model
updateW :: Float -> Model -> Model
updateW dt model =
if elem GLFW.Key'R model.keys
then
model
{ camera =
model.camera
{ camPos = model.camera.camPos + (V4 0 0 0 (dt * dt * model.camera.strafeStrength))
}
}
else
if elem GLFW.Key'F model.keys
then
model
{ camera =
model.camera
{ camPos = model.camera.camPos - (V4 0 0 0 (dt * dt * model.camera.strafeStrength))
}
}
else 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
@@ -260,39 +184,35 @@ updateAcceleration dt model =
then V3 0 (0 - model.wprop.g * model.camera.airTime) 0 then V3 0 (0 - model.wprop.g * model.camera.airTime) 0
else V3 0 0 0 else V3 0 0 0
camVel' = friction * (model.camera.camVel + movement' + jump) camVel' = friction * (model.camera.camVel + movement' + jump)
aboveGround = ((model.camera.camPos ^. _xyz) + 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 * (V4 1 0 1 1), , camPos = model.camera.camPos * (V3 1 0 1)
hasJumped = aboveGround , hasJumped = aboveGround
} }
} }
@@ -301,8 +221,7 @@ updateVelocity dt model =
model model
{ camera = { camera =
model.camera model.camera
{ camPos = V4 1 1 1 (model.camera.camPos ^. _w) * (L.point $ (model.camera.camPos ^. _xyz) + dt L.*^ model.camera.camVel) {camPos = model.camera.camPos + dt L.*^ model.camera.camVel}
}
} }
updateCameraAngle :: Float -> Model -> Model updateCameraAngle :: Float -> Model -> Model
@@ -323,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
@@ -344,37 +263,21 @@ view window model = do
forward = V3 (cos pitch * sin yaw) (sin pitch) (cos pitch * cos yaw) forward = V3 (cos pitch * sin yaw) (sin pitch) (cos pitch * cos yaw)
viewMatrix = viewMatrix =
L.lookAt L.lookAt
(model.camera.camPos ^. _xyz) model.camera.camPos
((model.camera.camPos ^. _xyz) - forward) (model.camera.camPos - forward)
model.wprop.up model.wprop.up
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)
-- load 3d view matrix
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)
-- load 3d projection matrix
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
let camx = (\(V4 x _ _ _) -> x) model.camera.camPos
camy = (\(V4 _ y _ _) -> y) model.camera.camPos
camz = (\(V4 _ _ z _) -> z) model.camera.camPos
camw = (\(V4 _ _ _ w) -> w) model.camera.camPos
camWLocation <- GL.get $ GL.uniformLocation model.program "u_cam"
GL.uniform camWLocation $= GL.Vector4 camx camy camz camw
-- draw objects; returns IO [] -- draw objects; returns IO []
_ <- drawObjects model.objects _ <- drawObjects model.objects
-- swap to current buffer -- swap to current buffer