merge development into master
This commit is contained in:
mtgmonkey
15
CHANGELOG.md
15
CHANGELOG.md
@@ -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
|
||||
- `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
|
||||
|
||||
### Added
|
||||
|
||||
32
flake.nix
32
flake.nix
@@ -7,41 +7,11 @@
|
||||
self,
|
||||
...
|
||||
}: 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";
|
||||
pkgs = nixpkgs.legacyPackages.${system};
|
||||
in {
|
||||
packages.${system} = {
|
||||
default =
|
||||
pkgs.haskellPackages.callPackage package {};
|
||||
default = pkgs.haskellPackages.callCabal2nix "hs-game" ./. {};
|
||||
};
|
||||
devShells.${system} = {
|
||||
default = pkgs.mkShell {
|
||||
|
||||
@@ -1,6 +1,6 @@
|
||||
cabal-version: 3.0
|
||||
name: hs-game
|
||||
version: 0.3.0
|
||||
version: 0.4.0
|
||||
-- synopsis:
|
||||
-- description:
|
||||
homepage: https://git.mtgmonkey.net/Andromeda/hs-game
|
||||
|
||||
@@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
|
||||
|
||||
{- |
|
||||
- Module : Game.Internal
|
||||
- Description : internal functions
|
||||
@@ -18,91 +19,89 @@ module Game.Internal
|
||||
, updateCursorPos
|
||||
, updateKeyPressed
|
||||
, updateKeyReleased
|
||||
)
|
||||
where
|
||||
) where
|
||||
|
||||
import Game.Internal.LoadShaders
|
||||
import Game.Internal.Types
|
||||
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Monad (when)
|
||||
import Data.IORef (IORef, modifyIORef', readIORef)
|
||||
import Data.List (delete)
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Monad (when)
|
||||
import Data.IORef (IORef, modifyIORef', readIORef)
|
||||
import Data.List (delete)
|
||||
import Foreign.Marshal.Array (withArray)
|
||||
import Foreign.Ptr (nullPtr, plusPtr)
|
||||
import Foreign.Storable (sizeOf, Storable)
|
||||
import GHC.Float (double2Float)
|
||||
import Foreign.Ptr (nullPtr, plusPtr)
|
||||
import Foreign.Storable (Storable, sizeOf)
|
||||
import GHC.Float (double2Float)
|
||||
|
||||
import qualified Graphics.UI.GLFW as GLFW
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
import Graphics.Rendering.OpenGL as GL (($=))
|
||||
import Graphics.Rendering.OpenGL (($=))
|
||||
import qualified Graphics.UI.GLFW as GLFW
|
||||
|
||||
import Linear (V3(..))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Shader creation and object initialisation
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | loads models, shaders
|
||||
initResources :: [V3 GL.GLfloat] -> IO ([Object], GL.Program)
|
||||
initResources array = do
|
||||
initResources :: [[V3 GL.GLfloat]] -> IO ([Object], GL.Program)
|
||||
initResources arrays = do
|
||||
-- create objects
|
||||
testObject0 <- createObject (map (+(V3 (-1) (-1) (-1))) array) 3 GL.TriangleStrip
|
||||
testObject1 <- createObject (map (+(V3 (1) (1) (1))) array) 3 GL.TriangleStrip
|
||||
testObject2 <- createObject array 3 GL.TriangleStrip
|
||||
let objects = [testObject0, testObject1, testObject2]
|
||||
|
||||
objects <- listIOsToIOlist [ createObject arr 3 GL.TriangleStrip | arr <- arrays ] []
|
||||
-- load shaders
|
||||
program <- loadShaders
|
||||
[ ShaderInfo GL.VertexShader (StringSource vertShader)
|
||||
, ShaderInfo GL.FragmentShader (StringSource fragShader)
|
||||
]
|
||||
program <-
|
||||
loadShaders
|
||||
[ ShaderInfo GL.VertexShader (StringSource vertShader)
|
||||
, ShaderInfo GL.FragmentShader (StringSource fragShader)
|
||||
]
|
||||
GL.currentProgram $= Just program
|
||||
|
||||
return (objects, program)
|
||||
|
||||
listIOsToIOlist :: [IO a] -> [a] -> IO [a]
|
||||
listIOsToIOlist [] out = return out
|
||||
listIOsToIOlist (io:ios) out = do
|
||||
ioVal <- io
|
||||
listIOsToIOlist ios (ioVal:out)
|
||||
|
||||
-- a_ vertex shader input
|
||||
-- v_ varying
|
||||
-- u_ uniform
|
||||
-- o_ fragment shader output
|
||||
|
||||
-- | vertex shader
|
||||
vertShader :: String
|
||||
vertShader =
|
||||
"#version 330 core\n" ++
|
||||
"layout (location = 0) in vec3 a_vPos;\n" ++
|
||||
"uniform mat4 u_view;\n" ++
|
||||
"uniform mat4 u_projection;\n" ++
|
||||
"out vec3 v_pos;\n" ++
|
||||
"void main()\n" ++
|
||||
"{\n" ++
|
||||
" gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n" ++
|
||||
" v_pos = a_vPos;\n" ++
|
||||
"}"
|
||||
"#version 330 core\n"
|
||||
++ "layout (location = 0) in vec3 a_vPos;\n"
|
||||
++ "uniform mat4 u_view;\n"
|
||||
++ "uniform mat4 u_projection;\n"
|
||||
++ "out vec3 v_pos;\n"
|
||||
++ "void main()\n"
|
||||
++ "{\n"
|
||||
++ " gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n"
|
||||
++ " v_pos = a_vPos;\n"
|
||||
++ "}"
|
||||
|
||||
-- | fragment shader
|
||||
fragShader :: String
|
||||
fragShader =
|
||||
"#version 330 core\n" ++
|
||||
"out vec4 o_vColor;\n" ++
|
||||
"in vec3 v_pos;\n" ++
|
||||
"void main()\n" ++
|
||||
"{\n" ++
|
||||
" o_vColor = vec4(0.5 + 0.5 * v_pos, 1);\n" ++
|
||||
"}"
|
||||
"#version 330 core\n"
|
||||
++ "out vec4 o_vColor;\n"
|
||||
++ "in vec3 v_pos;\n"
|
||||
++ "void main()\n"
|
||||
++ "{\n"
|
||||
++ " o_vColor = vec4(0.5 + 0.5 * normalize(v_pos), 1);\n"
|
||||
++ "}"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Objects
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | calculates the size in memory of an array
|
||||
sizeOfArray :: (Storable a, Num b) => [a] -> b
|
||||
sizeOfArray [] = 0
|
||||
sizeOfArray (x:xs) = fromIntegral $ (*) (1 + length xs) $ sizeOf x
|
||||
|
||||
-- | loads a given array into a given attribute index
|
||||
createVBO
|
||||
:: Storable (a GL.GLfloat)
|
||||
createVBO ::
|
||||
Storable (a GL.GLfloat)
|
||||
=> [a GL.GLfloat]
|
||||
-> GL.NumComponents
|
||||
-> GL.AttribLocation
|
||||
@@ -111,29 +110,19 @@ createVBO array numComponents attribLocation = do
|
||||
-- vbo for buffer
|
||||
buffer <- GL.genObjectName
|
||||
GL.bindBuffer GL.ArrayBuffer $= Just buffer
|
||||
|
||||
-- populate buffer
|
||||
withArray
|
||||
array
|
||||
$ \ptr ->
|
||||
GL.bufferData GL.ArrayBuffer $= (sizeOfArray array, ptr, GL.StaticDraw)
|
||||
|
||||
withArray array $ \ptr ->
|
||||
GL.bufferData GL.ArrayBuffer $= (sizeOfArray array, ptr, GL.StaticDraw)
|
||||
-- create attribute pointer to buffer
|
||||
GL.vertexAttribPointer attribLocation $=
|
||||
( GL.ToFloat
|
||||
, GL.VertexArrayDescriptor
|
||||
numComponents
|
||||
GL.Float
|
||||
0
|
||||
(plusPtr nullPtr 0)
|
||||
)
|
||||
GL.vertexAttribPointer attribLocation
|
||||
$= ( GL.ToFloat
|
||||
, GL.VertexArrayDescriptor numComponents GL.Float 0 (plusPtr nullPtr 0))
|
||||
GL.vertexAttribArray attribLocation $= GL.Enabled
|
||||
|
||||
return buffer
|
||||
|
||||
-- | creates an object from a given array; deals with vbos and everything
|
||||
createObject
|
||||
:: Storable (a GL.GLfloat)
|
||||
createObject ::
|
||||
Storable (a GL.GLfloat)
|
||||
=> [a GL.GLfloat]
|
||||
-> GL.NumComponents
|
||||
-> GL.PrimitiveMode
|
||||
@@ -142,25 +131,16 @@ createObject array numComponents primitiveMode = do
|
||||
-- vao for object
|
||||
vao <- GL.genObjectName
|
||||
GL.bindVertexArrayObject $= Just vao
|
||||
|
||||
-- vbo for vertices
|
||||
_ <- 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
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | gameloop
|
||||
loop
|
||||
:: GLFW.Window -- ^ window to display on
|
||||
loop ::
|
||||
GLFW.Window -- ^ window to display on
|
||||
-> Float -- ^ dt
|
||||
-> (Float -> Model -> Model) -- ^ update function
|
||||
-> (GLFW.Window -> Model -> IO ()) -- ^ view function
|
||||
@@ -169,62 +149,50 @@ loop
|
||||
loop window dt update view modelRef = do
|
||||
-- start frame timer
|
||||
Just frameStart <- GLFW.getTime
|
||||
|
||||
-- tick model
|
||||
modifyIORef' modelRef $ update dt
|
||||
model' <- readIORef modelRef
|
||||
|
||||
-- view new model
|
||||
view window model'
|
||||
|
||||
-- end frame timer, wait the difference between expected and actual
|
||||
Just frameEnd <- GLFW.getTime
|
||||
let
|
||||
drawTime = double2Float $ frameEnd - frameStart
|
||||
target = 1 / 60 :: Float
|
||||
let drawTime = double2Float $ frameEnd - frameStart
|
||||
target = 1 / 60 :: Float
|
||||
when (drawTime < target) $ threadDelay $ floor $ (target - drawTime) * 1000000
|
||||
Just frameEnd' <- GLFW.getTime
|
||||
let
|
||||
dt' = double2Float $ frameEnd' - frameStart
|
||||
|
||||
let dt' = double2Float $ frameEnd' - frameStart
|
||||
loop window dt' update view modelRef
|
||||
|
||||
-- | updates given a keypress. escape case is probably caught by GLFW in the
|
||||
-- handler function itself
|
||||
updateKeyPressed :: GLFW.Key -> Model -> Model
|
||||
updateKeyPressed key model =
|
||||
model { keys = key:model.keys }
|
||||
updateKeyPressed key model = model {keys = key : model.keys}
|
||||
|
||||
-- | updates given a keyrelease. escape case is probably caught by GLFW in the
|
||||
-- handler function itself
|
||||
updateKeyReleased :: GLFW.Key -> Model -> Model
|
||||
updateKeyReleased key model =
|
||||
model { keys = (delete key model.keys) }
|
||||
updateKeyReleased key model = model {keys = (delete key model.keys)}
|
||||
|
||||
applyToTuples :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
|
||||
applyToTuples f (x, y) (a, b) = (f x a, f y b)
|
||||
|
||||
-- | updates cursor
|
||||
updateCursorPos :: Double -> Double -> Model -> Model
|
||||
updateCursorPos :: Double -> Double -> Model -> Model
|
||||
updateCursorPos x y model =
|
||||
let
|
||||
pyth = (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos) - y) ** 2) ** 0.5
|
||||
in
|
||||
if pyth < 16 then
|
||||
model
|
||||
{ cursorPos = (x, y)
|
||||
, cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y)
|
||||
}
|
||||
else
|
||||
model
|
||||
{ cursorPos = (x, y)
|
||||
}
|
||||
let pyth =
|
||||
(((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos) - y) ** 2)
|
||||
** 0.5
|
||||
in if pyth < 16
|
||||
then model
|
||||
{ cursorPos = (x, y)
|
||||
, cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y)
|
||||
}
|
||||
else model {cursorPos = (x, y)}
|
||||
|
||||
-- | draws objects
|
||||
drawObjects :: [Object] -> IO ([Object])
|
||||
drawObjects [] = return []
|
||||
drawObjects
|
||||
((Object vao numVertices _ primitiveMode):objects) = do
|
||||
drawObjects ((Object vao numVertices _ primitiveMode):objects) = do
|
||||
GL.bindVertexArrayObject $= Just vao
|
||||
GL.drawArrays primitiveMode 0 numVertices
|
||||
drawObjects objects
|
||||
@@ -232,7 +200,6 @@ drawObjects
|
||||
--------------------------------------------------------------------------------
|
||||
-- interrupts
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | shuts down GLFW
|
||||
shutdownWindow :: GLFW.WindowCloseCallback
|
||||
shutdownWindow window = do
|
||||
|
||||
@@ -12,10 +12,11 @@
|
||||
-- Red Book Authors.
|
||||
--
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
module Game.Internal.LoadShaders (
|
||||
ShaderSource(..), ShaderInfo(..), loadShaders
|
||||
) where
|
||||
module Game.Internal.LoadShaders
|
||||
( ShaderSource(..)
|
||||
, ShaderInfo(..)
|
||||
, loadShaders
|
||||
) where
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
@@ -23,17 +24,15 @@ import qualified Data.ByteString as B
|
||||
import Graphics.Rendering.OpenGL
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | The source of the shader source code.
|
||||
|
||||
data ShaderSource =
|
||||
ByteStringSource B.ByteString
|
||||
data ShaderSource
|
||||
= ByteStringSource 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'.
|
||||
| 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 (ByteStringSource bs) = return bs
|
||||
@@ -41,49 +40,47 @@ getSource (StringSource str) = return $ packUtf8 str
|
||||
getSource (FileSource path) = B.readFile path
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | A description of a shader: The type of the shader plus its source code.
|
||||
|
||||
data ShaderInfo = ShaderInfo ShaderType ShaderSource
|
||||
deriving ( Eq, Ord, Show )
|
||||
data ShaderInfo =
|
||||
ShaderInfo ShaderType ShaderSource
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Create a new program object from the given shaders, throwing an
|
||||
-- 'IOException' if something goes wrong.
|
||||
|
||||
loadShaders :: [ShaderInfo] -> IO Program
|
||||
loadShaders infos =
|
||||
createProgram `bracketOnError` deleteObjectName $ \program -> do
|
||||
loadCompileAttach program infos
|
||||
linkAndCheck program
|
||||
return program
|
||||
createProgram `bracketOnError` deleteObjectName $ \program -> do
|
||||
loadCompileAttach program infos
|
||||
linkAndCheck program
|
||||
return program
|
||||
|
||||
linkAndCheck :: Program -> IO ()
|
||||
linkAndCheck = checked linkProgram linkStatus programInfoLog "link"
|
||||
|
||||
loadCompileAttach :: Program -> [ShaderInfo] -> IO ()
|
||||
loadCompileAttach _ [] = return ()
|
||||
loadCompileAttach program (ShaderInfo shType source : infos) =
|
||||
createShader shType `bracketOnError` deleteObjectName $ \shader -> do
|
||||
src <- getSource source
|
||||
shaderSourceBS shader $= src
|
||||
compileAndCheck shader
|
||||
attachShader program shader
|
||||
loadCompileAttach program infos
|
||||
loadCompileAttach program (ShaderInfo shType source:infos) =
|
||||
createShader shType `bracketOnError` deleteObjectName $ \shader -> do
|
||||
src <- getSource source
|
||||
shaderSourceBS shader $= src
|
||||
compileAndCheck shader
|
||||
attachShader program shader
|
||||
loadCompileAttach program infos
|
||||
|
||||
compileAndCheck :: Shader -> IO ()
|
||||
compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile"
|
||||
|
||||
checked :: (t -> IO ())
|
||||
-> (t -> GettableStateVar Bool)
|
||||
-> (t -> GettableStateVar String)
|
||||
-> String
|
||||
-> t
|
||||
-> IO ()
|
||||
checked ::
|
||||
(t -> IO ())
|
||||
-> (t -> GettableStateVar Bool)
|
||||
-> (t -> GettableStateVar String)
|
||||
-> String
|
||||
-> t
|
||||
-> IO ()
|
||||
checked action getStatus getInfoLog message object = do
|
||||
action object
|
||||
ok <- get (getStatus object)
|
||||
unless ok $ do
|
||||
infoLog <- get (getInfoLog object)
|
||||
fail (message ++ " log: " ++ infoLog)
|
||||
action object
|
||||
ok <- get (getStatus object)
|
||||
unless ok $ do
|
||||
infoLog <- get (getInfoLog object)
|
||||
fail (message ++ " log: " ++ infoLog)
|
||||
|
||||
@@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE NamedFieldPuns, OverloadedRecordDot #-}
|
||||
|
||||
{- |
|
||||
- Module : Game.Internal.Types
|
||||
- Description :
|
||||
@@ -9,116 +10,83 @@
|
||||
-}
|
||||
module Game.Internal.Types
|
||||
( Object(..)
|
||||
|
||||
, toGLMatrix
|
||||
|
||||
, Model ( camera
|
||||
, objects
|
||||
, cursorDeltaPos
|
||||
, cursorPos
|
||||
, program
|
||||
, keys
|
||||
, wprop
|
||||
)
|
||||
, Model(camera, objects, cursorDeltaPos, cursorPos, program, keys, wprop)
|
||||
, mkModel
|
||||
|
||||
, Camera ( camPos
|
||||
, camPitch
|
||||
, camYaw
|
||||
, camReference
|
||||
, mouseSensitivity
|
||||
, camVel
|
||||
, strafeStrength
|
||||
, jumpStrength
|
||||
, hasJumped
|
||||
, airTime
|
||||
)
|
||||
, Camera(camPos, camPitch, camYaw, camReference, mouseSensitivity, camVel, strafeStrength, jumpStrength, hasJumped, airTime)
|
||||
, mkCamera
|
||||
|
||||
, WorldProperties (g, friction, up)
|
||||
, WorldProperties(g, friction, up)
|
||||
, mkWorldProperties
|
||||
|
||||
) where
|
||||
|
||||
import qualified Graphics.UI.GLFW as GLFW
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
import qualified Graphics.UI.GLFW as GLFW
|
||||
|
||||
import qualified Linear as L
|
||||
import Linear (V3, V3(..), V4(..))
|
||||
import Linear (V3, V3(..), V4(..))
|
||||
|
||||
-- | represents a single draw call
|
||||
data Object =
|
||||
Object
|
||||
{ vao :: GL.VertexArrayObject -- ^ vao of vertex buffer
|
||||
, numIndicies :: GL.NumArrayIndices -- ^ number of vertices
|
||||
, numComponents :: GL.NumComponents -- ^ dimensionallity; vec3, vec4, etc.
|
||||
, primitiveMode :: GL.PrimitiveMode -- ^ primitive mode to be drawn with
|
||||
}
|
||||
deriving Show
|
||||
data Object = Object
|
||||
{ vao :: GL.VertexArrayObject -- ^ vao of vertex buffer
|
||||
, numIndicies :: GL.NumArrayIndices -- ^ number of vertices
|
||||
, numComponents :: GL.NumComponents -- ^ dimensionallity; vec3, vec4, etc.
|
||||
, primitiveMode :: GL.PrimitiveMode -- ^ primitive mode to be drawn with
|
||||
} deriving (Show)
|
||||
|
||||
-- | converts M44 to a 16array for OpenGL
|
||||
toGLMatrix :: L.M44 GL.GLfloat -> [GL.GLfloat]
|
||||
toGLMatrix
|
||||
(V4
|
||||
(V4 c00 c01 c02 c03)
|
||||
(V4 c10 c11 c12 c13)
|
||||
(V4 c20 c21 c22 c23)
|
||||
(V4 c30 c31 c32 c33)) =
|
||||
[ c00, c01, c02, c03
|
||||
, c10, c11, c12, c13
|
||||
, c20, c21, c22, c23
|
||||
, c30, c31, c32, c33
|
||||
toGLMatrix (V4 (V4 c00 c01 c02 c03) (V4 c10 c11 c12 c13) (V4 c20 c21 c22 c23) (V4 c30 c31 c32 c33)) =
|
||||
[ c00
|
||||
, c01
|
||||
, c02
|
||||
, c03
|
||||
, c10
|
||||
, c11
|
||||
, c12
|
||||
, c13
|
||||
, c20
|
||||
, c21
|
||||
, c22
|
||||
, c23
|
||||
, c30
|
||||
, c31
|
||||
, c32
|
||||
, c33
|
||||
]
|
||||
|
||||
-- | gamestate
|
||||
data Model =
|
||||
Model
|
||||
{ camera :: Camera
|
||||
, cursorDeltaPos :: (Double, Double) -- ^ frame-on-frame delta mouse position
|
||||
, cursorPos :: (Double, Double) -- ^ current mouse position
|
||||
, keys :: [GLFW.Key] -- ^ currently pressed keys
|
||||
, objects :: [Object] -- ^ draw calls
|
||||
, program :: GL.Program -- ^ shader program
|
||||
, wprop :: WorldProperties
|
||||
}
|
||||
deriving Show
|
||||
data Model = Model
|
||||
{ camera :: Camera
|
||||
, cursorDeltaPos :: (Double, Double) -- ^ frame-on-frame delta mouse position
|
||||
, cursorPos :: (Double, Double) -- ^ current mouse position
|
||||
, keys :: [GLFW.Key] -- ^ currently pressed keys
|
||||
, objects :: [Object] -- ^ draw calls
|
||||
, program :: GL.Program -- ^ shader program
|
||||
, wprop :: WorldProperties
|
||||
} deriving (Show)
|
||||
|
||||
-- | smart constructor for Model
|
||||
mkModel
|
||||
:: Camera
|
||||
-> [Object]
|
||||
-> GL.Program
|
||||
-> WorldProperties
|
||||
-> Model
|
||||
mkModel :: Camera -> [Object] -> GL.Program -> WorldProperties -> Model
|
||||
mkModel camera objects program wprop =
|
||||
Model
|
||||
camera
|
||||
(0,0)
|
||||
(0,0)
|
||||
[]
|
||||
objects
|
||||
program
|
||||
wprop
|
||||
Model camera (0, 0) (0, 0) [] objects program wprop
|
||||
|
||||
-- | camera
|
||||
data Camera =
|
||||
Camera
|
||||
{ camPos :: V3 Float -- ^ position in world space
|
||||
, camPitch :: Float -- ^ pitch in radians, up positive
|
||||
, camYaw :: Float -- ^ yaw in radians, right positive
|
||||
, camReference :: V3 Float -- ^ reference direction; orientation applied to
|
||||
, camVel :: V3 Float -- ^ velocity in world space
|
||||
, mouseSensitivity :: Float -- ^ scale factor for mouse movement
|
||||
, strafeStrength :: Float -- ^ scale factor for strafe
|
||||
, jumpStrength :: Float -- ^ scale factor for jump initial velocity
|
||||
, hasJumped :: Bool -- ^ whether the camera still has jumping state
|
||||
, airTime :: Float -- ^ time since jumping state entered in seconds
|
||||
}
|
||||
deriving Show
|
||||
data Camera = Camera
|
||||
{ camPos :: V3 Float -- ^ position in world space
|
||||
, camPitch :: Float -- ^ pitch in radians, up positive
|
||||
, camYaw :: Float -- ^ yaw in radians, right positive
|
||||
, camReference :: V3 Float -- ^ reference direction; orientation applied to
|
||||
, camVel :: V3 Float -- ^ velocity in world space
|
||||
, mouseSensitivity :: Float -- ^ scale factor for mouse movement
|
||||
, strafeStrength :: Float -- ^ scale factor for strafe
|
||||
, jumpStrength :: Float -- ^ scale factor for jump initial velocity
|
||||
, hasJumped :: Bool -- ^ whether the camera still has jumping state
|
||||
, airTime :: Float -- ^ time since jumping state entered in seconds
|
||||
} deriving (Show)
|
||||
|
||||
-- | smart constructor for Camera
|
||||
mkCamera
|
||||
:: V3 Float
|
||||
mkCamera ::
|
||||
V3 Float
|
||||
-> Float
|
||||
-> Float
|
||||
-> V3 Float
|
||||
@@ -127,15 +95,7 @@ mkCamera
|
||||
-> Float
|
||||
-> Float
|
||||
-> Camera
|
||||
mkCamera
|
||||
camPos
|
||||
camPitch
|
||||
camYaw
|
||||
camReference
|
||||
camVel
|
||||
mouseSensitivity
|
||||
strafeStrength
|
||||
jumpStrength =
|
||||
mkCamera camPos camPitch camYaw camReference camVel mouseSensitivity strafeStrength jumpStrength =
|
||||
Camera
|
||||
camPos
|
||||
camPitch
|
||||
@@ -149,15 +109,12 @@ mkCamera
|
||||
0
|
||||
|
||||
-- | physical properties of the world
|
||||
data WorldProperties =
|
||||
WorldProperties
|
||||
{ g :: Float -- ^ gravity `g`
|
||||
, friction :: Float -- ^ scale factor for floor friction
|
||||
, up :: V3 Float -- ^ global up vector
|
||||
}
|
||||
deriving Show
|
||||
data WorldProperties = WorldProperties
|
||||
{ g :: Float -- ^ gravity `g`
|
||||
, friction :: Float -- ^ scale factor for floor friction
|
||||
, up :: V3 Float -- ^ global up vector
|
||||
} deriving (Show)
|
||||
|
||||
-- | smart constructor for WorldProperties
|
||||
mkWorldProperties :: Float -> Float -> V3 Float-> WorldProperties
|
||||
mkWorldProperties g friction up =
|
||||
WorldProperties g friction (L.normalize up)
|
||||
mkWorldProperties :: Float -> Float -> V3 Float -> WorldProperties
|
||||
mkWorldProperties g friction up = WorldProperties g friction (L.normalize up)
|
||||
|
||||
327
src/Main.hs
327
src/Main.hs
@@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
|
||||
|
||||
{- |
|
||||
- Module : Game
|
||||
- Description : runs game
|
||||
@@ -7,177 +8,243 @@
|
||||
- Maintainer : Matrix @Andromeda:tchncs.de
|
||||
- Stability : Experimental
|
||||
-}
|
||||
module Main (main) where
|
||||
module Main
|
||||
( main
|
||||
) where
|
||||
|
||||
import Game.Internal.Types
|
||||
import Game.Internal
|
||||
import Game.Internal.Types
|
||||
|
||||
import Control.Lens ((^.))
|
||||
import Data.IORef (newIORef)
|
||||
import GHC.Float (double2Float)
|
||||
import Control.Lens ((^.))
|
||||
import Data.IORef (newIORef)
|
||||
import GHC.Float (double2Float)
|
||||
|
||||
import qualified Graphics.UI.GLFW as GLFW
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
import Graphics.Rendering.OpenGL as GL (($=))
|
||||
import Graphics.Rendering.OpenGL (($=))
|
||||
import qualified Graphics.UI.GLFW as GLFW
|
||||
|
||||
import qualified Linear as L
|
||||
import Linear ( V3(..), _y )
|
||||
import Linear (V3(..), _y)
|
||||
|
||||
-- | Main function runs game
|
||||
main :: IO ()
|
||||
main = do
|
||||
_ <- GLFW.init
|
||||
GLFW.defaultWindowHints
|
||||
|
||||
-- OpenGL core >=3.3
|
||||
GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor 3
|
||||
GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 3
|
||||
GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
|
||||
|
||||
-- MSAA
|
||||
GLFW.windowHint $ GLFW.WindowHint'Samples $ Just 8
|
||||
|
||||
-- create window
|
||||
monitor <- GLFW.getPrimaryMonitor
|
||||
Just window <- GLFW.createWindow 256 256 "hs-game" monitor Nothing
|
||||
GLFW.makeContextCurrent $ Just window
|
||||
|
||||
-- add callbacks
|
||||
GLFW.setWindowCloseCallback window $ Just shutdownWindow
|
||||
GLFW.setWindowSizeCallback window $ Just resizeWindow
|
||||
GLFW.setKeyCallback window $ Just (keyPressed Nothing)
|
||||
GLFW.setCursorInputMode window GLFW.CursorInputMode'Hidden
|
||||
GLFW.setCursorPosCallback window $ Just (cursorPosHandler Nothing)
|
||||
|
||||
(objects, program) <- initResources testVertices
|
||||
|
||||
(objects, program) <- initResources
|
||||
[ map (+ V3 a 0 0) cube | a <- take 100 [0,2..]]
|
||||
-- init model
|
||||
let
|
||||
model =
|
||||
mkModel
|
||||
(mkCamera
|
||||
(V3 0 0 3) -- camPos
|
||||
0 -- pitch
|
||||
0 -- yaw
|
||||
(V3 0 0 (-1)) -- reference vector
|
||||
(V3 0 0 0) -- velocity
|
||||
2 -- mouse sensitivity
|
||||
16 -- strafe strength
|
||||
12 -- jump strength
|
||||
)
|
||||
objects
|
||||
program
|
||||
(mkWorldProperties
|
||||
2
|
||||
0.16
|
||||
(V3 0 1 0)
|
||||
)
|
||||
let model =
|
||||
mkModel
|
||||
(mkCamera
|
||||
(V3 0 0 3) -- camPos
|
||||
0 -- pitch
|
||||
0 -- yaw
|
||||
(V3 0 0 (-1)) -- reference vector
|
||||
(V3 0 0 0) -- velocity
|
||||
2 -- mouse sensitivity
|
||||
16 -- strafe strength
|
||||
12 -- jump strength
|
||||
)
|
||||
objects
|
||||
program
|
||||
(mkWorldProperties 2 0.16 (V3 0 1 0))
|
||||
modelRef <- newIORef model
|
||||
|
||||
-- add callbacks with io ref to model
|
||||
GLFW.setKeyCallback window $ Just $ keyPressed $ Just modelRef
|
||||
GLFW.setCursorPosCallback window $ Just $ cursorPosHandler $ Just modelRef
|
||||
|
||||
loop window 0 update view modelRef
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Arrays
|
||||
--------------------------------------------------------------------------------
|
||||
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
|
||||
testVertices :: [V3 GL.GLfloat]
|
||||
testVertices =
|
||||
[ V3 (-0.5) (-0.5) 0
|
||||
, V3 0.5 (-0.5) 0
|
||||
, V3 (-0.5) 0.5 0
|
||||
, V3 0.5 0.5 0
|
||||
m = (0 - p)
|
||||
p = 0.5
|
||||
|
||||
-- TODO optimise cube
|
||||
-- | cube vertices
|
||||
cube :: [V3 GL.GLfloat]
|
||||
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
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | update function
|
||||
update :: Float -> Model -> Model
|
||||
update dt model =
|
||||
updateVelocity
|
||||
dt
|
||||
$ updateAcceleration
|
||||
dt
|
||||
$ updateCameraAngle
|
||||
dt
|
||||
model
|
||||
updateVelocity dt
|
||||
$ updateAcceleration dt
|
||||
$ updateSpeed dt
|
||||
$ updateCameraAngle dt model
|
||||
|
||||
updateSpeed :: Float -> Model -> Model
|
||||
updateSpeed dt model =
|
||||
if elem GLFW.Key'T model.keys then
|
||||
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 dt model =
|
||||
let
|
||||
zp = if elem GLFW.Key'S model.keys then 1 else 0
|
||||
zn = if elem GLFW.Key'W model.keys then 1 else 0
|
||||
xp = if elem GLFW.Key'D model.keys then 1 else 0
|
||||
xn = if elem GLFW.Key'A model.keys then 1 else 0
|
||||
x = xp - xn
|
||||
z = zp - zn
|
||||
friction = V3 (1 - model.wprop.friction) 1 (1 - model.wprop.friction)
|
||||
movement = L.normalize (V3 x 0 z) L.^* (dt * model.camera.strafeStrength)
|
||||
movement' = L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) movement
|
||||
jump =
|
||||
if model.camera.hasJumped then
|
||||
V3 0 (0 - model.wprop.g * model.camera.airTime) 0
|
||||
else
|
||||
V3 0 0 0
|
||||
camVel' = friction * (model.camera.camVel + movement' + jump)
|
||||
aboveGround = (model.camera.camPos + dt L.*^ camVel') ^. _y > 0
|
||||
in
|
||||
if
|
||||
(elem GLFW.Key'Space model.keys)
|
||||
&& (model.camera.hasJumped == False)
|
||||
then
|
||||
updateAcceleration dt $ model { camera = model.camera { airTime = dt, camVel = model.camera.camVel + (V3 0 model.camera.jumpStrength 0), hasJumped = True } }
|
||||
else
|
||||
if aboveGround then
|
||||
model
|
||||
{ camera = model.camera
|
||||
{ airTime = model.camera.airTime + dt
|
||||
, camVel = camVel'
|
||||
, hasJumped = aboveGround
|
||||
}
|
||||
}
|
||||
else
|
||||
model
|
||||
{ camera = model.camera
|
||||
{ airTime = 0
|
||||
, camVel = camVel' * (V3 1 0 1)
|
||||
, camPos = model.camera.camPos * (V3 1 0 1)
|
||||
, hasJumped = aboveGround
|
||||
}
|
||||
}
|
||||
let zp =
|
||||
if elem GLFW.Key'S model.keys
|
||||
then 1
|
||||
else 0
|
||||
zn =
|
||||
if elem GLFW.Key'W model.keys
|
||||
then 1
|
||||
else 0
|
||||
xp =
|
||||
if elem GLFW.Key'D model.keys
|
||||
then 1
|
||||
else 0
|
||||
xn =
|
||||
if elem GLFW.Key'A model.keys
|
||||
then 1
|
||||
else 0
|
||||
x = xp - xn
|
||||
z = zp - zn
|
||||
friction = V3 (1 - model.wprop.friction) 1 (1 - model.wprop.friction)
|
||||
movement = L.normalize (V3 x 0 z) L.^* (dt * model.camera.strafeStrength)
|
||||
movement' =
|
||||
L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) movement
|
||||
jump =
|
||||
if model.camera.hasJumped
|
||||
then V3 0 (0 - model.wprop.g * model.camera.airTime) 0
|
||||
else V3 0 0 0
|
||||
camVel' = friction * (model.camera.camVel + movement' + jump)
|
||||
aboveGround = (model.camera.camPos + dt L.*^ camVel') ^. _y > 0
|
||||
in if (elem GLFW.Key'Space model.keys) && (model.camera.hasJumped == False)
|
||||
then updateAcceleration dt
|
||||
$ model
|
||||
{ camera =
|
||||
model.camera
|
||||
{ airTime = dt
|
||||
, camVel =
|
||||
model.camera.camVel
|
||||
+ (V3 0 model.camera.jumpStrength 0)
|
||||
, hasJumped = True
|
||||
}
|
||||
}
|
||||
else if aboveGround
|
||||
then model
|
||||
{ camera =
|
||||
model.camera
|
||||
{ airTime = model.camera.airTime + dt
|
||||
, camVel = camVel'
|
||||
, hasJumped = aboveGround
|
||||
}
|
||||
}
|
||||
else model
|
||||
{ camera =
|
||||
model.camera
|
||||
{ airTime = 0
|
||||
, camVel = camVel' * (V3 1 0 1)
|
||||
, camPos = model.camera.camPos * (V3 1 0 1)
|
||||
, hasJumped = aboveGround
|
||||
}
|
||||
}
|
||||
|
||||
updateVelocity :: Float -> Model -> Model
|
||||
updateVelocity dt model =
|
||||
model
|
||||
{ camera = model.camera
|
||||
{ camPos = model.camera.camPos + dt L.*^ model.camera.camVel
|
||||
}
|
||||
{ camera =
|
||||
model.camera
|
||||
{camPos = model.camera.camPos + dt L.*^ model.camera.camVel}
|
||||
}
|
||||
|
||||
updateCameraAngle :: Float -> Model -> Model
|
||||
updateCameraAngle dt model =
|
||||
let
|
||||
scaleFactor = model.camera.mouseSensitivity * dt
|
||||
newPitch = model.camera.camPitch -
|
||||
scaleFactor * (double2Float $ snd model.cursorDeltaPos) -- mouse sensitivity, update pitch
|
||||
newPitch' = if newPitch > 1.56 then 1.56 else newPitch
|
||||
newPitch'' = if newPitch' < (-1.56) then (-1.56) else newPitch'
|
||||
newYaw = model.camera.camYaw +
|
||||
scaleFactor * (double2Float $ fst model.cursorDeltaPos)
|
||||
in
|
||||
model
|
||||
{ cursorDeltaPos = (0, 0)
|
||||
, camera = model.camera
|
||||
{ camPitch = newPitch''
|
||||
, camYaw = newYaw
|
||||
}
|
||||
}
|
||||
let scaleFactor = model.camera.mouseSensitivity * dt
|
||||
newPitch =
|
||||
model.camera.camPitch
|
||||
- scaleFactor * (double2Float $ snd model.cursorDeltaPos) -- mouse sensitivity, update pitch
|
||||
newPitch' =
|
||||
if newPitch > 1.56
|
||||
then 1.56
|
||||
else newPitch
|
||||
newPitch'' =
|
||||
if newPitch' < (-1.56)
|
||||
then (-1.56)
|
||||
else newPitch'
|
||||
newYaw =
|
||||
model.camera.camYaw
|
||||
+ scaleFactor * (double2Float $ fst model.cursorDeltaPos)
|
||||
in model
|
||||
{ cursorDeltaPos = (0, 0)
|
||||
, camera = model.camera {camPitch = newPitch'', camYaw = newYaw}
|
||||
}
|
||||
|
||||
-- | views the model
|
||||
view :: GLFW.Window -> Model -> IO ()
|
||||
@@ -185,39 +252,35 @@ view window model = do
|
||||
-- fit viewport to window
|
||||
(w, h) <- GLFW.getFramebufferSize window
|
||||
GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
|
||||
|
||||
-- clear screen
|
||||
GL.clearColor $= GL.Color4 1 0 1 1
|
||||
GL.clear [GL.ColorBuffer, GL.DepthBuffer]
|
||||
|
||||
-- depth
|
||||
GL.depthFunc $= Just GL.Less
|
||||
|
||||
-- apply transforms
|
||||
let
|
||||
pitch = model.camera.camPitch
|
||||
yaw = model.camera.camYaw
|
||||
forward = V3 (cos pitch * sin yaw) (sin pitch) (cos pitch * cos yaw)
|
||||
viewMatrix =
|
||||
L.lookAt
|
||||
model.camera.camPos
|
||||
(model.camera.camPos - forward)
|
||||
model.wprop.up
|
||||
projectionMatrix = L.perspective 1.5 (fromIntegral w / fromIntegral h) 0.01 10000
|
||||
|
||||
viewGLMatrix <- GL.newMatrix GL.RowMajor $ toGLMatrix viewMatrix :: IO (GL.GLmatrix GL.GLfloat)
|
||||
let pitch = model.camera.camPitch
|
||||
yaw = model.camera.camYaw
|
||||
forward = V3 (cos pitch * sin yaw) (sin pitch) (cos pitch * cos yaw)
|
||||
viewMatrix =
|
||||
L.lookAt
|
||||
model.camera.camPos
|
||||
(model.camera.camPos - forward)
|
||||
model.wprop.up
|
||||
projectionMatrix =
|
||||
L.perspective 1.2 (fromIntegral w / fromIntegral h) 0.01 1000
|
||||
viewGLMatrix <-
|
||||
GL.newMatrix GL.RowMajor $ toGLMatrix viewMatrix :: IO
|
||||
(GL.GLmatrix GL.GLfloat)
|
||||
viewLocation <- GL.get $ GL.uniformLocation model.program "u_view"
|
||||
GL.uniform viewLocation $= viewGLMatrix
|
||||
|
||||
projectionGLMatrix <- GL.newMatrix GL.RowMajor $ toGLMatrix projectionMatrix :: IO (GL.GLmatrix GL.GLfloat)
|
||||
projectionGLMatrix <-
|
||||
GL.newMatrix GL.RowMajor $ toGLMatrix projectionMatrix :: IO
|
||||
(GL.GLmatrix GL.GLfloat)
|
||||
projectionLocation <- GL.get $ GL.uniformLocation model.program "u_projection"
|
||||
GL.uniform projectionLocation $= projectionGLMatrix
|
||||
|
||||
-- draw objects; returns IO []
|
||||
_ <- drawObjects model.objects
|
||||
|
||||
-- swap to current buffer
|
||||
GLFW.swapBuffers window
|
||||
|
||||
-- check for interrupts
|
||||
GLFW.pollEvents
|
||||
|
||||
Reference in New Issue
Block a user