hypercube, format ig
This commit is contained in:
andromeda
@@ -1,28 +1,27 @@
|
||||
{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
|
||||
{-# LANGUAGE DisambiguateRecordFields #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
|
||||
{- |
|
||||
- Module : Game.Internal
|
||||
- Description : internal functions
|
||||
- Copyright : 2025 Andromeda
|
||||
- License : BSD 3-clause
|
||||
- Maintainer : Matrix @Andromeda:tchncs.de
|
||||
- Stability : Experimental
|
||||
-}
|
||||
-- |
|
||||
-- - 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
|
||||
( cursorPosHandler,
|
||||
drawObjects,
|
||||
initResources,
|
||||
keyPressed,
|
||||
loop,
|
||||
resizeWindow,
|
||||
shutdownWindow,
|
||||
updateCursorPos,
|
||||
updateKeyPressed,
|
||||
updateKeyReleased,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Monad (when)
|
||||
@@ -32,53 +31,56 @@ import Foreign.Marshal.Array (withArray)
|
||||
import Foreign.Ptr (nullPtr, plusPtr)
|
||||
import Foreign.Storable (Storable, sizeOf)
|
||||
import GHC.Float (double2Float)
|
||||
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
import Game.Internal.LoadShaders
|
||||
import Game.Internal.Types
|
||||
import Graphics.Rendering.OpenGL (($=))
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
import qualified Graphics.UI.GLFW as GLFW
|
||||
|
||||
import Linear (V3(..))
|
||||
import Linear (V3 (..), V4 (..))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Shader creation and object initialisation
|
||||
--------------------------------------------------------------------------------
|
||||
-- | loads models, shaders
|
||||
initResources :: [[V3 GL.GLfloat]] -> IO ([Object], GL.Program)
|
||||
|
||||
initResources :: [[V4 GL.GLfloat]] -> IO ([Object], GL.Program)
|
||||
initResources arrays = do
|
||||
-- create objects
|
||||
objects <- listIOsToIOlist [ createObject arr 3 GL.TriangleStrip | arr <- arrays ] []
|
||||
-- load shaders
|
||||
objects <-
|
||||
listIOsToIOlist
|
||||
[createObject arr 4 GL.TriangleStrip (GL.AttribLocation 0) | arr <- arrays]
|
||||
[]
|
||||
program <-
|
||||
loadShaders
|
||||
[ ShaderInfo GL.VertexShader (StringSource vertShader)
|
||||
, ShaderInfo GL.FragmentShader (StringSource fragShader)
|
||||
[ 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
|
||||
listIOsToIOlist (io : ios) out = do
|
||||
ioVal <- io
|
||||
listIOsToIOlist ios (ioVal:out)
|
||||
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"
|
||||
++ "layout (location = 0) in vec4 a_vPos;\n"
|
||||
++ "uniform mat4 u_view;\n"
|
||||
++ "uniform mat4 u_projection;\n"
|
||||
++ "out vec3 v_pos;\n"
|
||||
++ glslProjectTo3d
|
||||
++ "void main()\n"
|
||||
++ "{\n"
|
||||
++ " gl_Position = u_projection * u_view * vec4(a_vPos.xyz, 1.0);\n"
|
||||
++ " v_pos = a_vPos;\n"
|
||||
++ "}"
|
||||
++ " gl_Position = u_projection * u_view * vec4(projectTo3d(a_vPos), 1.0);\n"
|
||||
++ " v_pos = a_vPos.xyz;\n"
|
||||
++ "}\n"
|
||||
|
||||
-- | fragment shader
|
||||
fragShader :: String
|
||||
@@ -89,23 +91,32 @@ fragShader =
|
||||
++ "void main()\n"
|
||||
++ "{\n"
|
||||
++ " o_vColor = vec4(0.5 + 0.5 * normalize(v_pos), 1);\n"
|
||||
++ "}"
|
||||
++ "}\n"
|
||||
|
||||
glslProjectTo3d :: String
|
||||
glslProjectTo3d =
|
||||
"vec3 projectTo3d(vec4 point)\n"
|
||||
++ "{\n"
|
||||
++ " float perspective = 1.0 / (1.0 + point.w);\n"
|
||||
++ " return perspective * point.xyz;\n"
|
||||
++ "}\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
|
||||
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
|
||||
(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
|
||||
@@ -115,37 +126,45 @@ createVBO array numComponents attribLocation = do
|
||||
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.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
|
||||
(Storable (a GL.GLfloat)) =>
|
||||
[a GL.GLfloat] ->
|
||||
GL.NumComponents ->
|
||||
GL.PrimitiveMode ->
|
||||
GL.AttribLocation ->
|
||||
IO Object
|
||||
createObject array numComponents primitiveMode attrLocation = do
|
||||
-- vao for object
|
||||
vao <- GL.genObjectName
|
||||
GL.bindVertexArrayObject $= Just vao
|
||||
-- vbo for vertices
|
||||
_ <- createVBO array numComponents $ GL.AttribLocation 0
|
||||
_ <- createVBO array numComponents attrLocation
|
||||
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 ()
|
||||
-- | window to display on
|
||||
GLFW.Window ->
|
||||
-- | dt
|
||||
Float ->
|
||||
-- | update function
|
||||
(Float -> Model -> Model) ->
|
||||
-- | view function
|
||||
(GLFW.Window -> Model -> IO ()) ->
|
||||
-- | model
|
||||
IORef Model ->
|
||||
IO ()
|
||||
loop window dt update view modelRef = do
|
||||
-- start frame timer
|
||||
Just frameStart <- GLFW.getTime
|
||||
@@ -183,16 +202,17 @@ updateCursorPos x y model =
|
||||
(((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)
|
||||
}
|
||||
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
|
||||
@@ -200,6 +220,7 @@ drawObjects ((Object vao numVertices _ primitiveMode):objects) = do
|
||||
--------------------------------------------------------------------------------
|
||||
-- interrupts
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | shuts down GLFW
|
||||
shutdownWindow :: GLFW.WindowCloseCallback
|
||||
shutdownWindow window = do
|
||||
|
||||
Reference in New Issue
Block a user