summaryrefslogtreecommitdiff
path: root/src/Game/Internal.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Game/Internal.hs')
-rw-r--r--src/Game/Internal.hs175
1 files changed, 71 insertions, 104 deletions
diff --git a/src/Game/Internal.hs b/src/Game/Internal.hs
index 3461d27..39f3fd4 100644
--- a/src/Game/Internal.hs
+++ b/src/Game/Internal.hs
@@ -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
generated by cgit v1.3.1 (git 2.54.0) at 2026-09-04 04:56:29 +0000