{-# 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.LoadShaders import Game.Types 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) 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 -- 4x MSAA GLFW.windowHint $ GLFW.WindowHint'Samples $ Just 4 -- 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.setCursorPosCallback window $ Just (cursorPosHandler Nothing) (objects, program) <- initResources window -- 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 0.08 -- 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 (update 0) 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 ] -------------------------------------------------------------------------------- -- Shader creation and object initialisation -------------------------------------------------------------------------------- -- | loads models, shaders initResources :: GLFW.Window -> IO ([Object], GL.Program) initResources window = do -- create objects testObject0 <- createObject (map (+(V3 (-1) (-1) (-1))) testVertices) 3 GL.TriangleStrip testObject1 <- createObject (map (+(V3 (1) (1) (1))) testVertices) 3 GL.TriangleStrip testObject2 <- createObject testVertices 3 GL.TriangleStrip let objects = [testObject0, testObject1, testObject2] -- load shaders program <- loadShaders [ ShaderInfo GL.VertexShader (StringSource vertShader) , ShaderInfo GL.FragmentShader (StringSource fragShader) ] GL.currentProgram $= Just program return (objects, program) -- a_ vertex shader input -- v_ varying -- u_ uniform -- o_ fragment shader output -- | vertex shader vertShader :: String vertShader = "#version 330 core\n" ++ "layout (location = 0) in vec3 a_vPos;\n" ++ "uniform mat4 u_view;\n" ++ "uniform mat4 u_projection;\n" ++ "out vec3 v_pos;\n" ++ "void main()\n" ++ "{\n" ++ " gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n" ++ " v_pos = a_vPos;\n" ++ "}" -- | fragment shader fragShader :: String fragShader = "#version 330 core\n" ++ "out vec4 o_vColor;\n" ++ "in vec3 v_pos;\n" ++ "void main()\n" ++ "{\n" ++ " o_vColor = vec4(0.5 + 0.5 * v_pos, 1);\n" ++ "}" -------------------------------------------------------------------------------- -- Objects -------------------------------------------------------------------------------- -- | calculates the size in memory of an array sizeOfArray :: (Storable a, Num b) => [a] -> b sizeOfArray [] = 0 sizeOfArray (x:xs) = fromIntegral $ (*) (1 + length xs) $ sizeOf x -- | loads a given array into a given attribute index createVBO :: Storable (a GL.GLfloat) => [a GL.GLfloat] -> GL.NumComponents -> GL.AttribLocation -> IO GL.BufferObject createVBO array numComponents attribLocation = do -- vbo for buffer buffer <- GL.genObjectName GL.bindBuffer GL.ArrayBuffer $= Just buffer -- populate buffer withArray array $ \ptr -> GL.bufferData GL.ArrayBuffer $= (sizeOfArray array, ptr, GL.StaticDraw) -- create attribute pointer to buffer GL.vertexAttribPointer attribLocation $= ( GL.ToFloat , GL.VertexArrayDescriptor numComponents GL.Float 0 (plusPtr nullPtr 0) ) GL.vertexAttribArray attribLocation $= GL.Enabled return buffer -- | creates an object from a given array; deals with vbos and everything createObject :: Storable (a GL.GLfloat) => [a GL.GLfloat] -> GL.NumComponents -> GL.PrimitiveMode -> IO Object createObject array numComponents primitiveMode = do -- vao for object vao <- GL.genObjectName GL.bindVertexArrayObject $= Just vao -- vbo for vertices createVBO array numComponents $ GL.AttribLocation 0 return (Object vao (fromIntegral $ length array) numComponents primitiveMode ) -------------------------------------------------------------------------------- -- Elm-like data structures -------------------------------------------------------------------------------- -- | gameloop loop :: GLFW.Window -- ^ window to display on -> (Model -> Model) -- ^ update function -> (GLFW.Window -> Model -> IO ()) -- ^ view function -> IORef Model -- ^ model -> IO () loop window update view modelRef = do -- start frame timer Just frameStart <- GLFW.getTime -- tick model modifyIORef' modelRef $ update model' <- readIORef modelRef -- view new model view window model' putStrLn $ (++) "pitch" $ show model'.camera.camPitch putStrLn $ (++) "yaw" $ show model'.camera.camYaw -- end frame timer, wait the difference between expected and actual Just frameEnd <- GLFW.getTime let dt = double2Float $ frameEnd - frameStart target = 1 / 60 :: Float when (dt < target) $ threadDelay $ floor $ (target - dt) * 1000000 Just frameEnd' <- GLFW.getTime let dt' = double2Float $ frameEnd' - frameStart loop window (Game.update dt') view modelRef -- | 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 = xn - xp z = zn - zp 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 newPitch = model.camera.camPitch - model.camera.mouseSensitivity * dt * (double2Float $ snd model.cursorDeltaPos) newPitch' = if newPitch >= (pi / 2) then (0.9999 * pi / 2) else newPitch newPitch'' = if newPitch <= ((-1) * pi / 2) then ((-0.9999) * pi / 2) else newPitch newYaw = model.camera.camYaw + model.camera.mouseSensitivity * dt * (double2Float $ fst model.cursorDeltaPos) newYaw' = newYaw - (mod' newYaw pi) in model { cursorDeltaPos = (0, 0) , camera = model.camera { camPitch = model.camera.camPitch + dt * (double2Float $ snd model.cursorDeltaPos) , camYaw = model.camera.camYaw + dt * (double2Float $ fst model.cursorDeltaPos) } } -- | 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 } -- | updates given a keyrelease. escape case is probably caught by GLFW in the -- handler function itself updateKeyReleased :: GLFW.Key -> Model -> Model updateKeyReleased key model = model { keys = (delete key model.keys) } applyToTuples :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c) applyToTuples f (x, y) (a, b) = (f x a, f y b) -- | updates cursor updateCursorPos :: Double -> Double -> Model -> Model updateCursorPos x y model = model { cursorPos = (x, y) , cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y) } -- | 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] -- apply transforms let yaw = (L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) model.camera.camReference) viewMatrix = L.lookAt model.camera.camPos (model.camera.camPos + L.rotate (L.axisAngle (L.cross model.wprop.up yaw) model.camera.camPitch) yaw) model.wprop.up projectionMatrix = L.perspective 1.5 (fromIntegral w / fromIntegral h) 0.1 100 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 -- | draws objects drawObjects :: [Object] -> IO ([Object]) drawObjects [] = return [] drawObjects ((Object vao numVertices _ primitiveMode):objects) = do GL.bindVertexArrayObject $= Just vao GL.drawArrays primitiveMode 0 numVertices drawObjects objects -------------------------------------------------------------------------------- -- interrupts -------------------------------------------------------------------------------- -- | shuts down GLFW shutdownWindow :: GLFW.WindowCloseCallback shutdownWindow window = do GLFW.destroyWindow window GLFW.terminate -- | resizes viewport with window resizeWindow :: GLFW.WindowSizeCallback resizeWindow _ _ _ = return () -- | handles key presses keyPressed :: Maybe (IORef Model) -> GLFW.KeyCallback keyPressed _ window GLFW.Key'Escape _ GLFW.KeyState'Pressed _ = shutdownWindow window keyPressed (Just modelRef) window key _ GLFW.KeyState'Pressed _ = modifyIORef' modelRef $ updateKeyPressed key keyPressed (Just modelRef) window key _ GLFW.KeyState'Released _ = modifyIORef' modelRef $ updateKeyReleased key keyPressed _ _ _ _ _ _ = return () -- | handles cursor position updates cursorPosHandler :: Maybe (IORef Model) -> GLFW.CursorPosCallback cursorPosHandler (Just modelRef) _ x y = modifyIORef' modelRef $ updateCursorPos x y cursorPosHandler Nothing _ _ _ = return ()