From aa897bb7e2ae257c2680521e6b1c1cad1237df53 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Sat, 18 Dec 2021 17:52:25 +0100
Subject: [PATCH] fixed parsing of tiled objects
(points behave slightly differntly than I thought)
---
lib/Properties.hs | 17 +++++++++--------
lib/Tiled.hs | 33 ++++++++++-----------------------
lib/Types.hs | 3 +++
3 files changed, 22 insertions(+), 31 deletions(-)
diff --git a/lib/Properties.hs b/lib/Properties.hs
index c057b63..a326e30 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -211,7 +211,7 @@ checkLayer = do
forM_ (getProperties layer) checkObjectGroupProperty
unless (layerName layer == "floorLayer") $
- when (null publicObjects || publicObjects == Just mempty) $
+ when (null (layerObjects layer) || layerObjects layer == Just mempty) $
warn "objectgroup layer (which aren't the floorLayer) \
\are useless if they are empty."
@@ -234,16 +234,17 @@ checkObjectProperty obj p@(Property name _) = case name of
unwrapString p $ \str ->
unwrapBadgeToken str $ \token -> do
case obj of
- ObjectPoint {..} ->
- offersBadge (Badge token (BadgePoint objectX objectY))
- ObjectRectangle {..} ->
- if isJust objectEllipse
- then offersBadge
- $ Badge token (BadgeRect objectX objectY objectWidth objectHeight)
- else complain "ellipses are not supported."
ObjectPolygon {} -> complain "polygons are not supported."
ObjectPolyline {} -> complain "polylines are not supported."
ObjectText {} -> complain "cannot use texts to define badge areas."
+ ObjectRectangle {..} ->
+ if objectEllipse == Just True
+ then complain "ellipses are not supported."
+ else offersBadge
+ $ Badge token $ case (objectWidth, objectHeight) of
+ (Just w, Just h) | w /= 0 && h /= 0 ->
+ BadgeRect objectX objectY w h
+ _ -> BadgePoint objectX objectY
_ -> warn $ "unknown object property " <> prettyprint name <> "."
diff --git a/lib/Tiled.hs b/lib/Tiled.hs
index fa876ee..c5abb21 100644
--- a/lib/Tiled.hs
+++ b/lib/Tiled.hs
@@ -121,32 +121,19 @@ instance ToJSON Point where
-- | all kinds of objects that can occur in object layers, even
-- | those that we don't want to allow.
-data Object = ObjectPoint
+data Object = ObjectRectangle
{ objectId :: Int
, objectName :: Maybe String
, objectProperties :: Maybe (Vector Property)
, objectVisible :: Maybe Bool
, objectX :: Double
, objectY :: Double
- , objectHeight :: Double
- , objectWidth :: Double
, objectRotation :: Double
, objectGid :: Maybe GlobalId
- , objectType :: Text
- , objectPoint :: Bool
- }
- | ObjectRectangle
- { objectId :: Int
- , objectName :: Maybe String
- , objectProperties :: Maybe (Vector Property)
- , objectVisible :: Maybe Bool
- , objectX :: Double
- , objectY :: Double
- , objectRotation :: Double
- , objectGid :: Maybe GlobalId
- , objectWidth :: Double
- , objectHeight :: Double
+ , objectWidth :: Maybe Double
+ , objectHeight :: Maybe Double
, objectEllipse :: Maybe Bool
+ , objectPoint :: Maybe Bool
, objectType :: Text
}
| ObjectPolygon
@@ -158,8 +145,8 @@ data Object = ObjectPoint
, objectY :: Double
, objectRotation :: Double
, objectGid :: Maybe GlobalId
- , objectWidth :: Double
- , objectHeight :: Double
+ , objectWidth :: Maybe Double
+ , objectHeight :: Maybe Double
, objectType :: Text
, objectPolygon :: Vector Point
}
@@ -172,9 +159,9 @@ data Object = ObjectPoint
, objectY :: Double
, objectRotation :: Double
, objectGid :: Maybe GlobalId
- , objectWidth :: Double
+ , objectWidth :: Maybe Double
+ , objectHeight :: Maybe Double
, objectType :: Text
- , objectHeight :: Double
, objectPolyline :: Vector Point
}
| ObjectText
@@ -187,8 +174,8 @@ data Object = ObjectPoint
, objectRotation :: Double
, objectGid :: Maybe GlobalId
, objectText :: A.Value
- , objectWidth :: Double
- , objectHeight :: Double
+ , objectWidth :: Maybe Double
+ , objectHeight :: Maybe Double
, objectEllipse :: Maybe Bool
, objectType :: Text
} deriving (Eq, Generic, Show)
diff --git a/lib/Types.hs b/lib/Types.hs
index 978ada2..3ec9ebc 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -93,6 +93,9 @@ instance ToJSON Lint where
toJSON (Offers l) = A.object
[ "msg" .= prettyprint l
, "level" .= A.String "Entrypoint Info" ]
+ toJSON (Badge _) = A.object
+ [ "msg" .= A.String "found a badge"
+ , "level" .= A.String "Badge Info"]
instance ToJSON Hint where
toJSON (Hint l m) = A.object
--
GitLab