{-# 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