summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/Properties.hs37
-rw-r--r--lib/Tiled.hs22
2 files changed, 37 insertions, 22 deletions
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)