From 5c90eee84aaa6165eeabb1a191b4c1b4db0257b0 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 16 Dec 2020 18:57:37 +0100 Subject: [PATCH] preparations for populating the stage with actors and props --- pituicat.cabal | 5 +- src/Classes.hs | 2 + src/Classes/Actor.hs | 9 +++ src/Classes/Graphics/Drawable.hs | 9 ++- src/Classes/Prop.hs | 9 +++ src/Scenes/Test.hs | 96 +++++++++++++++++++++++--------- src/Types.hs | 2 + src/Types/Cast.hs | 8 +++ src/Types/Graphics.hs | 1 - src/Types/Graphics/Prop.hs | 8 --- src/Types/Map.hs | 18 +++--- src/Types/StageSet.hs | 8 +++ 12 files changed, 129 insertions(+), 46 deletions(-) create mode 100644 src/Classes/Actor.hs create mode 100644 src/Classes/Prop.hs create mode 100644 src/Types/Cast.hs delete mode 100644 src/Types/Graphics/Prop.hs create mode 100644 src/Types/StageSet.hs diff --git a/pituicat.cabal b/pituicat.cabal index 6e08e30..99d846a 100644 --- a/pituicat.cabal +++ b/pituicat.cabal @@ -22,15 +22,18 @@ executable pituicat , Types.Subsystems , Types.Map , Types.Texture + , Types.Cast + , Types.StageSet , Types.Graphics , Types.Graphics.VertexArray , Types.Graphics.VertexBuffer , Types.Graphics.IndexBuffer , Types.Graphics.Shader - , Types.Graphics.Prop , Types.Util , Classes , Classes.Scene + , Classes.Actor + , Classes.Prop , Classes.Graphics , Classes.Graphics.Bindable , Classes.Graphics.Buffer diff --git a/src/Classes.hs b/src/Classes.hs index 57bee54..9627806 100644 --- a/src/Classes.hs +++ b/src/Classes.hs @@ -4,3 +4,5 @@ module Classes import Classes.Graphics as C import Classes.Scene as C +import Classes.Prop as C +import Classes.Actor as C diff --git a/src/Classes/Actor.hs b/src/Classes/Actor.hs new file mode 100644 index 0000000..fc74c88 --- /dev/null +++ b/src/Classes/Actor.hs @@ -0,0 +1,9 @@ +module Classes.Actor where + +-- internal imports + +import Classes.Prop + +class (Prop a) => Actor a where + + perform :: Double -> a -> a diff --git a/src/Classes/Graphics/Drawable.hs b/src/Classes/Graphics/Drawable.hs index d402878..1a3862a 100644 --- a/src/Classes/Graphics/Drawable.hs +++ b/src/Classes/Graphics/Drawable.hs @@ -1,6 +1,8 @@ {-# LANGUAGE TypeFamilies #-} module Classes.Graphics.Drawable where +import qualified Data.Vector as V + -- iternal imports import Types.Graphics.VertexBuffer (Vertex) @@ -8,8 +10,9 @@ import Types.Graphics.VertexBuffer (Vertex) -- | A typeclass for all drawable objects class Drawable a where - -- | List type for resulting vertices and indices - type VertexList a :: * -> * + -- -- | List type for resulting vertices and indices + -- type VertexList a :: * -> * -- | converter function - toVertices :: a -> ((VertexList a) Word, (VertexList a) Vertex) + -- toVertices :: a -> ((VertexList a) Word, (VertexList a) Vertex) + toVertices :: a -> (V.Vector Word, V.Vector Vertex) diff --git a/src/Classes/Prop.hs b/src/Classes/Prop.hs new file mode 100644 index 0000000..ba9a9ab --- /dev/null +++ b/src/Classes/Prop.hs @@ -0,0 +1,9 @@ +module Classes.Prop where + +-- internal imports + +import Classes.Graphics.Drawable + +class (Drawable a) => Prop a where + + residentLayer :: a -> Word diff --git a/src/Scenes/Test.hs b/src/Scenes/Test.hs index f5059b3..818c31f 100644 --- a/src/Scenes/Test.hs +++ b/src/Scenes/Test.hs @@ -12,6 +12,8 @@ import Data.String import Control.Concurrent.STM +import Control.Arrow ((***)) + import Control.Monad (void) import Linear @@ -27,7 +29,8 @@ data Test = Test { testMap :: TMVar LevelMap , testGraphics :: TMVar GLAssets , testLoaded :: TVar Bool - , testProps :: TVar (V.Vector Prop) + , testStageSet :: TVar (V.Vector StageSet) + , testCast :: TVar (V.Vector Cast) } data GLAssets = GLAssets @@ -46,6 +49,7 @@ instance Scene Test where <*> newEmptyTMVarIO <*> newTVarIO False <*> newTVarIO V.empty + <*> newTVarIO V.empty loadScene level progress = do atomically $ do @@ -119,22 +123,20 @@ instance Scene Test where update level dt = liftIO $ do logIO Debug ("FPS: " <> fromString (show $ 1 / dt)) + + + onEvents _ _ = return () + + render level = liftIO $ do (GLAssets va vb ib sh tx) <- atomically (readTMVar $ testGraphics level) - (LevelMap layers _ _ tileMap _) <- atomically (readTMVar $ testMap level) - let (indices, vertices) = V.foldl - (\(acci, accv) a -> - let (ris, vs) = toVertices a - is = V.map - (\i -> i + - if V.null acci - then 0 - else (maximum acci + 1) - ) - ris - in (acci V.++ is, accv V.++ vs) - ) - (V.empty, V.empty) - layers + (LevelMap layers _ _ tileMap _) <- + atomically (readTMVar $ testMap level) + + stageSet <- atomically (readTVar $ testStageSet level) + cast <- atomically (readTVar $ testCast level) + + let (indices, vertices) = populate layers stageSet cast + bind va bind vb @@ -142,15 +144,7 @@ instance Scene Test where bind ib - write ib 0 (VS.convert $ V.map fromIntegral indices) - - - onEvents _ _ = return () - - render level = liftIO $ do - (GLAssets va vb ib sh tx) <- atomically (readTMVar $ testGraphics level) - (LevelMap layers _ _ tileMap _) <- atomically (readTMVar $ testMap level) - bind va + write ib 0 (VS.map fromIntegral indices) bind (tileMapTexture tileMap) R.draw va ib sh @@ -185,3 +179,55 @@ createQuad (V2 x y) index = (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) + lisRaw + pis = V.map + (+ + if null (is V.++ lis) + then 0 + else V.maximum (is V.++ lis)) + pisRaw + cis = V.map + (+ + if null (is V.++ lis V.++ pis) + then 0 + else V.maximum (is V.++ lis V.++ pis)) + 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.hs b/src/Types.hs index b6690e4..dc496ec 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -6,5 +6,7 @@ import Types.Application as T import Types.Subsystems as T import Types.Map as T import Types.Texture as T +import Types.Cast as T +import Types.StageSet as T import Types.Graphics as T import Types.Util as T diff --git a/src/Types/Cast.hs b/src/Types/Cast.hs new file mode 100644 index 0000000..8251e20 --- /dev/null +++ b/src/Types/Cast.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Types.Cast where + +-- internale imports + +import Classes.Actor + +data Cast = forall a. Actor a => Cast a diff --git a/src/Types/Graphics.hs b/src/Types/Graphics.hs index f6b3afd..1dde1a0 100644 --- a/src/Types/Graphics.hs +++ b/src/Types/Graphics.hs @@ -6,4 +6,3 @@ import Types.Graphics.VertexArray as G import Types.Graphics.VertexBuffer as G import Types.Graphics.IndexBuffer as G import Types.Graphics.Shader as G -import Types.Graphics.Prop as G diff --git a/src/Types/Graphics/Prop.hs b/src/Types/Graphics/Prop.hs deleted file mode 100644 index 1d3a5f8..0000000 --- a/src/Types/Graphics/Prop.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -module Types.Graphics.Prop where - --- internal imports - -import Classes.Graphics.Drawable - -data Prop = forall a. Drawable a => Prop a diff --git a/src/Types/Map.hs b/src/Types/Map.hs index 888c215..a2d2a40 100644 --- a/src/Types/Map.hs +++ b/src/Types/Map.hs @@ -13,17 +13,19 @@ import Types.Graphics.VertexBuffer import Classes.Graphics.Drawable data LevelMap = LevelMap - { mapLayers :: V.Vector (V.Vector Tile) -- ^ Layer stack - , mapWalkLayer :: Word -- ^ Collision layer index in stack - , mapDimensions :: V2 Word -- ^ Dimension of map in tiles - , mapTileMap :: TileMap -- ^ The tile map - , mapStartPos :: V2 Word -- ^ Player start position + { mapLayers :: V.Vector Layer -- ^ Layer stack + , mapWalkLayer :: Word -- ^ Collision layer index in stack + , mapDimensions :: V2 Word -- ^ Dimension of map in tiles + , mapTileMap :: TileMap -- ^ The tile map + , mapStartPos :: V2 Word -- ^ Player start position } deriving (Eq, Show) -instance Drawable (V.Vector Tile) where +type Layer = V.Vector Tile - type VertexList (V.Vector Tile) = V.Vector +instance Drawable Layer where + + -- type VertexList Layer = V.Vector toVertices vt = V.foldl (\(acci, accv) (mult, a) -> @@ -43,7 +45,7 @@ data Tile = Tile instance Drawable Tile where - type VertexList Tile = V.Vector + -- type VertexList Tile = V.Vector toVertices (Tile (V2 x y) (V2 u1 v1, V2 u2 v2) _) = ( V.fromList [ 0, 1, 2, 2, 3, 0 ] diff --git a/src/Types/StageSet.hs b/src/Types/StageSet.hs new file mode 100644 index 0000000..12f0339 --- /dev/null +++ b/src/Types/StageSet.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Types.StageSet where + +-- internal imports + +import Classes.Prop + +data StageSet = forall a. Prop a => StageSet a