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 +++++++++++++++++++++----------------
 1 file changed, 21 insertions(+), 16 deletions(-)

(limited to 'lib/Properties.hs')

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"
 
 
-- 
cgit v1.2.3