preparations for populating the stage with actors and props

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

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

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

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)

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

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)

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

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

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

src/Types/Graphics/Prop.hs

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

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 ]

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