summaryrefslogtreecommitdiff
path: root/src/Game/Main.hs
diff options
context:
space:
mode:
authormtgmonkey <mtgmonkey@nixos>2025-12-08 13:40:11 +0100
committermtgmonkey <mtgmonkey@nixos>2025-12-08 13:40:11 +0100
commit20ecde081bf47c7790e93dd2282d5e666e01b9ce (patch)
treee825e9091bbf3e169b9a86d4f545175cb99b3055 /src/Game/Main.hs
parent852244a49159097a83fc99edcdad26f84f999098 (diff)
release v0.2.0
Diffstat (limited to 'src/Game/Main.hs')
-rw-r--r--src/Game/Main.hs243
1 files changed, 0 insertions, 243 deletions
diff --git a/src/Game/Main.hs b/src/Game/Main.hs
deleted file mode 100644
index 7aeb2a5..0000000
--- a/src/Game/Main.hs
+++ /dev/null
@@ -1,243 +0,0 @@
-{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
-{- |
- - Module : Game
- - Description : runs game
- - Copyright : Andromeda 2025
- - License : WTFPL
- - Maintainer : Matrix @Andromeda:tchncs.de
- - Stability : Experimental
- -}
-module Game (main) where
-
-import Game.Internal.LoadShaders
-import Game.Internal.Types
-import Game.Internal
-
-import Control.Concurrent (threadDelay)
-import Control.Lens ((^.), (+~), (&), (%~))
-import Control.Monad (when)
-import Data.Fixed (mod')
-import Data.IORef (atomicModifyIORef', IORef, modifyIORef', newIORef, readIORef, writeIORef)
-import Data.List (delete)
-import Foreign.Marshal.Array (withArray)
-import Foreign.Ptr (nullPtr, plusPtr)
-import Foreign.Storable (sizeOf, Storable)
-import GHC.Float (double2Float, int2Double)
-
-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(..)
- , _x
- , _y
- , _z
- )
-
--- | 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 window 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
- yaw = (L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) model.camera.camReference)
- front = L.normalize $ (V3 1 0 1) * (L.rotate (L.axisAngle (L.cross model.wprop.up yaw) model.camera.camPitch) yaw)
- 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
- }
- }
-
--- | 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 }
-
--- | 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
- drawObjects model.objects
-
- -- swap to current buffer
- GLFW.swapBuffers window
-
- -- check for interrupts
- GLFW.pollEvents