make drawables and fix tiles to make it work

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

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

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)

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

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)

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

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)
 

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

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

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)