261 lines
7.4 KiB
Haskell
261 lines
7.4 KiB
Haskell
{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
|
|
{- |
|
|
- Module : Game.Internal
|
|
- Description : internal functions
|
|
- Copyright : 2025 Andromeda
|
|
- License : BSD 3-clause
|
|
- 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.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 qualified Graphics.UI.GLFW as GLFW
|
|
import qualified Graphics.Rendering.OpenGL as GL
|
|
import Graphics.Rendering.OpenGL as GL (($=))
|
|
|
|
import Linear (V3(..))
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Shader creation and object initialisation
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | loads models, shaders
|
|
initResources :: [V3 GL.GLfloat] -> IO ([Object], GL.Program)
|
|
initResources 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
|
|
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
|
|
|
|
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) _ key _ GLFW.KeyState'Pressed _ =
|
|
modifyIORef' modelRef $ updateKeyPressed key
|
|
keyPressed (Just modelRef) _ 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 ()
|