Andromeda/hs-game
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

merge development into master

Browse Source
This commit is contained in:
mtgmonkey
2025-12-21 12:23:57 +01:00
parent e9b4e2d34a
commit a62275f853
7 changed files with 382 additions and 413 deletions
Download Patch File Download Diff File Expand all files Collapse all files

175
src/Game/Internal.hs
View File

@@ -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