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

View file

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

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

View file

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

View file

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

View file

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

View file

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

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