{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, 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 Game.Internal import Game.Internal.Types import Control.Lens ((^.)) import Data.IORef (newIORef) import GHC.Float (double2Float) import qualified Graphics.Rendering.OpenGL as GL import Graphics.Rendering.OpenGL (($=)) import qualified Graphics.UI.GLFW as GLFW import qualified Linear as L import Linear (V3(..), _y) -- | 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 (+ V3 a 0 0) cube | a <- take 100 [0,2..]] -- 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 -------------------------------------------------------------------------------- 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 -- TODO optimise cube -- | cube vertices 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 ] -------------------------------------------------------------------------------- -- 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