From a62275f853be9d9f43772fe1969c225ae43c3d62 Mon Sep 17 00:00:00 2001 From: mtgmonkey Date: Sun, 21 Dec 2025 12:23:57 +0100 Subject: merge development into master --- src/Game/Internal.hs | 175 +++++++++++++++++++++------------------------------ 1 file changed, 71 insertions(+), 104 deletions(-) (limited to 'src/Game/Internal.hs') 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 -- cgit v1.3.1