From 5ec8901dd71f10629bf4e04a161de06a533d7ae3 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 11 Jan 2021 10:33:20 +0100 Subject: [PATCH] split Scene 'Test' up in submodules per method and hunt warnings --- pituicat.cabal | 4 + src/Classes/Graphics/Buffer.hs | 2 - src/Scenes/Test.hs | 242 ++---------------------------- src/Scenes/Test/Load.hs | 107 +++++++++++++ src/Scenes/Test/Types.hs | 25 +++ src/Scenes/Test/Update.hs | 60 ++++++++ src/Scenes/Test/Util.hs | 99 ++++++++++++ src/Types/Graphics/Shader.hs | 12 +- src/Types/Graphics/VertexArray.hs | 15 +- src/Types/Map.hs | 4 +- src/Types/Player.hs | 2 +- src/Types/Subsystems.hs | 12 +- src/Types/Texture.hs | 2 +- 13 files changed, 320 insertions(+), 266 deletions(-) create mode 100644 src/Scenes/Test/Load.hs create mode 100644 src/Scenes/Test/Types.hs create mode 100644 src/Scenes/Test/Update.hs create mode 100644 src/Scenes/Test/Util.hs diff --git a/pituicat.cabal b/pituicat.cabal index c3339d7..28a4641 100644 --- a/pituicat.cabal +++ b/pituicat.cabal @@ -44,6 +44,10 @@ executable pituicat , Classes.Physics.Mass , Classes.Physics.Collidible , Scenes.Test + , Scenes.Test.Types + , Scenes.Test.Util + , Scenes.Test.Load + , Scenes.Test.Update , Map , StateMachine , Renderer diff --git a/src/Classes/Graphics/Buffer.hs b/src/Classes/Graphics/Buffer.hs index b6c0365..4f7f34f 100644 --- a/src/Classes/Graphics/Buffer.hs +++ b/src/Classes/Graphics/Buffer.hs @@ -4,8 +4,6 @@ module Classes.Graphics.Buffer where import qualified Graphics.Rendering.OpenGL as GL -import SDL (($=), get) - import Foreign.Storable -- internal imports diff --git a/src/Scenes/Test.hs b/src/Scenes/Test.hs index 477ff64..fc26dba 100644 --- a/src/Scenes/Test.hs +++ b/src/Scenes/Test.hs @@ -1,45 +1,24 @@ {-# LANGUAGE OverloadedStrings #-} -module Scenes.Test where +module Scenes.Test + ( module Test + ) where import Affection as A -import qualified Graphics.Rendering.OpenGL as GL - import qualified Data.Vector.Storable as VS import qualified Data.Vector as V -import Data.String - import Control.Concurrent.STM -import Control.Arrow ((***)) - -import Control.Monad (void) - -import Linear - -- internal imports import Types import Classes -import Map import Renderer as R - -data Test = Test - { testMap :: TMVar LevelMap - , testGraphics :: TMVar GLAssets - , testLoaded :: TVar Bool - , testStageSet :: TVar (V.Vector StageSet) - , testCast :: TVar (V.Vector Cast) - } - -data GLAssets = GLAssets - { glVA :: VertexArray - , glVB :: VertexBuffer - , glIB :: IndexBuffer - , glSP :: Shader - , glTx :: [Texture] - } +import Scenes.Test.Types as Test +import Scenes.Test.Util as Test +import Scenes.Test.Load as Test +import Scenes.Test.Update as Test instance Scene Test where @@ -51,130 +30,11 @@ instance Scene Test where <*> newTVarIO V.empty <*> newTVarIO V.empty - loadScene level progress = do - atomically $ do - void $ takeTMVar progress - putTMVar progress (0, "Loading test level...") - loadedMap <- constructMap testLevelDesc 0 - atomically $ putTMVar (testMap level) loadedMap - void $ atomically $ do - void $ takeTMVar progress - putTMVar progress (0.5, "Loaded test level map!") - void $ atomically $ swapTVar (testLoaded level) True - - let projection = ortho 0 800 0 600 (-1) 1 :: M44 GL.GLfloat - view = mkTransformationMat - (identity :: M33 GL.GLfloat) - (V3 0 ((-64) * 32 + 600) 0) - model = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0) - - vertexArray <- newVertexArray - - bind vertexArray - - vertexBuffer <- newVertexBuffer 1024 - - bind vertexBuffer - - let vertices = VS.fromList (createQuad (V2 (400 - 16) (300 - 16)) 0) - - write vertexBuffer 0 vertices - - indexBuffer <- newIndexBuffer 1024 - - bind indexBuffer - - let indices = VS.fromList [0, 1, 2, 2, 3, 0] - - write indexBuffer 0 indices - - addBuffer (undefined :: Vertex) vertexBuffer - - (_, tex) <- newTexture "res/pituicat/pituicat.png" 1 - bind tex - - shader <- newShader - [ ShaderSource GL.VertexShader "./res/shaders/vert.shader" - , ShaderSource GL.FragmentShader "./res/shaders/frag.shader" - ] - - bind shader - setUniform shader "u_mvp" (projection !*! view !*! model) - setUniformList - shader - "u_textures" - (map - textureSlot - [ (tileMapTexture $ mapTileMap loadedMap) - , tex - ] - ) - - let pituicat = Pituicat - (V2 100 1948) - (V2 0 0) - (V2 0 0) - 100 - tex - - unbind vertexArray - unbind vertexBuffer - unbind indexBuffer - unbind tex - unbind shader - - atomically $ do - putTMVar (testGraphics level) - (GLAssets vertexArray vertexBuffer indexBuffer shader [tex]) - modifyTVar (testCast level) (\cast -> Cast pituicat `V.cons` cast) - writeTVar (testLoaded level) True - - void $ atomically $ do - void $ takeTMVar progress - putTMVar progress (1, "Loaded graphics!") - + loadScene = load isSceneLoaded = liftIO . readTVarIO . testLoaded - update level dt = liftIO $ do - logIO Debug ("FPS: " <> fromString (show $ 1 / dt)) - - -- Let all Actors update themselves and check for collisions - -- (Typeclasses rock!) - atomically $ do - lmap <- readTMVar (testMap level) - let layer = mapLayers lmap V.! fromIntegral (mapWalkLayer lmap) - modifyTVar - (testCast level) $ \cast -> - let playedCast = - V.map - (\(Cast c) -> Cast (perform dt c)) - cast - collidedCast = - (\(Cast c1) (Cast c2) -> - Cast $ - if collisionCheck dt c1 c2 - then collide c1 c2 - else c1 - ) - <$> playedCast <*> playedCast - wallCast (Cast c) = Cast $ - V.foldl - (\member tile -> - if collisionCheck dt member tile - then collide member tile - else member - ) - c - layer - walledCast = - V.map wallCast collidedCast - in - V.map - (\(Cast c) -> Cast $ - move dt c - ) - walledCast + update = Test.update onEvents _ _ = return () @@ -200,87 +60,3 @@ instance Scene Test where V.mapM_ (\(StageSet p) -> bindPropTexture p) stageSet V.mapM_ (\(Cast c) -> bindPropTexture c) cast R.draw va ib sh - -testLevelDesc :: LevelDescriptor -testLevelDesc = LevelDescriptor - [ (0, "res/maps/00_test/00_test.bmp") - ] - 0 - "res/tiles/00_test/00_test.png" - (3, 3) - -createQuad :: V2 GL.GLfloat -> Int -> [Vertex] -createQuad (V2 x y) index = - [ newVertex - (V3 x y 0) - (V4 0 0 0 1) - (V2 0 (1 - (50 / 1024))) - (fromIntegral index) - , newVertex - (V3 (x + 32) y 0) - (V4 0 0 0 1) - (V2 (50 / 1024) (1 - (50/1024))) - (fromIntegral index) - , newVertex - (V3 (x + 32) (y + 32) 0) - (V4 0 0 0 1) - (V2 (50 / 1024) 1) - (fromIntegral index) - , newVertex - (V3 x (y + 32) 0) - (V4 0 0 0 1) - (V2 0 1) - (fromIntegral index) - ] - -populate - :: V.Vector Layer - -> V.Vector StageSet - -> V.Vector Cast - -> (VS.Vector Word, VS.Vector Vertex) -populate layers props actors = - (VS.convert *** VS.convert) $ foldl - (\(is, vs) (num, l) -> - let propsHere = V.filter (\(StageSet s) -> residentLayer s == num) props - actorsHere = V.filter (\(Cast c) -> residentLayer c == num) actors - (pisRaw, pvs) = V.foldl - (\(ais, avs) (StageSet s) -> - let (nis, nvs) = toVertices s - in - ( ais V.++ nis - , avs V.++ nvs) - ) - (V.empty, V.empty) - propsHere - (cisRaw, cvs) = V.foldl - (\(ais, avs) (Cast c) -> - let (nis, nvs) = toVertices c - in - ( ais V.++ nis - , avs V.++ nvs) - ) - (V.empty, V.empty) - actorsHere - (lisRaw, lvs) = toVertices l - lis = V.map - (+ if null is then 0 else V.maximum is + 1) - lisRaw - pis = V.map - (+ - if null (is V.++ lis) - then 0 - else V.maximum (is V.++ lis) + 1) - pisRaw - cis = V.map - (+ - if null (is V.++ lis V.++ pis) - then 0 - else V.maximum (is V.++ lis V.++ pis) + 1) - cisRaw - in - ( is V.++ lis V.++ pis V.++ cis - , vs V.++ lvs V.++ pvs V.++ cvs - ) - ) - (V.empty, V.empty) - (V.zip (V.fromList [0 ..]) layers) diff --git a/src/Scenes/Test/Load.hs b/src/Scenes/Test/Load.hs new file mode 100644 index 0000000..06c9b61 --- /dev/null +++ b/src/Scenes/Test/Load.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} +module Scenes.Test.Load where + +import qualified Graphics.Rendering.OpenGL as GL + +import qualified Data.Vector.Storable as VS +import qualified Data.Vector as V + +import Control.Concurrent.STM + +import Control.Monad (void) + +import Linear + +-- internal imports + +import Types +import Classes +import Map +import Scenes.Test.Types +import Scenes.Test.Util + +load + :: Test + -> TMVar Progress + -> IO () +load level progress = do + atomically $ do + void $ takeTMVar progress + putTMVar progress (0, "Loading test level...") + loadedMap <- constructMap testLevelDesc 0 + atomically $ putTMVar (testMap level) loadedMap + void $ atomically $ do + void $ takeTMVar progress + putTMVar progress (0.5, "Loaded test level map!") + void $ atomically $ swapTVar (testLoaded level) True + + let projection = ortho 0 800 0 600 (-1) 1 :: M44 GL.GLfloat + view = mkTransformationMat + (identity :: M33 GL.GLfloat) + (V3 0 ((-64) * 32 + 600) 0) + model = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0) + + vertexArray <- newVertexArray + + bind vertexArray + + vertexBuffer <- newVertexBuffer 1024 + + bind vertexBuffer + + let vertices = VS.fromList (createQuad (V2 (400 - 16) (300 - 16)) 0) + + write vertexBuffer 0 vertices + + indexBuffer <- newIndexBuffer 1024 + + bind indexBuffer + + let indices = VS.fromList [0, 1, 2, 2, 3, 0] + + write indexBuffer 0 indices + + addBuffer (undefined :: Vertex) vertexBuffer + + (_, tex) <- newTexture "res/pituicat/pituicat.png" 1 + bind tex + + shader <- newShader + [ ShaderSource GL.VertexShader "./res/shaders/vert.shader" + , ShaderSource GL.FragmentShader "./res/shaders/frag.shader" + ] + + bind shader + setUniform shader "u_mvp" (projection !*! view !*! model) + setUniformList + shader + "u_textures" + (map + textureSlot + [ (tileMapTexture $ mapTileMap loadedMap) + , tex + ] + ) + + let pituicat = Pituicat + (V2 100 1948) + (V2 0 0) + (V2 0 0) + 100 + tex + + unbind vertexArray + unbind vertexBuffer + unbind indexBuffer + unbind tex + unbind shader + + atomically $ do + putTMVar (testGraphics level) + (GLAssets vertexArray vertexBuffer indexBuffer shader [tex]) + modifyTVar (testCast level) (\cast -> Cast pituicat `V.cons` cast) + writeTVar (testLoaded level) True + + void $ atomically $ do + void $ takeTMVar progress + putTMVar progress (1, "Loaded graphics!") diff --git a/src/Scenes/Test/Types.hs b/src/Scenes/Test/Types.hs new file mode 100644 index 0000000..c0c941b --- /dev/null +++ b/src/Scenes/Test/Types.hs @@ -0,0 +1,25 @@ +module Scenes.Test.Types where + +import Control.Concurrent.STM + +import qualified Data.Vector as V + +-- internal imports + +import Types + +data Test = Test + { testMap :: TMVar LevelMap + , testGraphics :: TMVar GLAssets + , testLoaded :: TVar Bool + , testStageSet :: TVar (V.Vector StageSet) + , testCast :: TVar (V.Vector Cast) + } + +data GLAssets = GLAssets + { glVA :: VertexArray + , glVB :: VertexBuffer + , glIB :: IndexBuffer + , glSP :: Shader + , glTx :: [Texture] + } diff --git a/src/Scenes/Test/Update.hs b/src/Scenes/Test/Update.hs new file mode 100644 index 0000000..eb9faf4 --- /dev/null +++ b/src/Scenes/Test/Update.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} +module Scenes.Test.Update where + +import Affection + +import Control.Concurrent.STM + +import qualified Data.Vector as V + +import Data.String (fromString) + +-- internal imports + +import Scenes.Test.Types +import Classes +import Types + +update + :: Test + -> Double + -> Affection () +update level dt = liftIO $ do + logIO Debug ("FPS: " <> fromString (show $ 1 / dt)) + + -- Let all Actors update themselves and check for collisions + -- (Typeclasses rock!) + atomically $ do + lmap <- readTMVar (testMap level) + let layer = mapLayers lmap V.! fromIntegral (mapWalkLayer lmap) + modifyTVar + (testCast level) $ \cast -> + let playedCast = + V.map + (\(Cast c) -> Cast (perform dt c)) + cast + collidedCast = + (\(Cast c1) (Cast c2) -> + Cast $ + if collisionCheck dt c1 c2 + then collide c1 c2 + else c1 + ) + <$> playedCast <*> playedCast + wallCast (Cast c) = Cast $ + V.foldl + (\member tile -> + if collisionCheck dt member tile + then collide member tile + else member + ) + c + layer + walledCast = + V.map wallCast collidedCast + in + V.map + (\(Cast c) -> Cast $ + move dt c + ) + walledCast diff --git a/src/Scenes/Test/Util.hs b/src/Scenes/Test/Util.hs new file mode 100644 index 0000000..f11f070 --- /dev/null +++ b/src/Scenes/Test/Util.hs @@ -0,0 +1,99 @@ +module Scenes.Test.Util where + +import qualified Graphics.Rendering.OpenGL as GL + +import Linear + +import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS + +import Control.Arrow ((***)) + +-- internal imports + +import Classes +import Types + +testLevelDesc :: LevelDescriptor +testLevelDesc = LevelDescriptor + [ (0, "res/maps/00_test/00_test.bmp") + ] + 0 + "res/tiles/00_test/00_test.png" + (3, 3) + +createQuad :: V2 GL.GLfloat -> Int -> [Vertex] +createQuad (V2 x y) index = + [ newVertex + (V3 x y 0) + (V4 0 0 0 1) + (V2 0 (1 - (50 / 1024))) + (fromIntegral index) + , newVertex + (V3 (x + 32) y 0) + (V4 0 0 0 1) + (V2 (50 / 1024) (1 - (50/1024))) + (fromIntegral index) + , newVertex + (V3 (x + 32) (y + 32) 0) + (V4 0 0 0 1) + (V2 (50 / 1024) 1) + (fromIntegral index) + , newVertex + (V3 x (y + 32) 0) + (V4 0 0 0 1) + (V2 0 1) + (fromIntegral index) + ] + +populate + :: V.Vector Layer + -> V.Vector StageSet + -> V.Vector Cast + -> (VS.Vector Word, VS.Vector Vertex) +populate layers props actors = + (VS.convert *** VS.convert) $ foldl + (\(is, vs) (num, l) -> + let propsHere = V.filter (\(StageSet s) -> residentLayer s == num) props + actorsHere = V.filter (\(Cast c) -> residentLayer c == num) actors + (pisRaw, pvs) = V.foldl + (\(ais, avs) (StageSet s) -> + let (nis, nvs) = toVertices s + in + ( ais V.++ nis + , avs V.++ nvs) + ) + (V.empty, V.empty) + propsHere + (cisRaw, cvs) = V.foldl + (\(ais, avs) (Cast c) -> + let (nis, nvs) = toVertices c + in + ( ais V.++ nis + , avs V.++ nvs) + ) + (V.empty, V.empty) + actorsHere + (lisRaw, lvs) = toVertices l + lis = V.map + (+ if null is then 0 else V.maximum is + 1) + lisRaw + pis = V.map + (+ + if null (is V.++ lis) + then 0 + else V.maximum (is V.++ lis) + 1) + pisRaw + cis = V.map + (+ + if null (is V.++ lis V.++ pis) + then 0 + else V.maximum (is V.++ lis V.++ pis) + 1) + cisRaw + in + ( is V.++ lis V.++ pis V.++ cis + , vs V.++ lvs V.++ pvs V.++ cvs + ) + ) + (V.empty, V.empty) + (V.zip (V.fromList [0 ..]) layers) diff --git a/src/Types/Graphics/Shader.hs b/src/Types/Graphics/Shader.hs index 6b32082..0747ded 100644 --- a/src/Types/Graphics/Shader.hs +++ b/src/Types/Graphics/Shader.hs @@ -3,27 +3,19 @@ module Types.Graphics.Shader where -import SDL (($=), get) - import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.GL as GLRaw -import Data.List as L - import Data.StateVar import qualified Data.ByteString as B -import Data.Maybe (fromJust) - import Control.Concurrent.MVar import Linear -import Foreign.Marshal.Utils (with) import Foreign.Marshal.Array (withArray) import Foreign.Storable -import Foreign.Ptr -- internal imports @@ -54,7 +46,7 @@ data ShaderUniform = ShaderUniform -- orphan instance to make linear's M44 uniforms instance GL.Uniform (M44 GL.GLfloat) where - uniform loc@(GL.UniformLocation ul) = makeStateVar getter setter + uniform (GL.UniformLocation ul) = makeStateVar getter setter where getter = error "cannot implement: get uniform M44 GLfloat" -- GL.withNewMatrix GL.RowMajor $ getUniformWith GLRaw.glGetUniformfv loc @@ -65,7 +57,7 @@ instance GL.Uniform (M44 GL.GLfloat) where (V4 m n o p)) = do mat <- GL.newMatrix GL.RowMajor [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p] :: IO (GL.GLmatrix GL.GLfloat) GL.withMatrix mat $ GLRaw.glUniformMatrix4fv ul 1 . isRowMajor - uniformv (GL.UniformLocation ul) count buf = error "can not implement uniformv for M44 GLfloat" + uniformv (GL.UniformLocation _) _ _ = error "can not implement uniformv for M44 GLfloat" -- GLRaw.glUniformMatrix4fv ul count 0 (castPtr buf `asTypeOf` elemType buf) -- where -- elemType = undefined :: GL.MatrixComponent c => Ptr (GL.GLmatrix c) -> Ptr c diff --git a/src/Types/Graphics/VertexArray.hs b/src/Types/Graphics/VertexArray.hs index 05ecdae..1a552c6 100644 --- a/src/Types/Graphics/VertexArray.hs +++ b/src/Types/Graphics/VertexArray.hs @@ -3,22 +3,11 @@ module Types.Graphics.VertexArray where import qualified Graphics.Rendering.OpenGL as GL -import SDL (($=), get) - -import qualified Data.Vector as V - -import Foreign (sizeOf) -import Foreign.Ptr - -import Control.Concurrent.STM - -import Control.Monad (void) +import SDL (($=)) -- internal imports import Classes.Graphics.Bindable -import Classes.Graphics.Buffer -import Types.Graphics.VertexBuffer newtype VertexArray = VertexArray { vArrId :: GL.VertexArrayObject @@ -29,7 +18,7 @@ instance Bindable VertexArray where bind va = GL.bindVertexArrayObject $= Just (vArrId va) - unbind va = GL.bindVertexArrayObject $= Nothing + unbind _ = GL.bindVertexArrayObject $= Nothing newVertexArray :: IO VertexArray newVertexArray = VertexArray diff --git a/src/Types/Map.hs b/src/Types/Map.hs index 7e2b11f..db79173 100644 --- a/src/Types/Map.hs +++ b/src/Types/Map.hs @@ -29,9 +29,9 @@ instance Drawable Layer where -- type VertexList Layer = V.Vector toVertices vt = V.foldl - (\(acci, accv) (mult, a) -> + (\(acci, accv) (multi, a) -> let (ris, vs) = toVertices a - is = V.map (mult * 4 +) ris + is = V.map (multi * 4 +) ris in (acci V.++ is, accv V.++ vs) ) (V.empty, V.empty) diff --git a/src/Types/Player.hs b/src/Types/Player.hs index 72c8680..43a60c0 100644 --- a/src/Types/Player.hs +++ b/src/Types/Player.hs @@ -108,4 +108,4 @@ instance Collidible Pituicat where Debug ("*boing* meow! other: " <> fromString (show other)) - (elasticCollision 0.3 cat other) + (elasticCollision 0.9 cat other) diff --git a/src/Types/Subsystems.hs b/src/Types/Subsystems.hs index 055d3c6..f677a4b 100644 --- a/src/Types/Subsystems.hs +++ b/src/Types/Subsystems.hs @@ -13,10 +13,14 @@ data Subsystems = Subsystems , subTranslator :: SubTranslator } -newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())]) -newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection ())]) -newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())]) -newtype SubTranslator = SubTranslator (TVar [(UUID, TranslatorMessage -> Affection ())]) +newtype SubWindow = + SubWindow (TVar [(UUID, WindowMessage -> Affection ())]) +newtype SubMouse = + SubMouse (TVar [(UUID, MouseMessage -> Affection ())]) +newtype SubKeyboard = + SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())]) +newtype SubTranslator = + SubTranslator (TVar [(UUID, TranslatorMessage -> Affection ())]) data TranslatorMessage = TranslatorMessage { tmAction :: Action diff --git a/src/Types/Texture.hs b/src/Types/Texture.hs index c1e63d3..99d1aef 100644 --- a/src/Types/Texture.hs +++ b/src/Types/Texture.hs @@ -1,6 +1,6 @@ module Types.Texture where -import SDL (($=), get) +import SDL (($=)) import qualified Graphics.Rendering.OpenGL as GL