make drawables and fix tiles to make it work

This commit is contained in:
nek0 2020-12-14 08:00:06 +01:00
parent 9c2f93a60c
commit c557b9cc3c
10 changed files with 153 additions and 35 deletions

View file

@ -27,6 +27,7 @@ executable pituicat
, 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
@ -34,6 +35,7 @@ executable pituicat
, Classes.Graphics.Bindable , Classes.Graphics.Bindable
, Classes.Graphics.Buffer , Classes.Graphics.Buffer
, Classes.Graphics.VertexLayout , Classes.Graphics.VertexLayout
, Classes.Graphics.Drawable
, Scenes.Test , Scenes.Test
, Map , Map
, StateMachine , StateMachine

View file

@ -5,3 +5,4 @@ module Classes.Graphics
import Classes.Graphics.Bindable as G import Classes.Graphics.Bindable as G
import Classes.Graphics.Buffer as G import Classes.Graphics.Buffer as G
import Classes.Graphics.VertexLayout as G import Classes.Graphics.VertexLayout as G
import Classes.Graphics.Drawable as G

View file

@ -0,0 +1,15 @@
{-# LANGUAGE TypeFamilies #-}
module Classes.Graphics.Drawable where
-- iternal imports
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 :: * -> *
-- | converter function
toVertices :: a -> ((VertexList a) Word, (VertexList a) Vertex)

View file

@ -22,7 +22,7 @@ class Scene a where
isSceneLoaded :: a -> Affection Bool isSceneLoaded :: a -> Affection Bool
-- | Run updates on the data given the time elapsed since last frame -- | Run updates on the data given the time elapsed since last frame
update :: a -> Float -> Affection () update :: a -> Double -> Affection ()
-- | Handle input events -- | Handle input events
onEvents :: a -> [SDL.EventPayload] -> Affection () onEvents :: a -> [SDL.EventPayload] -> Affection ()

View file

@ -6,6 +6,7 @@ import qualified Graphics.Rendering.OpenGL as GL
import Linear import Linear
import Codec.Picture import Codec.Picture
import Codec.Picture.Extra
import qualified Data.Vector as V import qualified Data.Vector as V
@ -17,16 +18,17 @@ import Types
constructMap :: LevelDescriptor -> GL.GLuint -> IO LevelMap constructMap :: LevelDescriptor -> GL.GLuint -> IO LevelMap
constructMap desc tilemapSlot = do constructMap desc tilemapSlot = do
tilemap <- uncurry TileMap <$> newTexture (levelTileMap desc) tilemapSlot
(layers, dimensions) <- foldM (layers, dimensions) <- foldM
(\(layers, dims) descTup -> do (\(layers, dims) descTup -> do
(nlayer, ndims) <- readLayer descTup (nlayer, ndims) <-
readLayer descTup (fmap fromIntegral $ tileMapDimensions tilemap)
if not (null layers) && ndims /= dims if not (null layers) && ndims /= dims
then error ("Map Layer dimensions mismatch in: " <> snd descTup) then error ("Map Layer dimensions mismatch in: " <> snd descTup)
else return (layers ++ [nlayer], ndims) else return (layers ++ [nlayer], ndims)
) )
([], V2 0 0) ([], V2 0 0)
(V.fromList $ levelLayerPath desc) (V.fromList $ levelLayerPath desc)
tilemap <- uncurry TileMap <$> newTexture (levelTileMap desc) tilemapSlot
LevelMap LevelMap
<$> pure (V.fromList layers) <$> pure (V.fromList layers)
<*> pure (levelWalkLayer desc) <*> pure (levelWalkLayer desc)
@ -35,10 +37,11 @@ constructMap desc tilemapSlot = do
<*> pure (V2 (fst $ levelStartPos desc) (snd $ levelStartPos desc)) <*> pure (V2 (fst $ levelStartPos desc) (snd $ levelStartPos desc))
readLayer readLayer
:: (Word, FilePath) -- | index and path of the layer descriptor image :: (Word, FilePath) -- ^ index and path of the layer descriptor image
-> IO (MapLayer, V2 Int) -> V2 Float -- ^ size of Tilemap in pixels
readLayer (idx, path) = do -> IO ((V.Vector Tile), V2 Int)
img <- either error convertRGBA8 <$> readImage path readLayer (idx, path) (V2 tx ty) = do
img <- flipVertically <$> convertRGBA8 <$> either error id <$> readImage path
let width = imageWidth img let width = imageWidth img
height = imageHeight img height = imageHeight img
layer = V.foldl layer = V.foldl
@ -46,7 +49,16 @@ readLayer (idx, path) = do
(PixelRGBA8 r g b _) -> if r >= 253 (PixelRGBA8 r g b _) -> if r >= 253
then then
acc `V.snoc` Tile acc `V.snoc` Tile
(V2 (255 - fromIntegral g) (255 - fromIntegral b)) (V2 (fromIntegral px) (fromIntegral py))
( (V2
((255 - fromIntegral g) * (32 / tx))
(1 - (255 - fromIntegral b + 1) * (32 / ty))
)
, (V2
((255 - fromIntegral g + 1) * (32 / tx))
(1 - (255 - fromIntegral b) * (32 / ty))
)
)
(case r of (case r of
255 -> Solid 255 -> Solid
254 -> Platform 254 -> Platform
@ -57,4 +69,4 @@ readLayer (idx, path) = do
) )
V.empty V.empty
(V.fromList ((,) <$> [0 .. height - 1] <*> [0 .. width - 1])) (V.fromList ((,) <$> [0 .. height - 1] <*> [0 .. width - 1]))
return (MapLayer layer, V2 width height) return (layer, V2 width height)

View file

@ -6,6 +6,9 @@ import Affection
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable as VS
import qualified Data.Vector as V
import Data.String
import Control.Concurrent.STM import Control.Concurrent.STM
@ -24,6 +27,7 @@ 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)
} }
data GLAssets = GLAssets data GLAssets = GLAssets
@ -41,6 +45,7 @@ instance Scene Test where
<$> newEmptyTMVarIO <$> newEmptyTMVarIO
<*> newEmptyTMVarIO <*> newEmptyTMVarIO
<*> newTVarIO False <*> newTVarIO False
<*> newTVarIO V.empty
loadScene level progress = do loadScene level progress = do
atomically $ do atomically $ do
@ -54,7 +59,9 @@ instance Scene Test where
void $ atomically $ swapTVar (testLoaded level) True void $ atomically $ swapTVar (testLoaded level) True
let projection = ortho 0 800 0 600 (-1) 1 :: M44 GL.GLfloat let projection = ortho 0 800 0 600 (-1) 1 :: M44 GL.GLfloat
view = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0) view = mkTransformationMat
(identity :: M33 GL.GLfloat)
(V3 0 ((-64) * 32 + 600) 0)
model = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0) model = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0)
vertexArray <- newVertexArray vertexArray <- newVertexArray
@ -79,7 +86,7 @@ instance Scene Test where
addBuffer (undefined :: Vertex) vertexBuffer addBuffer (undefined :: Vertex) vertexBuffer
(_, tex) <- newTexture "res/pituicat/pituicat.png" 0 (_, tex) <- newTexture "res/pituicat/pituicat.png" 1
bind tex bind tex
@ -110,14 +117,41 @@ instance Scene Test where
isSceneLoaded = liftIO . atomically . readTVar . testLoaded isSceneLoaded = liftIO . atomically . readTVar . testLoaded
update _ _ = return () update level dt = liftIO $ do
logIO Debug ("FPS: " <> fromString (show $ 1 / dt))
(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
bind va
bind vb
write vb 0 (VS.convert vertices)
bind ib
write ib 0 (VS.convert $ V.map fromIntegral indices)
onEvents _ _ = return () onEvents _ _ = return ()
render level = liftIO $ do 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)
bind va bind va
bind tx bind (tileMapTexture tileMap)
R.draw va ib sh R.draw va ib sh
testLevelDesc :: LevelDescriptor testLevelDesc :: LevelDescriptor

View file

@ -36,7 +36,9 @@ instance StateMachine GameData State where
smLoad x _ = error ("State load not yet implemented: " <> show x) smLoad x _ = error ("State load not yet implemented: " <> show x)
smUpdate Loading _ _ = return () smUpdate Loading gd dt = do
(Stage scene) <- liftIO $ atomically $ readTMVar $ gameScene gd
Classes.update scene dt
smUpdate x _ _ = error ("State update not yet implemented: " <> show x) smUpdate x _ _ = error ("State update not yet implemented: " <> show x)

View file

@ -6,3 +6,4 @@ 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

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

View file

@ -1,33 +1,76 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
module Types.Map where module Types.Map where
import Data.Vector import qualified Data.Vector as V
import Linear import Linear
-- internal imports -- internal imports
import Types.Texture import Types.Texture
import Types.Graphics.VertexBuffer
import Classes.Graphics.Drawable
data LevelMap = LevelMap data LevelMap = LevelMap
{ mapLayers :: Vector MapLayer -- | Layer stack { mapLayers :: V.Vector (V.Vector Tile) -- ^ 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)
newtype MapLayer = MapLayer instance Drawable (V.Vector Tile) where
{ layerTiles :: Vector Tile -- | Tiles of this layer
} type VertexList (V.Vector Tile) = V.Vector
deriving (Eq, Show)
toVertices vt = V.foldl
(\(acci, accv) (mult, a) ->
let (ris, vs) = toVertices a
is = V.map (mult * 4 +) ris
in (acci V.++ is, accv V.++ vs)
)
(V.empty, V.empty)
(V.zip (V.fromList [0 ..]) vt)
data Tile = Tile data Tile = Tile
{ tileOffset :: V2 Word -- | Offset of this tile on the tile map { tilePosition :: V2 Word -- ^
, tileType :: TileType -- | Type of tile , tileOffset :: (V2 Float, V2 Float) -- ^ Graphics offset on 'TileMap'
, tileType :: TileType -- ^ Type of tile
} }
deriving (Eq, Show) deriving (Eq, Show)
instance Drawable Tile where
type VertexList Tile = V.Vector
toVertices (Tile (V2 x y) (V2 u1 v1, V2 u2 v2) _) =
( V.fromList [ 0, 1, 2, 2, 3, 0 ]
, V.fromList
[ newVertex
(V3 (fromIntegral x * 32) (fromIntegral y * 32) 0)
(V4 0 0 0 1)
(V2 u1 v1)
(fromIntegral 0)
, newVertex
(V3 (fromIntegral (x + 1) * 32) (fromIntegral y * 32) 0)
(V4 0 0 0 1)
(V2 u2 v1)
(fromIntegral 0)
, newVertex
(V3 (fromIntegral (x + 1) * 32) (fromIntegral (y + 1) * 32) 0)
(V4 0 0 0 1)
(V2 u2 v2)
(fromIntegral 0)
, newVertex
(V3 (fromIntegral x * 32) (fromIntegral (y + 1) * 32) 0)
(V4 0 0 0 1)
(V2 u1 v2)
(fromIntegral 0)
]
)
data TileType data TileType
= Solid = Solid
| Platform | Platform
@ -35,18 +78,18 @@ data TileType
deriving (Enum, Ord, Eq, Show) deriving (Enum, Ord, Eq, Show)
data TileMap = TileMap data TileMap = TileMap
{ tileMapDimensions :: V2 Word -- | Dimensions of tile map image in pixels { tileMapDimensions :: V2 Word -- ^ Dimensions of tile map image in pixels
, tileMapTexture :: Texture -- | Texture object on GPU , tileMapTexture :: Texture -- ^ Texture object on GPU
} }
deriving (Eq, Show) deriving (Eq, Show)
data LevelDescriptor = LevelDescriptor data LevelDescriptor = LevelDescriptor
{ levelLayerPath :: [(Word, FilePath)] -- | Indexed paths to the layers { levelLayerPath :: [(Word, FilePath)] -- ^ Indexed paths to the layers
, levelWalkLayer :: Word -- | Index of walk layer , levelWalkLayer :: Word -- ^ Index of walk layer
, levelTileMap :: FilePath -- | Filepath to tile map , levelTileMap :: FilePath -- ^ Filepath to tile map
, levelStartPos :: (Word, Word) -- | Player start position , levelStartPos :: (Word, Word) -- ^ Player start position
-- , levelCollectibles :: [(V2 Word, ())] -- | TODO; Collectibles and their tile coords -- , levelCollectibles :: [(V2 Word, ())] -- ^ TODO; Collectibles and their tile coords
-- , levelEnemies :: [(V2 Word, ())] -- | TODO: Enemies and their tile coords -- , levelEnemies :: [(V2 Word, ())] -- ^ TODO: Enemies and their tile coords
-- , levelInteractables :: [(V2 Word, ())] -- | TODO: Interactables and their coords -- , levelInteractables :: [(V2 Word, ())] -- ^ TODO: Interactables and their coords
} }
deriving (Eq, Show) deriving (Eq, Show)