From bbde46e7db5fa23015ba09128efb27f6b7342675 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sat, 4 Dec 2021 12:56:33 +0100
Subject: handle text objects in objectgroup layers

---
 lib/Properties.hs | 37 +++++++++++++++++++++----------------
 lib/Tiled.hs      | 22 ++++++++++++++++------
 2 files changed, 37 insertions(+), 22 deletions(-)

(limited to 'lib')

diff --git a/lib/Properties.hs b/lib/Properties.hs
index c9c704a..ba78fca 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -24,6 +24,7 @@ import           Badges        (Badge (Badge),
                                 BadgeArea (BadgePoint, BadgeRect), BadgeToken,
                                 parseToken)
 import           Data.Data     (Proxy (Proxy))
+import           Data.Functor  ((<&>))
 import           Data.Maybe    (fromMaybe, isJust)
 import           Data.Set      (Set)
 import qualified Data.Set      as S
@@ -164,27 +165,30 @@ checkLayer = do
     "tilelayer" -> mapM_ checkTileLayerProperty (getProperties layer)
     "group" -> pure ()
     "objectgroup" -> do
-      -- TODO: this still retains object group layers, just empties them out.
-      -- perhaps actually delete the entire layer, since this still leaves hints
-      -- as to where badges are?
-      adjust $ \l -> l { layerObjects = Nothing, layerProperties = Nothing }
 
-      unless (layerName layer == "floorLayer") $ do
+      -- all objects which can't define badges, i.e. only texts
+      publicObjects <- askContext <&>
+        fmap (V.filter (\case {ObjectText {} -> True; _ -> False})) . layerObjects
 
-        -- TODO: these two checks can probably be unified
-        unlessHasProperty "getBadge"
-          $ warn "objectgrouop layer (which aren't the floor layer)\
-                 \are useless if not used to define badges."
+      -- filter everything out that might define badges, but keep text
+      -- objects, which workadventure apparently supports but doesn't
+      -- really tell anyone about.
+      adjust $ \l -> l { layerObjects = publicObjects
+                       , layerProperties = Nothing }
 
-        when (null (layerObjects layer) || layerObjects layer == Just mempty)
-          $ warn "empty objectgroup layers (which aren't the floor\
-                 \layer) are useless."
+      unless (layerName layer == "floorLayer") $
+        unlessHasProperty "getBadge" $
+          when (null publicObjects || publicObjects == Just mempty) $
+            warn "objectgroup layer (which aren't the floor layer) \
+                 \are useless if they do not contain the \"getBadge\" \
+                 \property and define at least one area for this badge, \
+                 \or do not contain at least one text element."
 
       -- individual objects can't have properties
       forM_ (fromMaybe mempty (layerObjects layer)) $ \object ->
         unless (null (objectProperties object))
-          $ warn "Properties cannot be set on individual objects. For setting\
-                 \badge tokens, use per-layer properties instead."
+          $ warn "Properties cannot be set on individual objects. For \
+                 \setting badge tokens, use per-layer properties instead."
 
       forM_ (getProperties layer) checkObjectGroupProperty
     ty -> complain $ "unsupported layer type " <> prettyprint ty <> "."
@@ -213,8 +217,9 @@ checkObjectGroupProperty p@(Property name _) = case name of
                       objectX objectY
                       objectWidth objectHeight
                       (objectEllipse == Just True)
-            ObjectPolygon {} -> complain "cannot use polygons for badges."
-            ObjectPolyline {} -> complain "cannot use polylines for badges."
+            ObjectPolygon {} -> complain "polygons are not supported."
+            ObjectPolyline {} -> complain "polylines are not supported."
+            ObjectText {} -> complain "cannot use texts to define badge areas."
   _ -> warn $ "unknown property " <> prettyprint name <> " for objectgroup layers"
 
 
diff --git a/lib/Tiled.hs b/lib/Tiled.hs
index 9df52d3..05839a7 100644
--- a/lib/Tiled.hs
+++ b/lib/Tiled.hs
@@ -121,7 +121,6 @@ data Object = ObjectPoint
   , objectWidth      :: Double
   , objectRotation   :: Double
   , objectGid        :: Maybe GlobalId
-  , objectText       :: Maybe Text
   , objectType       :: Text
   , objectPoint      :: Bool
   }
@@ -134,7 +133,6 @@ data Object = ObjectPoint
   , objectY          :: Double
   , objectRotation   :: Double
   , objectGid        :: Maybe GlobalId
-  , objectText       :: Maybe Text
   , objectWidth      :: Double
   , objectHeight     :: Double
   , objectEllipse    :: Maybe Bool
@@ -149,7 +147,6 @@ data Object = ObjectPoint
   , objectY          :: Double
   , objectRotation   :: Double
   , objectGid        :: Maybe GlobalId
-  , objectText       :: Maybe Text
   , objectWidth      :: Double
   , objectHeight     :: Double
   , objectType       :: Text
@@ -164,18 +161,31 @@ data Object = ObjectPoint
   , objectY          :: Double
   , objectRotation   :: Double
   , objectGid        :: Maybe GlobalId
-  , objectText       :: Maybe Text
   , objectWidth      :: Double
   , objectType       :: Text
   , objectHeight     :: Double
   , objectPolyline   :: Vector Point
+  }
+  | ObjectText
+  { objectId         :: Int
+  , objectName       :: Maybe String
+  , objectProperties :: Maybe (Vector Property)
+  , objectVisible    :: Maybe Bool
+  , objectX          :: Double
+  , objectY          :: Double
+  , objectRotation   :: Double
+  , objectGid        :: Maybe GlobalId
+  , objectText       :: A.Value
+  , objectWidth      :: Double
+  , objectHeight     :: Double
+  , objectEllipse    :: Maybe Bool
+  , objectType       :: Text
   } deriving (Eq, Generic, Show)
 
 
 
 
 
-
 instance FromJSON Object where
   parseJSON = genericParseJSON (aesonOptions 6)
 instance ToJSON Object where
@@ -259,7 +269,7 @@ instance ToJSON Frame where
 
 
 data Tile = Tile { tileId          :: Int
-                 , tileProperties  :: Maybe (Vector Value)
+                 , tileProperties  :: Maybe (Vector Property)
                  , tileImage       :: Maybe Value
                  , tileObjectGroup :: Maybe Value
                  , tileAnimation   :: Maybe (Vector Frame)
-- 
cgit v1.2.3