diff options
| -rw-r--r-- | lib/Properties.hs | 37 | ||||
| -rw-r--r-- | lib/Tiled.hs | 22 |
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) |