diff options
Diffstat (limited to 'src/Game/Internal.hs')
| -rw-r--r-- | src/Game/Internal.hs | 267 |
1 files changed, 267 insertions, 0 deletions
diff --git a/src/Game/Internal.hs b/src/Game/Internal.hs new file mode 100644 index 0000000..bb9da57 --- /dev/null +++ b/src/Game/Internal.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-} +{- | + - Module : Game.Internal + - Description : 'hidden' functions + - Copyright : Andromeda 2025 + - License : WTFPL + - Maintainer : Matrix @Andromeda:tchncs.de + - Stability : Experimental + -} +module Game.Internal + ( cursorPosHandler + , drawObjects + , initResources + , keyPressed + , loop + , resizeWindow + , shutdownWindow + , updateCursorPos + , updateKeyPressed + , updateKeyReleased + ) + where + +import Game.Internal.LoadShaders +import Game.Internal.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 + ) + +-------------------------------------------------------------------------------- +-- Shader creation and object initialisation +-------------------------------------------------------------------------------- + +-- | loads models, shaders +initResources :: GLFW.Window -> [V3 GL.GLfloat] -> IO ([Object], GL.Program) +initResources window array = 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] + + -- 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 + -> Float -- ^ dt + -> (Float -> Model -> Model) -- ^ update function + -> (GLFW.Window -> Model -> IO ()) -- ^ view function + -> IORef Model -- ^ model + -> IO () +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 + 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 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 } + +-- | 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 = + 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 + 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 () |