From c557b9cc3c9a26bb7214fbd15b35010e6909f65d Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 14 Dec 2020 08:00:06 +0100 Subject: [PATCH] make drawables and fix tiles to make it work --- pituicat.cabal | 2 + src/Classes/Graphics.hs | 1 + src/Classes/Graphics/Drawable.hs | 15 ++++++ src/Classes/Scene.hs | 2 +- src/Map.hs | 28 ++++++++--- src/Scenes/Test.hs | 42 ++++++++++++++-- src/StateMachine.hs | 4 +- src/Types/Graphics.hs | 1 + src/Types/Graphics/Prop.hs | 8 +++ src/Types/Map.hs | 85 ++++++++++++++++++++++++-------- 10 files changed, 153 insertions(+), 35 deletions(-) create mode 100644 src/Classes/Graphics/Drawable.hs create mode 100644 src/Types/Graphics/Prop.hs diff --git a/pituicat.cabal b/pituicat.cabal index 4383cb4..6e08e30 100644 --- a/pituicat.cabal +++ b/pituicat.cabal @@ -27,6 +27,7 @@ executable pituicat , Types.Graphics.VertexBuffer , Types.Graphics.IndexBuffer , Types.Graphics.Shader + , Types.Graphics.Prop , Types.Util , Classes , Classes.Scene @@ -34,6 +35,7 @@ executable pituicat , Classes.Graphics.Bindable , Classes.Graphics.Buffer , Classes.Graphics.VertexLayout + , Classes.Graphics.Drawable , Scenes.Test , Map , StateMachine diff --git a/src/Classes/Graphics.hs b/src/Classes/Graphics.hs index 9295e9a..cbf0779 100644 --- a/src/Classes/Graphics.hs +++ b/src/Classes/Graphics.hs @@ -5,3 +5,4 @@ module Classes.Graphics import Classes.Graphics.Bindable as G import Classes.Graphics.Buffer as G import Classes.Graphics.VertexLayout as G +import Classes.Graphics.Drawable as G diff --git a/src/Classes/Graphics/Drawable.hs b/src/Classes/Graphics/Drawable.hs new file mode 100644 index 0000000..d402878 --- /dev/null +++ b/src/Classes/Graphics/Drawable.hs @@ -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) diff --git a/src/Classes/Scene.hs b/src/Classes/Scene.hs index df9714c..a8e1763 100644 --- a/src/Classes/Scene.hs +++ b/src/Classes/Scene.hs @@ -22,7 +22,7 @@ class Scene a where isSceneLoaded :: a -> Affection Bool -- | Run updates on the data given the time elapsed since last frame - update :: a -> Float -> Affection () + update :: a -> Double -> Affection () -- | Handle input events onEvents :: a -> [SDL.EventPayload] -> Affection () diff --git a/src/Map.hs b/src/Map.hs index 65519dd..9ec933a 100644 --- a/src/Map.hs +++ b/src/Map.hs @@ -6,6 +6,7 @@ import qualified Graphics.Rendering.OpenGL as GL import Linear import Codec.Picture +import Codec.Picture.Extra import qualified Data.Vector as V @@ -17,16 +18,17 @@ import Types constructMap :: LevelDescriptor -> GL.GLuint -> IO LevelMap constructMap desc tilemapSlot = do + tilemap <- uncurry TileMap <$> newTexture (levelTileMap desc) tilemapSlot (layers, dimensions) <- foldM (\(layers, dims) descTup -> do - (nlayer, ndims) <- readLayer descTup + (nlayer, ndims) <- + readLayer descTup (fmap fromIntegral $ tileMapDimensions tilemap) if not (null layers) && ndims /= dims then error ("Map Layer dimensions mismatch in: " <> snd descTup) else return (layers ++ [nlayer], ndims) ) ([], V2 0 0) (V.fromList $ levelLayerPath desc) - tilemap <- uncurry TileMap <$> newTexture (levelTileMap desc) tilemapSlot LevelMap <$> pure (V.fromList layers) <*> pure (levelWalkLayer desc) @@ -35,10 +37,11 @@ constructMap desc tilemapSlot = do <*> pure (V2 (fst $ levelStartPos desc) (snd $ levelStartPos desc)) readLayer - :: (Word, FilePath) -- | index and path of the layer descriptor image - -> IO (MapLayer, V2 Int) -readLayer (idx, path) = do - img <- either error convertRGBA8 <$> readImage path + :: (Word, FilePath) -- ^ index and path of the layer descriptor image + -> V2 Float -- ^ size of Tilemap in pixels + -> IO ((V.Vector Tile), V2 Int) +readLayer (idx, path) (V2 tx ty) = do + img <- flipVertically <$> convertRGBA8 <$> either error id <$> readImage path let width = imageWidth img height = imageHeight img layer = V.foldl @@ -46,7 +49,16 @@ readLayer (idx, path) = do (PixelRGBA8 r g b _) -> if r >= 253 then 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 255 -> Solid 254 -> Platform @@ -57,4 +69,4 @@ readLayer (idx, path) = do ) V.empty (V.fromList ((,) <$> [0 .. height - 1] <*> [0 .. width - 1])) - return (MapLayer layer, V2 width height) + return (layer, V2 width height) diff --git a/src/Scenes/Test.hs b/src/Scenes/Test.hs index ebca77c..f5059b3 100644 --- a/src/Scenes/Test.hs +++ b/src/Scenes/Test.hs @@ -6,6 +6,9 @@ import Affection import qualified Graphics.Rendering.OpenGL as GL import qualified Data.Vector.Storable as VS +import qualified Data.Vector as V + +import Data.String import Control.Concurrent.STM @@ -24,6 +27,7 @@ data Test = Test { testMap :: TMVar LevelMap , testGraphics :: TMVar GLAssets , testLoaded :: TVar Bool + , testProps :: TVar (V.Vector Prop) } data GLAssets = GLAssets @@ -41,6 +45,7 @@ instance Scene Test where <$> newEmptyTMVarIO <*> newEmptyTMVarIO <*> newTVarIO False + <*> newTVarIO V.empty loadScene level progress = do atomically $ do @@ -54,7 +59,9 @@ instance Scene Test where void $ atomically $ swapTVar (testLoaded level) True 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) vertexArray <- newVertexArray @@ -79,7 +86,7 @@ instance Scene Test where addBuffer (undefined :: Vertex) vertexBuffer - (_, tex) <- newTexture "res/pituicat/pituicat.png" 0 + (_, tex) <- newTexture "res/pituicat/pituicat.png" 1 bind tex @@ -110,14 +117,41 @@ instance Scene Test where 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 () render level = liftIO $ do (GLAssets va vb ib sh tx) <- atomically (readTMVar $ testGraphics level) + (LevelMap layers _ _ tileMap _) <- atomically (readTMVar $ testMap level) bind va - bind tx + bind (tileMapTexture tileMap) R.draw va ib sh testLevelDesc :: LevelDescriptor diff --git a/src/StateMachine.hs b/src/StateMachine.hs index 881434c..e4833f5 100644 --- a/src/StateMachine.hs +++ b/src/StateMachine.hs @@ -36,7 +36,9 @@ instance StateMachine GameData State where 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) diff --git a/src/Types/Graphics.hs b/src/Types/Graphics.hs index 1dde1a0..f6b3afd 100644 --- a/src/Types/Graphics.hs +++ b/src/Types/Graphics.hs @@ -6,3 +6,4 @@ 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 new file mode 100644 index 0000000..1d3a5f8 --- /dev/null +++ b/src/Types/Graphics/Prop.hs @@ -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 diff --git a/src/Types/Map.hs b/src/Types/Map.hs index 159d55c..888c215 100644 --- a/src/Types/Map.hs +++ b/src/Types/Map.hs @@ -1,33 +1,76 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} module Types.Map where -import Data.Vector +import qualified Data.Vector as V import Linear -- internal imports import Types.Texture +import Types.Graphics.VertexBuffer +import Classes.Graphics.Drawable data LevelMap = LevelMap - { mapLayers :: Vector MapLayer -- | 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 (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 } deriving (Eq, Show) -newtype MapLayer = MapLayer - { layerTiles :: Vector Tile -- | Tiles of this layer - } - deriving (Eq, Show) +instance Drawable (V.Vector Tile) where + + type VertexList (V.Vector Tile) = V.Vector + + 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 - { tileOffset :: V2 Word -- | Offset of this tile on the tile map - , tileType :: TileType -- | Type of tile + { tilePosition :: V2 Word -- ^ + , tileOffset :: (V2 Float, V2 Float) -- ^ Graphics offset on 'TileMap' + , tileType :: TileType -- ^ Type of tile } 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 = Solid | Platform @@ -35,18 +78,18 @@ data TileType deriving (Enum, Ord, Eq, Show) data TileMap = TileMap - { tileMapDimensions :: V2 Word -- | Dimensions of tile map image in pixels - , tileMapTexture :: Texture -- | Texture object on GPU + { tileMapDimensions :: V2 Word -- ^ Dimensions of tile map image in pixels + , tileMapTexture :: Texture -- ^ Texture object on GPU } deriving (Eq, Show) data LevelDescriptor = LevelDescriptor - { levelLayerPath :: [(Word, FilePath)] -- | Indexed paths to the layers - , levelWalkLayer :: Word -- | Index of walk layer - , levelTileMap :: FilePath -- | Filepath to tile map - , levelStartPos :: (Word, Word) -- | Player start position - -- , levelCollectibles :: [(V2 Word, ())] -- | TODO; Collectibles and their tile coords - -- , levelEnemies :: [(V2 Word, ())] -- | TODO: Enemies and their tile coords - -- , levelInteractables :: [(V2 Word, ())] -- | TODO: Interactables and their coords + { levelLayerPath :: [(Word, FilePath)] -- ^ Indexed paths to the layers + , levelWalkLayer :: Word -- ^ Index of walk layer + , levelTileMap :: FilePath -- ^ Filepath to tile map + , levelStartPos :: (Word, Word) -- ^ Player start position + -- , levelCollectibles :: [(V2 Word, ())] -- ^ TODO; Collectibles and their tile coords + -- , levelEnemies :: [(V2 Word, ())] -- ^ TODO: Enemies and their tile coords + -- , levelInteractables :: [(V2 Word, ())] -- ^ TODO: Interactables and their coords } deriving (Eq, Show)