325 lines
9.1 KiB
Haskell
325 lines
9.1 KiB
Haskell
{-# LANGUAGE DisambiguateRecordFields #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedRecordDot #-}
|
|
|
|
-- |
|
|
-- - Module : Game
|
|
-- - Description : runs game
|
|
-- - Copyright : 2025 Andromeda
|
|
-- - License : BSD 3-clause
|
|
-- - Maintainer : Matrix @Andromeda:tchncs.de
|
|
-- - Stability : Experimental
|
|
module Main
|
|
( main,
|
|
)
|
|
where
|
|
|
|
import Control.Lens ((^.))
|
|
import Data.IORef (newIORef)
|
|
import GHC.Float (double2Float)
|
|
import Game.Internal
|
|
import Game.Internal.Types
|
|
import Graphics.Rendering.OpenGL (($=))
|
|
import qualified Graphics.Rendering.OpenGL as GL
|
|
import qualified Graphics.UI.GLFW as GLFW
|
|
import Linear (V3 (..), V4 (..), _y)
|
|
import qualified Linear as L
|
|
|
|
-- | 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 $
|
|
-- [map (v3tov4 0) $ map (+ V3 a 0 0) cube | a <- take 100 [0, 2 ..]]
|
|
[hCube]
|
|
|
|
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
|
|
]
|
|
|
|
m = (0 - p)
|
|
|
|
p = 0.5
|
|
|
|
v3tov4 :: GL.GLfloat -> V3 GL.GLfloat -> V4 GL.GLfloat
|
|
v3tov4 w (V3 x y z) = V4 x y z w
|
|
|
|
v3tov4' :: GL.GLfloat -> V3 GL.GLfloat -> V4 GL.GLfloat
|
|
v3tov4' w (V3 x y z) = V4 x y w z
|
|
|
|
v3tov4'' :: GL.GLfloat -> V3 GL.GLfloat -> V4 GL.GLfloat
|
|
v3tov4'' w (V3 x y z) = V4 x w y z
|
|
|
|
v3tov4''' :: GL.GLfloat -> V3 GL.GLfloat -> V4 GL.GLfloat
|
|
v3tov4''' w (V3 x y z) = V4 w x y z
|
|
|
|
-- | TODO optimise cube
|
|
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
|
|
]
|
|
|
|
-- | TODO optimise hCube
|
|
hCube :: [V4 GL.GLfloat]
|
|
hCube =
|
|
(map (v3tov4 m) cube)
|
|
++ (map (v3tov4 p) cube)
|
|
++ (map (v3tov4' m) cube)
|
|
++ (map (v3tov4' p) cube)
|
|
++ (map (v3tov4'' m) cube)
|
|
++ (map (v3tov4'' p) cube)
|
|
++ (map (v3tov4''' m) cube)
|
|
++ (map (v3tov4''' p) cube)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Elm-like data structures
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | update function
|
|
update :: Float -> Model -> Model
|
|
update 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
|
|
}
|
|
}
|
|
|
|
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.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)
|
|
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
|