diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 329 |
1 files changed, 196 insertions, 133 deletions
diff --git a/src/Main.hs b/src/Main.hs index 2a96e89..6dec8ad 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-} + {- | - Module : Game - Description : runs game @@ -7,177 +8,243 @@ - Maintainer : Matrix @Andromeda:tchncs.de - Stability : Experimental -} -module Main (main) where +module Main + ( main + ) where -import Game.Internal.Types import Game.Internal +import Game.Internal.Types -import Control.Lens ((^.)) -import Data.IORef (newIORef) -import GHC.Float (double2Float) +import Control.Lens ((^.)) +import Data.IORef (newIORef) +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 Graphics.Rendering.OpenGL (($=)) +import qualified Graphics.UI.GLFW as GLFW import qualified Linear as L -import Linear ( V3(..), _y ) +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 + 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 testVertices - + (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) - ) + 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 + ] --- | 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 +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 - $ updateCameraAngle - dt - model + updateVelocity dt + $ updateAcceleration dt + $ updateSpeed dt + $ updateCameraAngle dt 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 - } +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 - model - { camera = model.camera - { airTime = 0 - , camVel = camVel' * (V3 1 0 1) - , camPos = model.camera.camPos * (V3 1 0 1) - , hasJumped = aboveGround - } + } + 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 - } + { 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 - } - } + 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 () @@ -185,39 +252,35 @@ 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) + 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) + 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 |