From 852244a49159097a83fc99edcdad26f84f999098 Mon Sep 17 00:00:00 2001 From: mtgmonkey Date: Sun, 7 Dec 2025 23:52:20 +0100 Subject: [PATCH] add changelog; see changelog <3 --- CHANGELOG.md | 42 ++++ README.md | 7 +- src/Game/Internal.hs | 267 +++++++++++++++++++++++++ src/Game/{ => Internal}/LoadShaders.hs | 2 +- src/Game/{ => Internal}/Types.hs | 23 ++- src/Game/Main.hs | 253 +++-------------------- 6 files changed, 360 insertions(+), 234 deletions(-) create mode 100644 CHANGELOG.md create mode 100644 src/Game/Internal.hs rename src/Game/{ => Internal}/LoadShaders.hs (98%) rename src/Game/{ => Internal}/Types.hs (85%) diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..5d229fa --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,42 @@ + +# Changelog + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), +and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). + +## [Unreleased] + +### Added + +- test suite for non-IO functions +- debug/release outputs of Nix flake + +### Changed + +- use Rotors rather than Quaternions for rotation; easily extended to 4D + +### Fixed + +- semantic issues + +## [0.1.0] - 2025-12-07 + +### Added + +- CHANGELOG.md +- layer correctly drawn objects in the view function + +### Changed + +- 8xMSAA rather than 4xMSAA window hint to improve AA +- todo and changelog in CHANGELOG.md rather than README.md +- a nubmer fo functions from Game module now in Game.Internal +- initResources takes an array of objects to draw rather than hardcoded arrays +- square the far plane of the perspective transform +- loop function takes delta time + +### Fixed + +- constrained pitch to disallow gimbal lock and an inverted view diff --git a/README.md b/README.md index 18227bc..f2c4dec 100644 --- a/README.md +++ b/README.md @@ -4,9 +4,4 @@ cd hs-game nix run ``` -todo - -- [x] add proper mouse movement -- [ ] abstract into `Game` and `Game.Internal` with appropriate exports -- [ ] refactor for correctness -- [ ] fix depth clipping; near squares show oft before far +todo moved to CHANGELOG.md 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 () diff --git a/src/Game/LoadShaders.hs b/src/Game/Internal/LoadShaders.hs similarity index 98% rename from src/Game/LoadShaders.hs rename to src/Game/Internal/LoadShaders.hs index 3d24e78..ded2da9 100644 --- a/src/Game/LoadShaders.hs +++ b/src/Game/Internal/LoadShaders.hs @@ -13,7 +13,7 @@ -- -------------------------------------------------------------------------------- -module Game.LoadShaders ( +module Game.Internal.LoadShaders ( ShaderSource(..), ShaderInfo(..), loadShaders ) where diff --git a/src/Game/Types.hs b/src/Game/Internal/Types.hs similarity index 85% rename from src/Game/Types.hs rename to src/Game/Internal/Types.hs index 738205f..719905e 100644 --- a/src/Game/Types.hs +++ b/src/Game/Internal/Types.hs @@ -7,15 +7,32 @@ - Maintainer : Matrix @Andromeda:tchncs.de - Stability : Experimental -} -module Game.Types +module Game.Internal.Types ( Object(..) , toGLMatrix - , Model (objects, camera, 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) diff --git a/src/Game/Main.hs b/src/Game/Main.hs index 5ba5bd7..7aeb2a5 100644 --- a/src/Game/Main.hs +++ b/src/Game/Main.hs @@ -9,8 +9,9 @@ -} module Game (main) where -import Game.LoadShaders -import Game.Types +import Game.Internal.LoadShaders +import Game.Internal.Types +import Game.Internal import Control.Concurrent (threadDelay) import Control.Lens ((^.), (+~), (&), (%~)) @@ -21,7 +22,7 @@ import Data.List (delete) import Foreign.Marshal.Array (withArray) import Foreign.Ptr (nullPtr, plusPtr) import Foreign.Storable (sizeOf, Storable) -import GHC.Float (double2Float) +import GHC.Float (double2Float, int2Double) import qualified Graphics.UI.GLFW as GLFW import qualified Graphics.Rendering.OpenGL as GL @@ -45,8 +46,8 @@ main = do GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 3 GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core - -- 4x MSAA - GLFW.windowHint $ GLFW.WindowHint'Samples $ Just 4 + -- MSAA + GLFW.windowHint $ GLFW.WindowHint'Samples $ Just 8 -- create window monitor <- GLFW.getPrimaryMonitor @@ -57,9 +58,10 @@ main = do 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 window + (objects, program) <- initResources window testVertices -- init model let @@ -71,7 +73,7 @@ main = do 0 -- yaw (V3 0 0 (-1)) -- reference vector (V3 0 0 0) -- velocity - 0.08 -- mouse sensitivity + 2 -- mouse sensitivity 16 -- strafe strength 12 -- jump strength ) @@ -88,7 +90,7 @@ main = do GLFW.setKeyCallback window $ Just $ keyPressed $ Just modelRef GLFW.setCursorPosCallback window $ Just $ cursorPosHandler $ Just modelRef - loop window (update 0) view modelRef + loop window 0 update view modelRef -------------------------------------------------------------------------------- -- Arrays @@ -103,158 +105,10 @@ testVertices = , V3 0.5 0.5 0 ] --------------------------------------------------------------------------------- --- Shader creation and object initialisation --------------------------------------------------------------------------------- - --- | loads models, shaders -initResources :: GLFW.Window -> IO ([Object], GL.Program) -initResources window = do - -- create objects - testObject0 <- createObject (map (+(V3 (-1) (-1) (-1))) testVertices) 3 GL.TriangleStrip - testObject1 <- createObject (map (+(V3 (1) (1) (1))) testVertices) 3 GL.TriangleStrip - testObject2 <- createObject testVertices 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 - -> (Model -> Model) -- ^ update function - -> (GLFW.Window -> Model -> IO ()) -- ^ view function - -> IORef Model -- ^ model - -> IO () -loop window update view modelRef = do - -- start frame timer - Just frameStart <- GLFW.getTime - - -- tick model - modifyIORef' modelRef $ update - model' <- readIORef modelRef - - -- view new model - view window model' - - putStrLn $ (++) "pitch" $ show model'.camera.camPitch - putStrLn $ (++) "yaw" $ show model'.camera.camYaw - - -- 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 (Game.update dt') view modelRef - -- | update function update :: Float -> Model -> Model update dt model = @@ -275,8 +129,8 @@ updateAcceleration dt model = 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 = xn - xp - z = zn - zp + 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 @@ -323,17 +177,19 @@ updateVelocity dt model = updateCameraAngle :: Float -> Model -> Model updateCameraAngle dt model = let - newPitch = model.camera.camPitch - model.camera.mouseSensitivity * dt * (double2Float $ snd model.cursorDeltaPos) - newPitch' = if newPitch >= (pi / 2) then (0.9999 * pi / 2) else newPitch - newPitch'' = if newPitch <= ((-1) * pi / 2) then ((-0.9999) * pi / 2) else newPitch - newYaw = model.camera.camYaw + model.camera.mouseSensitivity * dt * (double2Float $ fst model.cursorDeltaPos) - newYaw' = newYaw - (mod' newYaw pi) + 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 = model.camera.camPitch + dt * (double2Float $ snd model.cursorDeltaPos) - , camYaw = model.camera.camYaw + dt * (double2Float $ fst model.cursorDeltaPos) + { camPitch = newPitch'' + , camYaw = newYaw } } @@ -343,23 +199,6 @@ 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 = - model - { cursorPos = (x, y) - , cursorDeltaPos = applyToTuples (-) model.cursorPos (x, y) - } - -- | views the model view :: GLFW.Window -> Model -> IO () view window model = do @@ -371,15 +210,20 @@ view window model = do GL.clearColor $= GL.Color4 1 0 1 1 GL.clear [GL.ColorBuffer, GL.DepthBuffer] + -- depth + GL.depthFunc $= Just GL.Less + -- apply transforms let - yaw = (L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) model.camera.camReference) + 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 + L.rotate (L.axisAngle (L.cross model.wprop.up yaw) model.camera.camPitch) yaw) + (model.camera.camPos - forward) model.wprop.up - projectionMatrix = L.perspective 1.5 (fromIntegral w / fromIntegral h) 0.1 100 + projectionMatrix = L.perspective 1.5 (fromIntegral w / fromIntegral h) 0.01 10000 viewGLMatrix <- GL.newMatrix GL.RowMajor $ toGLMatrix viewMatrix :: IO (GL.GLmatrix GL.GLfloat) viewLocation <- GL.get $ GL.uniformLocation model.program "u_view" @@ -397,42 +241,3 @@ view window model = do -- check for interrupts GLFW.pollEvents - --- | 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 ()