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

use hindent

Browse Source
This commit is contained in:
mtgmonkey
2025-12-13 19:39:43 +01:00
parent e9b4e2d34a
commit a13a8610dc
4 changed files with 289 additions and 375 deletions
Download Patch File Download Diff File Expand all files Collapse all files

164
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,91 +19,88 @@ 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
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Monad (when) import Control.Monad (when)
import Data.IORef (IORef, modifyIORef', readIORef) 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 array = do
-- create objects -- create objects
testObject0 <- createObject (map (+(V3 (-1) (-1) (-1))) array) 3 GL.TriangleStrip testObject0 <-
testObject1 <- createObject (map (+(V3 (1) (1) (1))) array) 3 GL.TriangleStrip 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 testObject2 <- createObject array 3 GL.TriangleStrip
let objects = [testObject0, testObject1, testObject2] let objects = [testObject0, testObject1, testObject2]
-- load shaders -- load shaders
program <- loadShaders program <-
[ ShaderInfo GL.VertexShader (StringSource vertShader) loadShaders
, ShaderInfo GL.FragmentShader (StringSource fragShader) [ ShaderInfo GL.VertexShader (StringSource vertShader)
] , ShaderInfo GL.FragmentShader (StringSource fragShader)
]
GL.currentProgram $= Just program GL.currentProgram $= Just program
return (objects, program) return (objects, program)
-- 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 * 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 +109,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 GL.bufferData GL.ArrayBuffer $= (sizeOfArray array, ptr, GL.StaticDraw)
$ \ptr ->
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 +130,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,62 +148,50 @@ 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)
-- | 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 +199,6 @@ drawObjects
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- interrupts -- interrupts
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | shuts down GLFW -- | shuts down GLFW
shutdownWindow :: GLFW.WindowCloseCallback shutdownWindow :: GLFW.WindowCloseCallback
shutdownWindow window = do shutdownWindow window = do

75
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,49 +40,47 @@ 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
loadCompileAttach program infos loadCompileAttach program infos
linkAndCheck program linkAndCheck program
return program return program
linkAndCheck :: Program -> IO () linkAndCheck :: Program -> IO ()
linkAndCheck = checked linkProgram linkStatus programInfoLog "link" 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
compileAndCheck shader compileAndCheck shader
attachShader program shader attachShader program shader
loadCompileAttach program infos loadCompileAttach program infos
compileAndCheck :: Shader -> IO () compileAndCheck :: Shader -> IO ()
compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile" compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile"
checked :: (t -> IO ()) checked ::
-> (t -> GettableStateVar Bool) (t -> IO ())
-> (t -> GettableStateVar String) -> (t -> GettableStateVar Bool)
-> String -> (t -> GettableStateVar String)
-> t -> String
-> IO () -> t
-> 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)
unless ok $ do unless ok $ do
infoLog <- get (getInfoLog object) infoLog <- get (getInfoLog object)
fail (message ++ " log: " ++ infoLog) fail (message ++ " log: " ++ infoLog)

167
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,116 +10,83 @@
-} -}
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 , keys :: [GLFW.Key] -- ^ currently pressed keys
, keys :: [GLFW.Key] -- ^ currently pressed keys , 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 , camReference :: V3 Float -- ^ reference direction; orientation applied to
, camReference :: V3 Float -- ^ reference direction; orientation applied to , camVel :: V3 Float -- ^ velocity in world space
, camVel :: V3 Float -- ^ velocity in world space , mouseSensitivity :: Float -- ^ scale factor for mouse movement
, mouseSensitivity :: Float -- ^ scale factor for mouse movement , strafeStrength :: Float -- ^ scale factor for strafe
, strafeStrength :: Float -- ^ scale factor for strafe , 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)

254
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,177 +8,174 @@
- 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 testVertices (objects, program) <- initResources testVertices
-- init model -- init model
let let model =
model = mkModel
mkModel (mkCamera
(mkCamera (V3 0 0 3) -- 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 (V3 0 0 0) -- velocity
(V3 0 0 0) -- velocity 2 -- mouse sensitivity
2 -- mouse sensitivity 16 -- strafe strength
16 -- strafe strength 12 -- jump strength
12 -- jump strength )
) objects
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
-- 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
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | centered unit square -- | centered unit square
testVertices :: [V3 GL.GLfloat] testVertices :: [V3 GL.GLfloat]
testVertices = 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, V3 0.5 0.5 0]
, V3 0.5 (-0.5) 0
, V3 (-0.5) 0.5 0
, V3 0.5 0.5 0
]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- 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 $ updateAcceleration dt $ updateCameraAngle dt model
dt
$ updateAcceleration
dt
$ updateCameraAngle
dt
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 =
x = xp - xn if elem GLFW.Key'W model.keys
z = zp - zn then 1
friction = V3 (1 - model.wprop.friction) 1 (1 - model.wprop.friction) else 0
movement = L.normalize (V3 x 0 z) L.^* (dt * model.camera.strafeStrength) xp =
movement' = L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) movement if elem GLFW.Key'D model.keys
jump = then 1
if model.camera.hasJumped then else 0
V3 0 (0 - model.wprop.g * model.camera.airTime) 0 xn =
else if elem GLFW.Key'A model.keys
V3 0 0 0 then 1
camVel' = friction * (model.camera.camVel + movement' + jump) else 0
aboveGround = (model.camera.camPos + dt L.*^ camVel') ^. _y > 0 x = xp - xn
in z = zp - zn
if friction = V3 (1 - model.wprop.friction) 1 (1 - model.wprop.friction)
(elem GLFW.Key'Space model.keys) movement = L.normalize (V3 x 0 z) L.^* (dt * model.camera.strafeStrength)
&& (model.camera.hasJumped == False) movement' =
then L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) movement
updateAcceleration dt $ model { camera = model.camera { airTime = dt, camVel = model.camera.camVel + (V3 0 model.camera.jumpStrength 0), hasJumped = True } } jump =
else if model.camera.hasJumped
if aboveGround then then V3 0 (0 - model.wprop.g * model.camera.airTime) 0
model else V3 0 0 0
{ camera = model.camera camVel' = friction * (model.camera.camVel + movement' + jump)
{ airTime = model.camera.airTime + dt aboveGround = (model.camera.camPos + dt L.*^ camVel') ^. _y > 0
, camVel = camVel' in if (elem GLFW.Key'Space model.keys) && (model.camera.hasJumped == False)
, hasJumped = aboveGround then updateAcceleration dt
} $ model
} { camera =
else model.camera
model { airTime = dt
{ camera = model.camera , camVel =
{ airTime = 0 model.camera.camVel
, camVel = camVel' * (V3 1 0 1) + (V3 0 model.camera.jumpStrength 0)
, camPos = model.camera.camPos * (V3 1 0 1) , hasJumped = True
, hasJumped = aboveGround }
} }
} 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 :: 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)
{ cursorDeltaPos = (0, 0) then (-1.56)
, camera = model.camera else newPitch'
{ camPitch = newPitch'' newYaw =
, camYaw = newYaw model.camera.camYaw
} + scaleFactor * (double2Float $ fst model.cursorDeltaPos)
} in model
{ cursorDeltaPos = (0, 0)
, camera = model.camera {camPitch = newPitch'', camYaw = newYaw}
}
-- | views the model -- | views the model
view :: GLFW.Window -> Model -> IO () view :: GLFW.Window -> Model -> IO ()
@@ -185,39 +183,35 @@ 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 = L.lookAt
L.lookAt model.camera.camPos
model.camera.camPos (model.camera.camPos - forward)
(model.camera.camPos - forward) model.wprop.up
model.wprop.up projectionMatrix =
projectionMatrix = L.perspective 1.5 (fromIntegral w / fromIntegral h) 0.01 10000 L.perspective 1.5 (fromIntegral w / fromIntegral h) 0.01 10000
viewGLMatrix <-
viewGLMatrix <- GL.newMatrix GL.RowMajor $ toGLMatrix viewMatrix :: IO (GL.GLmatrix GL.GLfloat) 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