diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Game/Internal.hs | 175 | ||||
| -rw-r--r-- | src/Game/Internal/LoadShaders.hs | 75 | ||||
| -rw-r--r-- | src/Game/Internal/Types.hs | 167 | ||||
| -rw-r--r-- | src/Main.hs | 329 |
4 files changed, 365 insertions, 381 deletions
diff --git a/src/Game/Internal.hs b/src/Game/Internal.hs index 3461d27..39f3fd4 100644 --- a/src/Game/Internal.hs +++ b/src/Game/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-} + {- | - Module : Game.Internal - Description : internal functions @@ -18,91 +19,89 @@ module Game.Internal , updateCursorPos , updateKeyPressed , updateKeyReleased - ) - where + ) where import Game.Internal.LoadShaders import Game.Internal.Types -import Control.Concurrent (threadDelay) -import Control.Monad (when) -import Data.IORef (IORef, modifyIORef', readIORef) -import Data.List (delete) +import Control.Concurrent (threadDelay) +import Control.Monad (when) +import Data.IORef (IORef, modifyIORef', readIORef) +import Data.List (delete) import Foreign.Marshal.Array (withArray) -import Foreign.Ptr (nullPtr, plusPtr) -import Foreign.Storable (sizeOf, Storable) -import GHC.Float (double2Float) +import Foreign.Ptr (nullPtr, plusPtr) +import Foreign.Storable (Storable, sizeOf) +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 Linear (V3(..)) -------------------------------------------------------------------------------- -- Shader creation and object initialisation -------------------------------------------------------------------------------- - -- | loads models, shaders -initResources :: [V3 GL.GLfloat] -> IO ([Object], GL.Program) -initResources array = do +initResources :: [[V3 GL.GLfloat]] -> IO ([Object], GL.Program) +initResources arrays = do -- create objects - testObject0 <- createObject (map (+(V3 (-1) (-1) (-1))) array) 3 GL.TriangleStrip - testObject1 <- createObject (map (+(V3 (1) (1) (1))) array) 3 GL.TriangleStrip - testObject2 <- createObject array 3 GL.TriangleStrip - let objects = [testObject0, testObject1, testObject2] - + objects <- listIOsToIOlist [ createObject arr 3 GL.TriangleStrip | arr <- arrays ] [] -- load shaders - program <- loadShaders - [ ShaderInfo GL.VertexShader (StringSource vertShader) - , ShaderInfo GL.FragmentShader (StringSource fragShader) - ] + program <- + loadShaders + [ ShaderInfo GL.VertexShader (StringSource vertShader) + , ShaderInfo GL.FragmentShader (StringSource fragShader) + ] GL.currentProgram $= Just program - return (objects, program) +listIOsToIOlist :: [IO a] -> [a] -> IO [a] +listIOsToIOlist [] out = return out +listIOsToIOlist (io:ios) out = do + ioVal <- io + listIOsToIOlist ios (ioVal:out) + -- 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" ++ - "}" - + "#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" ++ - "}" + "#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 * normalize(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) +createVBO :: + Storable (a GL.GLfloat) => [a GL.GLfloat] -> GL.NumComponents -> GL.AttribLocation @@ -111,29 +110,19 @@ 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) - + 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.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) +createObject :: + Storable (a GL.GLfloat) => [a GL.GLfloat] -> GL.NumComponents -> GL.PrimitiveMode @@ -142,25 +131,16 @@ 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 - ) + return (Object vao (fromIntegral $ length array) numComponents primitiveMode) -------------------------------------------------------------------------------- -- Elm-like data structures -------------------------------------------------------------------------------- - -- | gameloop -loop - :: GLFW.Window -- ^ window to display on +loop :: + GLFW.Window -- ^ window to display on -> Float -- ^ dt -> (Float -> Model -> Model) -- ^ update function -> (GLFW.Window -> Model -> IO ()) -- ^ view function @@ -169,62 +149,50 @@ loop loop window dt update view modelRef = do -- start frame timer Just frameStart <- GLFW.getTime - -- tick model modifyIORef' modelRef $ update dt model' <- readIORef modelRef - -- view new model view window model' - -- end frame timer, wait the difference between expected and actual Just frameEnd <- GLFW.getTime - let - drawTime = double2Float $ frameEnd - frameStart - target = 1 / 60 :: Float + let drawTime = double2Float $ frameEnd - frameStart + target = 1 / 60 :: Float when (drawTime < target) $ threadDelay $ floor $ (target - drawTime) * 1000000 Just frameEnd' <- GLFW.getTime - let - dt' = double2Float $ frameEnd' - frameStart - + let dt' = double2Float $ frameEnd' - frameStart loop window dt' update view modelRef -- | 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 } +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) } +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 :: Double -> Double -> Model -> Model updateCursorPos x y model = - let - pyth = (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos) - y) ** 2) ** 0.5 - in - if pyth < 16 then - model - { cursorPos = (x, y) - , cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y) - } - else - model - { cursorPos = (x, y) - } + let pyth = + (((fst model.cursorPos) - x) ** 2 + ((snd model.cursorPos) - y) ** 2) + ** 0.5 + in if pyth < 16 + then model + { cursorPos = (x, y) + , cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y) + } + else model {cursorPos = (x, y)} -- | draws objects drawObjects :: [Object] -> IO ([Object]) drawObjects [] = return [] -drawObjects - ((Object vao numVertices _ primitiveMode):objects) = do +drawObjects ((Object vao numVertices _ primitiveMode):objects) = do GL.bindVertexArrayObject $= Just vao GL.drawArrays primitiveMode 0 numVertices drawObjects objects @@ -232,7 +200,6 @@ drawObjects -------------------------------------------------------------------------------- -- interrupts -------------------------------------------------------------------------------- - -- | shuts down GLFW shutdownWindow :: GLFW.WindowCloseCallback shutdownWindow window = do diff --git a/src/Game/Internal/LoadShaders.hs b/src/Game/Internal/LoadShaders.hs index ded2da9..86b549f 100644 --- a/src/Game/Internal/LoadShaders.hs +++ b/src/Game/Internal/LoadShaders.hs @@ -12,10 +12,11 @@ -- Red Book Authors. -- -------------------------------------------------------------------------------- - -module Game.Internal.LoadShaders ( - ShaderSource(..), ShaderInfo(..), loadShaders -) where +module Game.Internal.LoadShaders + ( ShaderSource(..) + , ShaderInfo(..) + , loadShaders + ) where import Control.Exception import Control.Monad @@ -23,17 +24,15 @@ import qualified Data.ByteString as B import Graphics.Rendering.OpenGL -------------------------------------------------------------------------------- - -- | The source of the shader source code. - -data ShaderSource = - ByteStringSource B.ByteString +data ShaderSource + = ByteStringSource B.ByteString -- ^ The shader source code is directly given as a 'B.ByteString'. - | StringSource String + | StringSource String -- ^ The shader source code is directly given as a 'String'. - | FileSource FilePath + | FileSource FilePath -- ^ The shader source code is located in the file at the given 'FilePath'. - deriving ( Eq, Ord, Show ) + deriving (Eq, Ord, Show) getSource :: ShaderSource -> IO B.ByteString getSource (ByteStringSource bs) = return bs @@ -41,49 +40,47 @@ getSource (StringSource str) = return $ packUtf8 str getSource (FileSource path) = B.readFile path -------------------------------------------------------------------------------- - -- | A description of a shader: The type of the shader plus its source code. - -data ShaderInfo = ShaderInfo ShaderType ShaderSource - deriving ( Eq, Ord, Show ) +data ShaderInfo = + ShaderInfo ShaderType ShaderSource + deriving (Eq, Ord, Show) -------------------------------------------------------------------------------- - -- | Create a new program object from the given shaders, throwing an -- 'IOException' if something goes wrong. - loadShaders :: [ShaderInfo] -> IO Program loadShaders infos = - createProgram `bracketOnError` deleteObjectName $ \program -> do - loadCompileAttach program infos - linkAndCheck program - return program + createProgram `bracketOnError` deleteObjectName $ \program -> do + loadCompileAttach program infos + linkAndCheck program + return program linkAndCheck :: Program -> IO () linkAndCheck = checked linkProgram linkStatus programInfoLog "link" loadCompileAttach :: Program -> [ShaderInfo] -> IO () loadCompileAttach _ [] = return () -loadCompileAttach program (ShaderInfo shType source : infos) = - createShader shType `bracketOnError` deleteObjectName $ \shader -> do - src <- getSource source - shaderSourceBS shader $= src - compileAndCheck shader - attachShader program shader - loadCompileAttach program infos +loadCompileAttach program (ShaderInfo shType source:infos) = + createShader shType `bracketOnError` deleteObjectName $ \shader -> do + src <- getSource source + shaderSourceBS shader $= src + compileAndCheck shader + attachShader program shader + loadCompileAttach program infos compileAndCheck :: Shader -> IO () compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile" -checked :: (t -> IO ()) - -> (t -> GettableStateVar Bool) - -> (t -> GettableStateVar String) - -> String - -> t - -> IO () +checked :: + (t -> IO ()) + -> (t -> GettableStateVar Bool) + -> (t -> GettableStateVar String) + -> String + -> t + -> IO () checked action getStatus getInfoLog message object = do - action object - ok <- get (getStatus object) - unless ok $ do - infoLog <- get (getInfoLog object) - fail (message ++ " log: " ++ infoLog) + action object + ok <- get (getStatus object) + unless ok $ do + infoLog <- get (getInfoLog object) + fail (message ++ " log: " ++ infoLog) diff --git a/src/Game/Internal/Types.hs b/src/Game/Internal/Types.hs index ad220e4..8095cfb 100644 --- a/src/Game/Internal/Types.hs +++ b/src/Game/Internal/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns, OverloadedRecordDot #-} + {- | - Module : Game.Internal.Types - Description : @@ -9,116 +10,83 @@ -} module Game.Internal.Types ( Object(..) - , toGLMatrix - - , Model ( camera - , objects - , cursorDeltaPos - , cursorPos - , program - , keys - , wprop - ) + , Model(camera, objects, cursorDeltaPos, cursorPos, program, keys, wprop) , mkModel - - , Camera ( camPos - , camPitch - , camYaw - , camReference - , mouseSensitivity - , camVel - , strafeStrength - , jumpStrength - , hasJumped - , airTime - ) + , Camera(camPos, camPitch, camYaw, camReference, mouseSensitivity, camVel, strafeStrength, jumpStrength, hasJumped, airTime) , mkCamera - - , WorldProperties (g, friction, up) + , WorldProperties(g, friction, up) , mkWorldProperties - ) where -import qualified Graphics.UI.GLFW as GLFW import qualified Graphics.Rendering.OpenGL as GL +import qualified Graphics.UI.GLFW as GLFW import qualified Linear as L -import Linear (V3, V3(..), V4(..)) +import Linear (V3, V3(..), V4(..)) -- | represents a single draw call -data Object = - Object - { vao :: GL.VertexArrayObject -- ^ vao of vertex buffer - , numIndicies :: GL.NumArrayIndices -- ^ number of vertices - , numComponents :: GL.NumComponents -- ^ dimensionallity; vec3, vec4, etc. - , primitiveMode :: GL.PrimitiveMode -- ^ primitive mode to be drawn with - } - deriving Show +data Object = Object + { vao :: GL.VertexArrayObject -- ^ vao of vertex buffer + , numIndicies :: GL.NumArrayIndices -- ^ number of vertices + , numComponents :: GL.NumComponents -- ^ dimensionallity; vec3, vec4, etc. + , primitiveMode :: GL.PrimitiveMode -- ^ primitive mode to be drawn with + } deriving (Show) -- | converts M44 to a 16array for OpenGL toGLMatrix :: L.M44 GL.GLfloat -> [GL.GLfloat] -toGLMatrix - (V4 - (V4 c00 c01 c02 c03) - (V4 c10 c11 c12 c13) - (V4 c20 c21 c22 c23) - (V4 c30 c31 c32 c33)) = - [ c00, c01, c02, c03 - , c10, c11, c12, c13 - , c20, c21, c22, c23 - , c30, c31, c32, c33 +toGLMatrix (V4 (V4 c00 c01 c02 c03) (V4 c10 c11 c12 c13) (V4 c20 c21 c22 c23) (V4 c30 c31 c32 c33)) = + [ c00 + , c01 + , c02 + , c03 + , c10 + , c11 + , c12 + , c13 + , c20 + , c21 + , c22 + , c23 + , c30 + , c31 + , c32 + , c33 ] -- | gamestate -data Model = - Model - { camera :: Camera - , cursorDeltaPos :: (Double, Double) -- ^ frame-on-frame delta mouse position - , cursorPos :: (Double, Double) -- ^ current mouse position - , keys :: [GLFW.Key] -- ^ currently pressed keys - , objects :: [Object] -- ^ draw calls - , program :: GL.Program -- ^ shader program - , wprop :: WorldProperties - } - deriving Show +data Model = Model + { camera :: Camera + , cursorDeltaPos :: (Double, Double) -- ^ frame-on-frame delta mouse position + , cursorPos :: (Double, Double) -- ^ current mouse position + , keys :: [GLFW.Key] -- ^ currently pressed keys + , objects :: [Object] -- ^ draw calls + , program :: GL.Program -- ^ shader program + , wprop :: WorldProperties + } deriving (Show) -- | smart constructor for Model -mkModel - :: Camera - -> [Object] - -> GL.Program - -> WorldProperties - -> Model +mkModel :: Camera -> [Object] -> GL.Program -> WorldProperties -> Model mkModel camera objects program wprop = - Model - camera - (0,0) - (0,0) - [] - objects - program - wprop + Model camera (0, 0) (0, 0) [] objects program wprop -- | camera -data Camera = - Camera - { camPos :: V3 Float -- ^ position in world space - , camPitch :: Float -- ^ pitch in radians, up positive - , camYaw :: Float -- ^ yaw in radians, right positive - , camReference :: V3 Float -- ^ reference direction; orientation applied to - , camVel :: V3 Float -- ^ velocity in world space - , mouseSensitivity :: Float -- ^ scale factor for mouse movement - , strafeStrength :: Float -- ^ scale factor for strafe - , jumpStrength :: Float -- ^ scale factor for jump initial velocity - , hasJumped :: Bool -- ^ whether the camera still has jumping state - , airTime :: Float -- ^ time since jumping state entered in seconds - } - deriving Show +data Camera = Camera + { camPos :: V3 Float -- ^ position in world space + , camPitch :: Float -- ^ pitch in radians, up positive + , camYaw :: Float -- ^ yaw in radians, right positive + , camReference :: V3 Float -- ^ reference direction; orientation applied to + , camVel :: V3 Float -- ^ velocity in world space + , mouseSensitivity :: Float -- ^ scale factor for mouse movement + , strafeStrength :: Float -- ^ scale factor for strafe + , jumpStrength :: Float -- ^ scale factor for jump initial velocity + , hasJumped :: Bool -- ^ whether the camera still has jumping state + , airTime :: Float -- ^ time since jumping state entered in seconds + } deriving (Show) -- | smart constructor for Camera -mkCamera - :: V3 Float +mkCamera :: + V3 Float -> Float -> Float -> V3 Float @@ -127,15 +95,7 @@ mkCamera -> Float -> Float -> Camera -mkCamera - camPos - camPitch - camYaw - camReference - camVel - mouseSensitivity - strafeStrength - jumpStrength = +mkCamera camPos camPitch camYaw camReference camVel mouseSensitivity strafeStrength jumpStrength = Camera camPos camPitch @@ -149,15 +109,12 @@ mkCamera 0 -- | physical properties of the world -data WorldProperties = - WorldProperties - { g :: Float -- ^ gravity `g` - , friction :: Float -- ^ scale factor for floor friction - , up :: V3 Float -- ^ global up vector - } - deriving Show +data WorldProperties = WorldProperties + { g :: Float -- ^ gravity `g` + , friction :: Float -- ^ scale factor for floor friction + , up :: V3 Float -- ^ global up vector + } deriving (Show) -- | smart constructor for WorldProperties -mkWorldProperties :: Float -> Float -> V3 Float-> WorldProperties -mkWorldProperties g friction up = - WorldProperties g friction (L.normalize up) +mkWorldProperties :: Float -> Float -> V3 Float -> WorldProperties +mkWorldProperties g friction up = WorldProperties g friction (L.normalize up) 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 |