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

merge development into master

Browse Source
This commit is contained in:
mtgmonkey
2025-12-21 12:23:57 +01:00
parent e9b4e2d34a
commit a62275f853
7 changed files with 382 additions and 413 deletions
Download Patch File Download Diff File Expand all files Collapse all files

15
CHANGELOG.md
View File

@@ -20,6 +20,21 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
- use `Double` rather than `FLoat` for internal calculations - use `Double` rather than `FLoat` for internal calculations
- `cursorPos`, `dt` natively `Double` already - `cursorPos`, `dt` natively `Double` already
## [0.4.0] - 2025-12-21
### Added
- cube as array of points
- debug feature where `t` and `g` raise and lower speed respectively
### Changed
- `initResources` now takes `[[V3 GL.GLfloat]]` rather than `[V3 GL.GLfloat]`
- to migrate: rather than passing `a` pass `[a]`; behaviour is the same
- reduce view distance to 1'000 from 10'000
- color pixels based on normalized coordinates
- use `haskellPackages.callCabal2nix` in `flake.nix` for brevity, same behaviour
## [0.3.0] - 2025-12-08 ## [0.3.0] - 2025-12-08
### Added ### Added

32
flake.nix
View File

@@ -7,41 +7,11 @@
self, self,
... ...
}: let }: let
versionString = "0.3.0";
package = {
mkDerivation,
base,
bytestring,
GLFW-b,
lens,
lib,
linear,
OpenGL,
}:
mkDerivation {
pname = "hs-game";
version = versionString;
src = ./.;
isLibrary = false;
isExecutable = true;
executableHaskellDepends = [
base
bytestring
GLFW-b
lens
linear
OpenGL
];
homepage = "https://git.mtgmonkey.net/Andromeda/hs-game";
license = lib.licenses.bsd3;
mainProgram = "hs-game";
};
system = "x86_64-linux"; system = "x86_64-linux";
pkgs = nixpkgs.legacyPackages.${system}; pkgs = nixpkgs.legacyPackages.${system};
in { in {
packages.${system} = { packages.${system} = {
default = default = pkgs.haskellPackages.callCabal2nix "hs-game" ./. {};
pkgs.haskellPackages.callPackage package {};
}; };
devShells.${system} = { devShells.${system} = {
default = pkgs.mkShell { default = pkgs.mkShell {

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.3.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

143
src/Game/Internal.hs
View File

@@ -1,4 +1,5 @@
{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-} {-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
{- | {- |
- Module : Game.Internal - Module : Game.Internal
- Description : internal functions - Description : internal functions
@@ -18,8 +19,7 @@ module Game.Internal
, updateCursorPos , updateCursorPos
, updateKeyPressed , updateKeyPressed
, updateKeyReleased , updateKeyReleased
) ) where
where
import Game.Internal.LoadShaders import Game.Internal.LoadShaders
import Game.Internal.Types import Game.Internal.Types
@@ -30,79 +30,78 @@ import Data.IORef (IORef, modifyIORef', readIORef)
import Data.List (delete) import Data.List (delete)
import Foreign.Marshal.Array (withArray) import Foreign.Marshal.Array (withArray)
import Foreign.Ptr (nullPtr, plusPtr) import Foreign.Ptr (nullPtr, plusPtr)
import Foreign.Storable (sizeOf, Storable) import Foreign.Storable (Storable, sizeOf)
import GHC.Float (double2Float) import GHC.Float (double2Float)
import qualified Graphics.UI.GLFW as GLFW
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL as GL (($=)) import Graphics.Rendering.OpenGL (($=))
import qualified Graphics.UI.GLFW as GLFW
import Linear (V3(..)) import Linear (V3(..))
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Shader creation and object initialisation -- Shader creation and object initialisation
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | loads models, shaders -- | loads models, shaders
initResources :: [V3 GL.GLfloat] -> IO ([Object], GL.Program) initResources :: [[V3 GL.GLfloat]] -> IO ([Object], GL.Program)
initResources array = do initResources arrays = do
-- create objects -- create objects
testObject0 <- createObject (map (+(V3 (-1) (-1) (-1))) array) 3 GL.TriangleStrip objects <- listIOsToIOlist [ createObject arr 3 GL.TriangleStrip | arr <- arrays ] []
testObject1 <- createObject (map (+(V3 (1) (1) (1))) array) 3 GL.TriangleStrip
testObject2 <- createObject array 3 GL.TriangleStrip
let objects = [testObject0, testObject1, testObject2]
-- load shaders -- load shaders
program <- loadShaders program <-
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 [] out = return out
listIOsToIOlist (io:ios) out = do
ioVal <- io
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 vec3 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"
"void main()\n" ++ ++ "void main()\n"
"{\n" ++ ++ "{\n"
" gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n" ++ ++ " gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n"
" v_pos = a_vPos;\n" ++ ++ " v_pos = a_vPos;\n"
"}" ++ "}"
-- | fragment shader -- | fragment shader
fragShader :: String fragShader :: String
fragShader = fragShader =
"#version 330 core\n" ++ "#version 330 core\n"
"out vec4 o_vColor;\n" ++ ++ "out vec4 o_vColor;\n"
"in vec3 v_pos;\n" ++ ++ "in vec3 v_pos;\n"
"void main()\n" ++ ++ "void main()\n"
"{\n" ++ ++ "{\n"
" o_vColor = vec4(0.5 + 0.5 * v_pos, 1);\n" ++ ++ " o_vColor = vec4(0.5 + 0.5 * normalize(v_pos), 1);\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
@@ -111,29 +110,19 @@ createVBO array numComponents attribLocation = do
-- vbo for buffer -- vbo for buffer
buffer <- GL.genObjectName buffer <- GL.genObjectName
GL.bindBuffer GL.ArrayBuffer $= Just buffer GL.bindBuffer GL.ArrayBuffer $= Just buffer
-- populate buffer -- populate buffer
withArray withArray array $ \ptr ->
array
$ \ptr ->
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 , GL.VertexArrayDescriptor numComponents GL.Float 0 (plusPtr nullPtr 0))
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
@@ -142,25 +131,16 @@ createObject array numComponents primitiveMode = 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 $ GL.AttribLocation 0 _ <- 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 ::
:: GLFW.Window -- ^ window to display on GLFW.Window -- ^ window to display on
-> Float -- ^ dt -> Float -- ^ dt
-> (Float -> Model -> Model) -- ^ update function -> (Float -> Model -> Model) -- ^ update function
-> (GLFW.Window -> Model -> IO ()) -- ^ view function -> (GLFW.Window -> Model -> IO ()) -- ^ view function
@@ -169,37 +149,29 @@ loop
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
-- tick model -- tick model
modifyIORef' modelRef $ update dt modifyIORef' modelRef $ update dt
model' <- readIORef modelRef model' <- readIORef modelRef
-- view new model -- view new model
view window model' view window model'
-- end frame timer, wait the difference between expected and actual -- end frame timer, wait the difference between expected and actual
Just frameEnd <- GLFW.getTime Just frameEnd <- GLFW.getTime
let let drawTime = double2Float $ frameEnd - frameStart
drawTime = double2Float $ frameEnd - frameStart
target = 1 / 60 :: Float target = 1 / 60 :: Float
when (drawTime < target) $ threadDelay $ floor $ (target - drawTime) * 1000000 when (drawTime < target) $ threadDelay $ floor $ (target - drawTime) * 1000000
Just frameEnd' <- GLFW.getTime Just frameEnd' <- GLFW.getTime
let let dt' = double2Float $ frameEnd' - frameStart
dt' = double2Float $ frameEnd' - frameStart
loop window dt' update view modelRef loop window dt' update view modelRef
-- | updates given a keypress. escape case is probably caught by GLFW in the -- | updates given a keypress. escape case is probably caught by GLFW in the
-- handler function itself -- handler function itself
updateKeyPressed :: GLFW.Key -> Model -> Model updateKeyPressed :: GLFW.Key -> Model -> Model
updateKeyPressed key model = updateKeyPressed key model = model {keys = key : model.keys}
model { keys = key:model.keys }
-- | updates given a keyrelease. escape case is probably caught by GLFW in the -- | updates given a keyrelease. escape case is probably caught by GLFW in the
-- handler function itself -- handler function itself
updateKeyReleased :: GLFW.Key -> Model -> Model updateKeyReleased :: GLFW.Key -> Model -> Model
updateKeyReleased key model = updateKeyReleased key model = model {keys = (delete key model.keys)}
model { keys = (delete key model.keys) }
applyToTuples :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c) applyToTuples :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
applyToTuples f (x, y) (a, b) = (f x a, f y b) applyToTuples f (x, y) (a, b) = (f x a, f y b)
@@ -207,24 +179,20 @@ applyToTuples f (x, y) (a, b) = (f x a, f y b)
-- | updates cursor -- | updates cursor
updateCursorPos :: Double -> Double -> Model -> Model updateCursorPos :: Double -> Double -> Model -> Model
updateCursorPos x y model = updateCursorPos x y model =
let let pyth =
pyth = (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos) - y) ** 2) ** 0.5 (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos) - y) ** 2)
in ** 0.5
if pyth < 16 then in if pyth < 16
model then model
{ cursorPos = (x, y) { cursorPos = (x, y)
, cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y) , cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y)
} }
else else model {cursorPos = (x, y)}
model
{ cursorPos = (x, y)
}
-- | draws objects -- | draws objects
drawObjects :: [Object] -> IO ([Object]) drawObjects :: [Object] -> IO ([Object])
drawObjects [] = return [] drawObjects [] = return []
drawObjects drawObjects ((Object vao numVertices _ primitiveMode):objects) = do
((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
@@ -232,7 +200,6 @@ drawObjects
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- interrupts -- interrupts
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | shuts down GLFW -- | shuts down GLFW
shutdownWindow :: GLFW.WindowCloseCallback shutdownWindow :: GLFW.WindowCloseCallback
shutdownWindow window = do shutdownWindow window = do

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

@@ -12,10 +12,11 @@
-- Red Book Authors. -- Red Book Authors.
-- --
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
module Game.Internal.LoadShaders
module Game.Internal.LoadShaders ( ( ShaderSource(..)
ShaderSource(..), ShaderInfo(..), loadShaders , ShaderInfo(..)
) where , loadShaders
) where
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
@@ -23,17 +24,15 @@ 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 = = 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 'B.ByteString'.
| StringSource String | StringSource String
-- ^ The shader source code is directly given as a 'String'. -- ^ The shader source code is directly given as a 'String'.
| FileSource FilePath | FileSource FilePath
-- ^ The shader source code is located in the file at the given '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
getSource (ByteStringSource bs) = return bs getSource (ByteStringSource bs) = return bs
@@ -41,17 +40,14 @@ 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
loadShaders infos = loadShaders infos =
createProgram `bracketOnError` deleteObjectName $ \program -> do createProgram `bracketOnError` deleteObjectName $ \program -> do
@@ -64,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
@@ -75,7 +71,8 @@ loadCompileAttach program (ShaderInfo shType source : infos) =
compileAndCheck :: Shader -> IO () compileAndCheck :: Shader -> IO ()
compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile" compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile"
checked :: (t -> IO ()) checked ::
(t -> IO ())
-> (t -> GettableStateVar Bool) -> (t -> GettableStateVar Bool)
-> (t -> GettableStateVar String) -> (t -> GettableStateVar String)
-> String -> String

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

@@ -1,4 +1,5 @@
{-# LANGUAGE NamedFieldPuns, OverloadedRecordDot #-} {-# LANGUAGE NamedFieldPuns, OverloadedRecordDot #-}
{- | {- |
- Module : Game.Internal.Types - Module : Game.Internal.Types
- Description : - Description :
@@ -9,70 +10,52 @@
-} -}
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.UI.GLFW as GLFW
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLFW as GLFW
import qualified Linear as L import qualified Linear as L
import Linear (V3, V3(..), V4(..)) import Linear (V3, V3(..), V4(..))
-- | represents a single draw call -- | represents a single draw call
data Object = data Object = Object
Object
{ vao :: GL.VertexArrayObject -- ^ vao of vertex buffer { vao :: GL.VertexArrayObject -- ^ vao of vertex buffer
, numIndicies :: GL.NumArrayIndices -- ^ number of vertices , numIndicies :: GL.NumArrayIndices -- ^ number of vertices
, numComponents :: GL.NumComponents -- ^ dimensionallity; vec3, vec4, etc. , numComponents :: GL.NumComponents -- ^ dimensionallity; vec3, vec4, etc.
, primitiveMode :: GL.PrimitiveMode -- ^ primitive mode to be drawn with , primitiveMode :: GL.PrimitiveMode -- ^ primitive mode to be drawn with
} } deriving (Show)
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 toGLMatrix (V4 (V4 c00 c01 c02 c03) (V4 c10 c11 c12 c13) (V4 c20 c21 c22 c23) (V4 c30 c31 c32 c33)) =
(V4 [ c00
(V4 c00 c01 c02 c03) , c01
(V4 c10 c11 c12 c13) , c02
(V4 c20 c21 c22 c23) , c03
(V4 c30 c31 c32 c33)) = , c10
[ c00, c01, c02, c03 , c11
, c10, c11, c12, c13 , c12
, c20, c21, c22, c23 , c13
, c30, c31, c32, c33 , c20
, c21
, c22
, c23
, c30
, c31
, c32
, c33
] ]
-- | gamestate -- | gamestate
data Model = data Model = Model
Model
{ camera :: Camera { camera :: Camera
, cursorDeltaPos :: (Double, Double) -- ^ frame-on-frame delta mouse position , cursorDeltaPos :: (Double, Double) -- ^ frame-on-frame delta mouse position
, cursorPos :: (Double, Double) -- ^ current mouse position , cursorPos :: (Double, Double) -- ^ current mouse position
@@ -80,29 +63,15 @@ data Model =
, objects :: [Object] -- ^ draw calls , objects :: [Object] -- ^ draw calls
, program :: GL.Program -- ^ shader program , program :: GL.Program -- ^ shader program
, wprop :: WorldProperties , wprop :: WorldProperties
} } deriving (Show)
deriving Show
-- | smart constructor for Model -- | smart constructor for Model
mkModel mkModel :: Camera -> [Object] -> GL.Program -> WorldProperties -> Model
:: Camera
-> [Object]
-> GL.Program
-> WorldProperties
-> Model
mkModel camera objects program wprop = mkModel camera objects program wprop =
Model Model camera (0, 0) (0, 0) [] objects program wprop
camera
(0,0)
(0,0)
[]
objects
program
wprop
-- | camera -- | camera
data Camera = data Camera = Camera
Camera
{ camPos :: V3 Float -- ^ position in world space { camPos :: V3 Float -- ^ position in world space
, camPitch :: Float -- ^ pitch in radians, up positive , camPitch :: Float -- ^ pitch in radians, up positive
, camYaw :: Float -- ^ yaw in radians, right positive , camYaw :: Float -- ^ yaw in radians, right positive
@@ -113,12 +82,11 @@ data Camera =
, jumpStrength :: Float -- ^ scale factor for jump initial velocity , jumpStrength :: Float -- ^ scale factor for jump initial velocity
, hasJumped :: Bool -- ^ whether the camera still has jumping state , hasJumped :: Bool -- ^ whether the camera still has jumping state
, airTime :: Float -- ^ time since jumping state entered in seconds , airTime :: Float -- ^ time since jumping state entered in seconds
} } deriving (Show)
deriving Show
-- | smart constructor for Camera -- | smart constructor for Camera
mkCamera mkCamera ::
:: V3 Float V3 Float
-> Float -> Float
-> Float -> Float
-> V3 Float -> V3 Float
@@ -127,15 +95,7 @@ mkCamera
-> Float -> Float
-> Float -> Float
-> Camera -> Camera
mkCamera mkCamera camPos camPitch camYaw camReference camVel mouseSensitivity strafeStrength jumpStrength =
camPos
camPitch
camYaw
camReference
camVel
mouseSensitivity
strafeStrength
jumpStrength =
Camera Camera
camPos camPos
camPitch camPitch
@@ -149,15 +109,12 @@ mkCamera
0 0
-- | physical properties of the world -- | physical properties of the world
data WorldProperties = data WorldProperties = WorldProperties
WorldProperties
{ g :: Float -- ^ gravity `g` { g :: Float -- ^ gravity `g`
, friction :: Float -- ^ scale factor for floor friction , friction :: Float -- ^ scale factor for floor friction
, up :: V3 Float -- ^ global up vector , up :: V3 Float -- ^ global up vector
} } deriving (Show)
deriving Show
-- | smart constructor for WorldProperties -- | smart constructor for WorldProperties
mkWorldProperties :: Float -> Float -> V3 Float-> WorldProperties mkWorldProperties :: Float -> Float -> V3 Float -> WorldProperties
mkWorldProperties g friction up = mkWorldProperties g friction up = WorldProperties g friction (L.normalize up)
WorldProperties g friction (L.normalize up)

239
src/Main.hs
View File

@@ -1,4 +1,5 @@
{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-} {-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
{- | {- |
- Module : Game - Module : Game
- Description : runs game - Description : runs game
@@ -7,53 +8,49 @@
- Maintainer : Matrix @Andromeda:tchncs.de - Maintainer : Matrix @Andromeda:tchncs.de
- Stability : Experimental - Stability : Experimental
-} -}
module Main (main) where module Main
( main
) where
import Game.Internal.Types
import Game.Internal 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 qualified Graphics.UI.GLFW as GLFW
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL as GL (($=)) import Graphics.Rendering.OpenGL (($=))
import qualified Graphics.UI.GLFW as GLFW
import qualified Linear as L import qualified Linear as L
import Linear ( V3(..), _y ) import Linear (V3(..), _y)
-- | Main function runs game -- | Main function runs game
main :: IO () main :: IO ()
main = do main = do
_ <- GLFW.init _ <- GLFW.init
GLFW.defaultWindowHints GLFW.defaultWindowHints
-- OpenGL core >=3.3 -- OpenGL core >=3.3
GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor 3 GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor 3
GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 3 GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 3
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
-- 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
GLFW.makeContextCurrent $ Just window GLFW.makeContextCurrent $ Just window
-- add callbacks -- add callbacks
GLFW.setWindowCloseCallback window $ Just shutdownWindow GLFW.setWindowCloseCallback window $ Just shutdownWindow
GLFW.setWindowSizeCallback window $ Just resizeWindow GLFW.setWindowSizeCallback window $ Just resizeWindow
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) <- initResources
(objects, program) <- initResources testVertices [ map (+ V3 a 0 0) cube | a <- take 100 [0,2..]]
-- init model -- init model
let let model =
model =
mkModel mkModel
(mkCamera (mkCamera
(V3 0 0 3) -- camPos (V3 0 0 3) -- camPos
@@ -67,84 +64,151 @@ main = do
) )
objects objects
program program
(mkWorldProperties (mkWorldProperties 2 0.16 (V3 0 1 0))
2
0.16
(V3 0 1 0)
)
modelRef <- newIORef model modelRef <- newIORef model
-- add callbacks with io ref to model -- add callbacks with io ref to model
GLFW.setKeyCallback window $ Just $ keyPressed $ Just modelRef GLFW.setKeyCallback window $ Just $ keyPressed $ Just modelRef
GLFW.setCursorPosCallback window $ Just $ cursorPosHandler $ Just modelRef GLFW.setCursorPosCallback window $ Just $ cursorPosHandler $ Just modelRef
loop window 0 update view modelRef loop window 0 update view modelRef
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- 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
]
-- | centered unit square m = (0 - p)
testVertices :: [V3 GL.GLfloat] p = 0.5
testVertices =
[ V3 (-0.5) (-0.5) 0 -- TODO optimise cube
, V3 0.5 (-0.5) 0 -- | cube vertices
, V3 (-0.5) 0.5 0 cube :: [V3 GL.GLfloat]
, V3 0.5 0.5 0 cube =
[ V3 p p p -- front
, V3 p m p
, V3 m p p
, V3 m m p -- down
, V3 m m m
, V3 p m p
, V3 p m m -- right
, V3 p p m
, V3 p m p
, V3 p p p -- up
, V3 m p p
, V3 p p m
, V3 m p m -- back
, V3 p m m
, V3 p p m
, V3 m m m -- left
, V3 m p m
, V3 m m p
, V3 m p p
] ]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- 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 updateVelocity dt
dt $ updateAcceleration dt
$ updateAcceleration $ updateSpeed dt
dt $ updateCameraAngle dt model
$ updateCameraAngle
dt updateSpeed :: Float -> Model -> Model
updateSpeed dt model =
if elem GLFW.Key'T model.keys then
model model
{ camera =
model.camera
{ jumpStrength = model.camera.jumpStrength * 1.1
, strafeStrength = model.camera.strafeStrength * 1.1
}
}
else if elem GLFW.Key'G model.keys then
model
{ camera =
model.camera
{ jumpStrength = model.camera.jumpStrength * 0.99
, strafeStrength = model.camera.strafeStrength * 0.99
}
}
else model
updateAcceleration :: Float -> Model -> Model updateAcceleration :: Float -> Model -> Model
updateAcceleration dt model = updateAcceleration dt model =
let let zp =
zp = if elem GLFW.Key'S model.keys then 1 else 0 if elem GLFW.Key'S model.keys
zn = if elem GLFW.Key'W model.keys then 1 else 0 then 1
xp = if elem GLFW.Key'D model.keys then 1 else 0 else 0
xn = if elem GLFW.Key'A 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 x = xp - xn
z = zp - zn z = zp - zn
friction = V3 (1 - model.wprop.friction) 1 (1 - model.wprop.friction) 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.normalize (V3 x 0 z) L.^* (dt * model.camera.strafeStrength)
movement' = L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) movement movement' =
L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) movement
jump = jump =
if model.camera.hasJumped then if model.camera.hasJumped
V3 0 (0 - model.wprop.g * model.camera.airTime) 0 then V3 0 (0 - model.wprop.g * model.camera.airTime) 0
else else V3 0 0 0
V3 0 0 0
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 in if (elem GLFW.Key'Space model.keys) && (model.camera.hasJumped == False)
if then updateAcceleration dt
(elem GLFW.Key'Space model.keys) $ model
&& (model.camera.hasJumped == False) { camera =
then model.camera
updateAcceleration dt $ model { camera = model.camera { airTime = dt, camVel = model.camera.camVel + (V3 0 model.camera.jumpStrength 0), hasJumped = True } } { airTime = dt
else , camVel =
if aboveGround then model.camera.camVel
model + (V3 0 model.camera.jumpStrength 0)
{ camera = model.camera , hasJumped = True
}
}
else if aboveGround
then 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)
@@ -155,28 +219,31 @@ updateAcceleration dt model =
updateVelocity :: Float -> Model -> Model updateVelocity :: Float -> Model -> Model
updateVelocity dt model = updateVelocity dt model =
model model
{ camera = model.camera { camera =
{ camPos = model.camera.camPos + dt L.*^ model.camera.camVel model.camera
} {camPos = model.camera.camPos + dt L.*^ model.camera.camVel}
} }
updateCameraAngle :: Float -> Model -> Model updateCameraAngle :: Float -> Model -> Model
updateCameraAngle dt model = updateCameraAngle dt model =
let let scaleFactor = model.camera.mouseSensitivity * dt
scaleFactor = model.camera.mouseSensitivity * dt newPitch =
newPitch = model.camera.camPitch - model.camera.camPitch
scaleFactor * (double2Float $ snd model.cursorDeltaPos) -- mouse sensitivity, update pitch - scaleFactor * (double2Float $ snd model.cursorDeltaPos) -- mouse sensitivity, update pitch
newPitch' = if newPitch > 1.56 then 1.56 else newPitch newPitch' =
newPitch'' = if newPitch' < (-1.56) then (-1.56) else newPitch' if newPitch > 1.56
newYaw = model.camera.camYaw + then 1.56
scaleFactor * (double2Float $ fst model.cursorDeltaPos) else newPitch
in newPitch'' =
model if newPitch' < (-1.56)
then (-1.56)
else newPitch'
newYaw =
model.camera.camYaw
+ scaleFactor * (double2Float $ fst model.cursorDeltaPos)
in model
{ cursorDeltaPos = (0, 0) { cursorDeltaPos = (0, 0)
, camera = model.camera , camera = model.camera {camPitch = newPitch'', camYaw = newYaw}
{ camPitch = newPitch''
, camYaw = newYaw
}
} }
-- | views the model -- | views the model
@@ -185,17 +252,13 @@ view window model = do
-- fit viewport to window -- fit viewport to window
(w, h) <- GLFW.getFramebufferSize window (w, h) <- GLFW.getFramebufferSize window
GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
-- clear screen -- clear screen
GL.clearColor $= GL.Color4 1 0 1 1 GL.clearColor $= GL.Color4 1 0 1 1
GL.clear [GL.ColorBuffer, GL.DepthBuffer] GL.clear [GL.ColorBuffer, GL.DepthBuffer]
-- depth -- depth
GL.depthFunc $= Just GL.Less GL.depthFunc $= Just GL.Less
-- apply transforms -- apply transforms
let let pitch = model.camera.camPitch
pitch = model.camera.camPitch
yaw = model.camera.camYaw yaw = model.camera.camYaw
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 =
@@ -203,21 +266,21 @@ view window model = do
model.camera.camPos model.camera.camPos
(model.camera.camPos - forward) (model.camera.camPos - forward)
model.wprop.up model.wprop.up
projectionMatrix = L.perspective 1.5 (fromIntegral w / fromIntegral h) 0.01 10000 projectionMatrix =
L.perspective 1.2 (fromIntegral w / fromIntegral h) 0.01 1000
viewGLMatrix <- GL.newMatrix GL.RowMajor $ toGLMatrix viewMatrix :: IO (GL.GLmatrix GL.GLfloat) viewGLMatrix <-
GL.newMatrix GL.RowMajor $ toGLMatrix viewMatrix :: IO
(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 :: IO (GL.GLmatrix GL.GLfloat) GL.newMatrix GL.RowMajor $ toGLMatrix projectionMatrix :: IO
(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
-- draw objects; returns IO [] -- draw objects; returns IO []
_ <- drawObjects model.objects _ <- drawObjects model.objects
-- swap to current buffer -- swap to current buffer
GLFW.swapBuffers window GLFW.swapBuffers window
-- check for interrupts -- check for interrupts
GLFW.pollEvents GLFW.pollEvents