diff options
Diffstat (limited to 'src/Game.hs')
| -rw-r--r-- | src/Game.hs | 243 |
1 files changed, 243 insertions, 0 deletions
diff --git a/src/Game.hs b/src/Game.hs new file mode 100644 index 0000000..7aeb2a5 --- /dev/null +++ b/src/Game.hs @@ -0,0 +1,243 @@ +{-# 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 |