release v0.2.0
This commit is contained in:
mtgmonkey
223
src/Game.hs
Normal file
223
src/Game.hs
Normal file
@@ -0,0 +1,223 @@
|
||||
{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
|
||||
{- |
|
||||
- Module : Game
|
||||
- Description : runs game
|
||||
- Copyright : 2025 Andromeda
|
||||
- License : BSD 3-clause
|
||||
- Maintainer : Matrix @Andromeda:tchncs.de
|
||||
- Stability : Experimental
|
||||
-}
|
||||
module Game (main) where
|
||||
|
||||
import Game.Internal.Types
|
||||
import Game.Internal
|
||||
|
||||
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 qualified Linear as L
|
||||
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
|
||||
|
||||
-- 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)
|
||||
)
|
||||
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
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | 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
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Elm-like data structures
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | update function
|
||||
update :: Float -> Model -> Model
|
||||
update dt model =
|
||||
updateVelocity
|
||||
dt
|
||||
$ updateAcceleration
|
||||
dt
|
||||
$ updateCameraAngle
|
||||
dt
|
||||
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
|
||||
}
|
||||
}
|
||||
|
||||
updateVelocity :: Float -> Model -> Model
|
||||
updateVelocity dt model =
|
||||
model
|
||||
{ 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
|
||||
}
|
||||
}
|
||||
|
||||
-- | views the model
|
||||
view :: GLFW.Window -> Model -> IO ()
|
||||
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)
|
||||
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)
|
||||
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