From c2fb8cd922032e24962bc3aef65d5428c5361957 Mon Sep 17 00:00:00 2001
From: "Juan J. Martinez" <jjm@usebox.net>
Date: Thu, 9 Feb 2023 17:41:31 +0000
Subject: Object layer support for map entities

---
 src/Game/Map.hs | 91 +++++++++++++++++++++++++++++++++++++++++++--------------
 1 file changed, 69 insertions(+), 22 deletions(-)

(limited to 'src')

diff --git a/src/Game/Map.hs b/src/Game/Map.hs
index 94478bd..b872f4c 100644
--- a/src/Game/Map.hs
+++ b/src/Game/Map.hs
@@ -7,6 +7,7 @@ module Game.Map
 where
 
 import Control.Monad
+import Data.Maybe (mapMaybe)
 import qualified Game.Utils as U
 import qualified SDL
 import Text.JSON
@@ -20,22 +21,23 @@ data Tileset = Tileset
   }
   deriving (Show)
 
-data TileLayer = TileLayer
-  { name :: String,
-    tiles :: [Int]
-  }
+data Layer
+  = TileLayer
+      {name :: String, tiles :: [Int]}
+  | ObjectLayer
+      {name :: String, objects :: [MapObject]}
   deriving (Show)
 
-data MapData = MapData
+data MapObject = PlayerEntity Int Int deriving (Show)
+
+data JsonMapData = JsonMapData
   { width :: Int,
     height :: Int,
     tileset :: Tileset,
-    layers :: [TileLayer]
+    layers :: [Layer]
   }
   deriving (Show)
 
-data Map = Map MapData SDL.Texture
-
 instance JSON Tileset where
   showJSON = undefined
   readJSON (JSArray [JSObject obj]) = do
@@ -46,42 +48,87 @@ instance JSON Tileset where
       <*> valFromObj "firstgid" obj
   readJSON _ = mzero
 
-instance JSON TileLayer where
+instance JSON Layer where
   showJSON = undefined
   readJSON (JSObject obj) =
     case get_field obj "type" of
       Just "tilelayer" ->
-        TileLayer
-          <$> valFromObj "name" obj
-          <*> valFromObj "data" obj
+        TileLayer <$> valFromObj "name" obj <*> valFromObj "data" obj
+      Just "objectgroup" ->
+        ObjectLayer <$> valFromObj "name" obj <*> valFromObj "objects" obj
       _ -> Error "unsupported layer type"
   readJSON _ = mzero
 
-instance JSON MapData where
+instance JSON MapObject where
   showJSON = undefined
   readJSON (JSObject obj) =
-    MapData
+    case get_field obj "name" of
+      Just "Player" ->
+        PlayerEntity <$> valFromObj "x" obj <*> valFromObj "y" obj
+      Just (JSString (JSONString s)) -> Error $ "unsupported entity " ++ show s
+      e -> Error $ "unsupported entity in " ++ show e
+  readJSON _ = mzero
+
+instance JSON JsonMapData where
+  showJSON = undefined
+  readJSON (JSObject obj) =
+    JsonMapData
       <$> valFromObj "width" obj
       <*> valFromObj "height" obj
       <*> valFromObj "tilesets" obj
       <*> valFromObj "layers" obj
   readJSON _ = mzero
 
+data MapData = MapData
+  { width :: Int,
+    height :: Int,
+    tileset :: Tileset,
+    tileLayers :: [[Int]],
+    blocked :: [Int],
+    objects :: [MapObject]
+  }
+  deriving (Show)
+
+data Map = Map MapData SDL.Texture
+
 -- | Loads a map from a JSON file.
 load :: String -> SDL.Texture -> IO Map
 load filename tex = do
   d <- readFile filename
-  case decode d :: Result MapData of
-    Ok s -> pure $ Map s tex
+  case decode d :: Result JsonMapData of
+    Ok s -> do
+      let tileLayers = mapMaybe (filterTileLayer (\l -> l.name /= "Blocked")) s.layers
+          blockedLayers = mapMaybe (filterTileLayer (\l -> l.name == "Blocked")) s.layers
+      blockedLayer <- case blockedLayers of
+        [l] -> pure l
+        xs -> error $ "1 \"Blocked\" layer expected, " ++ show (length xs) ++ " found"
+      pure $
+        Map
+          MapData
+            { width = s.width,
+              height = s.height,
+              tileset = s.tileset,
+              tileLayers = tileLayers,
+              blocked = blockedLayer,
+              objects = concat $ mapMaybe filterObjectLayer s.layers
+            }
+          tex
     Error e -> error e
+  where
+    filterTileLayer :: (Layer -> Bool) -> Layer -> Maybe [Int]
+    filterTileLayer f l = case l of
+      TileLayer _ tiles -> if f l then Just tiles else Nothing
+      _ -> Nothing
+    filterObjectLayer :: Layer -> Maybe [MapObject]
+    filterObjectLayer l = case l of
+      ObjectLayer _ objs -> Just objs
+      _ -> Nothing
 
--- | Check for collision detection vs "Blocked" TileLayer that MUST be last layer.
+-- | Check for collision detection vs "Blocked" TileLayer.
 --   x and y in pixels.
 isBlocked :: Map -> Int -> Int -> Bool
-isBlocked (Map (MapData mapWidth _ ts ls) _) x y =
+isBlocked (Map (MapData mapWidth _ ts _ blocked _) _) x y =
   blocked !! ((x `div` ts.width) + (y `div` ts.height) * mapWidth) >= ts.firstGid
-  where
-    blocked = (last ls).tiles
 
 -- | Renders a map.
 render :: SDL.Renderer -> Map -> IO ()
@@ -90,11 +137,11 @@ render renderer (Map mapData tex) = do
     ( \layer ->
         mapM_
           ( \(x, y) ->
-              renderTile x y $ layer.tiles !! (x + (y * mapData.width))
+              renderTile x y $ layer !! (x + (y * mapData.width))
           )
           index
     )
-    (init $ mapData.layers)
+    mapData.tileLayers
   where
     index = [(x, y) | x <- [0 .. mapData.width - 1], y <- [0 .. mapData.height - 1]]
 
-- 
cgit v1.2.3