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

View file

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

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 #-}
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)

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.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)

View file

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

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.IndexBuffer 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
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 ]

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