preparations for populating the stage with actors and props

This commit is contained in:
nek0 2020-12-16 18:57:37 +01:00
parent 3873c62f17
commit 5c90eee84a
12 changed files with 129 additions and 46 deletions

View file

@ -22,15 +22,18 @@ executable pituicat
, Types.Subsystems , Types.Subsystems
, Types.Map , Types.Map
, Types.Texture , Types.Texture
, Types.Cast
, Types.StageSet
, Types.Graphics , Types.Graphics
, Types.Graphics.VertexArray , Types.Graphics.VertexArray
, Types.Graphics.VertexBuffer , Types.Graphics.VertexBuffer
, Types.Graphics.IndexBuffer , Types.Graphics.IndexBuffer
, Types.Graphics.Shader , Types.Graphics.Shader
, Types.Graphics.Prop
, Types.Util , Types.Util
, Classes , Classes
, Classes.Scene , Classes.Scene
, Classes.Actor
, Classes.Prop
, Classes.Graphics , Classes.Graphics
, Classes.Graphics.Bindable , Classes.Graphics.Bindable
, Classes.Graphics.Buffer , Classes.Graphics.Buffer

View file

@ -4,3 +4,5 @@ module Classes
import Classes.Graphics as C import Classes.Graphics as C
import Classes.Scene as C import Classes.Scene as C
import Classes.Prop as C
import Classes.Actor as C

9
src/Classes/Actor.hs Normal file
View file

@ -0,0 +1,9 @@
module Classes.Actor where
-- internal imports
import Classes.Prop
class (Prop a) => Actor a where
perform :: Double -> a -> a

View file

@ -1,6 +1,8 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Classes.Graphics.Drawable where module Classes.Graphics.Drawable where
import qualified Data.Vector as V
-- iternal imports -- iternal imports
import Types.Graphics.VertexBuffer (Vertex) import Types.Graphics.VertexBuffer (Vertex)
@ -8,8 +10,9 @@ import Types.Graphics.VertexBuffer (Vertex)
-- | A typeclass for all drawable objects -- | A typeclass for all drawable objects
class Drawable a where class Drawable a where
-- | List type for resulting vertices and indices -- -- | List type for resulting vertices and indices
type VertexList a :: * -> * -- type VertexList a :: * -> *
-- | converter function -- | 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)

9
src/Classes/Prop.hs Normal file
View file

@ -0,0 +1,9 @@
module Classes.Prop where
-- internal imports
import Classes.Graphics.Drawable
class (Drawable a) => Prop a where
residentLayer :: a -> Word

View file

@ -12,6 +12,8 @@ import Data.String
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Arrow ((***))
import Control.Monad (void) import Control.Monad (void)
import Linear import Linear
@ -27,7 +29,8 @@ data Test = Test
{ testMap :: TMVar LevelMap { testMap :: TMVar LevelMap
, testGraphics :: TMVar GLAssets , testGraphics :: TMVar GLAssets
, testLoaded :: TVar Bool , testLoaded :: TVar Bool
, testProps :: TVar (V.Vector Prop) , testStageSet :: TVar (V.Vector StageSet)
, testCast :: TVar (V.Vector Cast)
} }
data GLAssets = GLAssets data GLAssets = GLAssets
@ -46,6 +49,7 @@ instance Scene Test where
<*> newEmptyTMVarIO <*> newEmptyTMVarIO
<*> newTVarIO False <*> newTVarIO False
<*> newTVarIO V.empty <*> newTVarIO V.empty
<*> newTVarIO V.empty
loadScene level progress = do loadScene level progress = do
atomically $ do atomically $ do
@ -119,22 +123,20 @@ instance Scene Test where
update level dt = liftIO $ do update level dt = liftIO $ do
logIO Debug ("FPS: " <> fromString (show $ 1 / dt)) logIO Debug ("FPS: " <> fromString (show $ 1 / dt))
onEvents _ _ = return ()
render level = liftIO $ do
(GLAssets va vb ib sh tx) <- atomically (readTMVar $ testGraphics level) (GLAssets va vb ib sh tx) <- atomically (readTMVar $ testGraphics level)
(LevelMap layers _ _ tileMap _) <- atomically (readTMVar $ testMap level) (LevelMap layers _ _ tileMap _) <-
let (indices, vertices) = V.foldl atomically (readTMVar $ testMap level)
(\(acci, accv) a ->
let (ris, vs) = toVertices a stageSet <- atomically (readTVar $ testStageSet level)
is = V.map cast <- atomically (readTVar $ testCast level)
(\i -> i +
if V.null acci let (indices, vertices) = populate layers stageSet cast
then 0
else (maximum acci + 1)
)
ris
in (acci V.++ is, accv V.++ vs)
)
(V.empty, V.empty)
layers
bind va bind va
bind vb bind vb
@ -142,15 +144,7 @@ instance Scene Test where
bind ib bind ib
write ib 0 (VS.convert $ V.map fromIntegral indices) write ib 0 (VS.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
bind (tileMapTexture tileMap) bind (tileMapTexture tileMap)
R.draw va ib sh R.draw va ib sh
@ -185,3 +179,55 @@ createQuad (V2 x y) index =
(V2 0 1) (V2 0 1)
(fromIntegral index) (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)

View file

@ -6,5 +6,7 @@ import Types.Application as T
import Types.Subsystems as T import Types.Subsystems as T
import Types.Map as T import Types.Map as T
import Types.Texture as T import Types.Texture as T
import Types.Cast as T
import Types.StageSet as T
import Types.Graphics as T import Types.Graphics as T
import Types.Util as T import Types.Util as T

8
src/Types/Cast.hs Normal file
View file

@ -0,0 +1,8 @@
{-# LANGUAGE ExistentialQuantification #-}
module Types.Cast where
-- internale imports
import Classes.Actor
data Cast = forall a. Actor a => Cast a

View file

@ -6,4 +6,3 @@ import Types.Graphics.VertexArray as G
import Types.Graphics.VertexBuffer as G import Types.Graphics.VertexBuffer as G
import Types.Graphics.IndexBuffer as G import Types.Graphics.IndexBuffer as G
import Types.Graphics.Shader as G import Types.Graphics.Shader as G
import Types.Graphics.Prop as G

View file

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

View file

@ -13,17 +13,19 @@ import Types.Graphics.VertexBuffer
import Classes.Graphics.Drawable import Classes.Graphics.Drawable
data LevelMap = LevelMap data LevelMap = LevelMap
{ mapLayers :: V.Vector (V.Vector Tile) -- ^ Layer stack { mapLayers :: V.Vector Layer -- ^ Layer stack
, mapWalkLayer :: Word -- ^ Collision layer index in stack , mapWalkLayer :: Word -- ^ Collision layer index in stack
, mapDimensions :: V2 Word -- ^ Dimension of map in tiles , mapDimensions :: V2 Word -- ^ Dimension of map in tiles
, mapTileMap :: TileMap -- ^ The tile map , mapTileMap :: TileMap -- ^ The tile map
, mapStartPos :: V2 Word -- ^ Player start position , mapStartPos :: V2 Word -- ^ Player start position
} }
deriving (Eq, Show) 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 toVertices vt = V.foldl
(\(acci, accv) (mult, a) -> (\(acci, accv) (mult, a) ->
@ -43,7 +45,7 @@ data Tile = Tile
instance Drawable Tile where 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) _) = toVertices (Tile (V2 x y) (V2 u1 v1, V2 u2 v2) _) =
( V.fromList [ 0, 1, 2, 2, 3, 0 ] ( V.fromList [ 0, 1, 2, 2, 3, 0 ]

8
src/Types/StageSet.hs Normal file
View file

@ -0,0 +1,8 @@
{-# LANGUAGE ExistentialQuantification #-}
module Types.StageSet where
-- internal imports
import Classes.Prop
data StageSet = forall a. Prop a => StageSet a