From ec9552b1d6ab303d54a8bbb8c93418f32fa29654 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Wed, 8 Dec 2021 00:56:31 +0100
Subject: rudimentary linting for overlapping layers
---
lib/LayerData.hs | 42 ++++++++++++++++++++++++++++++++++++++++++
lib/LintWriter.hs | 2 +-
lib/Properties.hs | 17 +++++++++++++++++
lib/Util.hs | 5 +++++
walint.cabal | 1 +
5 files changed, 66 insertions(+), 1 deletion(-)
create mode 100644 lib/LayerData.hs
diff --git a/lib/LayerData.hs b/lib/LayerData.hs
new file mode 100644
index 0000000..1a07982
--- /dev/null
+++ b/lib/LayerData.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module LayerData where
+
+
+import Control.Monad.Zip (mzipWith)
+import Data.Set (Set, insert)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Vector (Vector, uncons)
+import Tiled (GlobalId (unGlobalId), Layer (..))
+import Util (PrettyPrint (..))
+
+-- | A collision between two layers of the given names.
+-- Wrapped in a newtype so that Eq can ignore the order of the two
+newtype Collision = Collision { fromCollision :: (Text, Text) }
+ deriving Ord
+
+instance Eq Collision where
+ (Collision (a,b)) == (Collision (a',b')) = ((a,b) == (a',b')) || ((a,b) == (b',a'))
+
+instance PrettyPrint Collision where
+ prettyprint (Collision (a,b)) = a <> " and " <> b
+
+instance Show Collision where
+ show c = T.unpack $ prettyprint c
+
+-- | Finds pairwise tile collisions between the given layers.
+layerOverlaps :: Vector Layer -> Set Collision
+layerOverlaps layers = case uncons layers of
+ Nothing -> mempty
+ Just (l, ls) ->
+ fst . foldr overlapBetween (mempty, l) $ ls
+ where overlapBetween :: Layer -> (Set Collision, Layer) -> (Set Collision, Layer)
+ overlapBetween layer (acc, oldlayer) =
+ (if collides then insert collision acc else acc, layer)
+ where
+ collision = Collision (layerName layer, layerName oldlayer)
+ collides = case (layerData layer, layerData oldlayer) of
+ (Just d1, Just d2) ->
+ 0 /= maximum (mzipWith (\a b -> unGlobalId a * unGlobalId b) d1 d2)
+ _ -> False
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index 12c4311..74df70a 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -42,6 +42,7 @@ module LintWriter
import Data.Text (Text)
+import Badges (Badge)
import Control.Monad.State (StateT, modify)
import Control.Monad.Trans.Reader (Reader, asks, runReader)
import Control.Monad.Trans.State (runStateT)
@@ -49,7 +50,6 @@ import Control.Monad.Writer.Lazy (lift)
import Data.Bifunctor (Bifunctor (second))
import Data.Map (Map, fromListWith)
import Data.Maybe (mapMaybe)
-import Badges (Badge)
import LintConfig (LintConfig')
import TiledAbstract (HasName)
import Types (Dep, Hint, Level (..), Lint (..),
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 2747998..5845a1b 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -25,8 +25,10 @@ import Badges (Badge (Badge),
parseToken)
import Data.Data (Proxy (Proxy))
import Data.Maybe (fromMaybe, isJust)
+import Data.Set (Set)
import qualified Data.Set as S
import GHC.TypeLits (KnownSymbol)
+import LayerData (Collision, layerOverlaps)
import LintConfig (LintConfig (..))
import LintWriter (LintWriter, adjust, askContext, askFileDepth,
complain, dependsOn, forbid, lintConfig,
@@ -71,6 +73,11 @@ checkMap = do
unlessHasProperty "mapCopyright"
$ complain "must give the map's copyright via the \"mapCopyright\" property."
+ -- TODO: this doesn't catch collisions with the default start layer!
+ whenLayerCollisions (\(Property name _) -> name == "exitUrl" || name == "startLayer")
+ $ \cols -> warn $ "collisions between entry and / or exit layers: " <> prettyprint cols
+
+
-- | Checks a single property of a map.
--
-- Doesn't really do all that much, but could in theory be expanded into a
@@ -378,6 +385,16 @@ containsProperty :: Foldable t => t Property -> Text -> Bool
containsProperty props name = any
(\(Property name' _) -> name' == name) props
+-- | should the layers fulfilling the given predicate collide, then perform andthen.
+whenLayerCollisions
+ :: (Property -> Bool)
+ -> (Set Collision -> LintWriter Tiledmap)
+ -> LintWriter Tiledmap
+whenLayerCollisions f andthen = do
+ tiledmap <- askContext
+ let collisions = layerOverlaps . V.filter (any f . getProperties) $ tiledmapLayers tiledmap
+ unless (null collisions)
+ $ andthen collisions
----- Functions with concrete lint messages -----
diff --git a/lib/Util.hs b/lib/Util.hs
index e676e7e..1e5826c 100644
--- a/lib/Util.hs
+++ b/lib/Util.hs
@@ -8,6 +8,8 @@ module Util where
import Data.Aeson as Aeson
import Data.Proxy (Proxy (..))
+import Data.Set (Set)
+import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Tiled (Layer (layerData), PropertyValue (..),
@@ -36,6 +38,9 @@ instance PrettyPrint Aeson.Value where
Aeson.String s -> prettyprint s
v -> (T.pack . show) v
+instance PrettyPrint t => PrettyPrint (Set t) where
+ prettyprint = T.intercalate ", " . fmap prettyprint . S.toList
+
instance PrettyPrint PropertyValue where
prettyprint = \case
StrProp str -> str
diff --git a/walint.cabal b/walint.cabal
index e39e9e3..a211aec 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -39,6 +39,7 @@ library
Uris
LintConfig
Badges
+ LayerData
build-depends: base,
aeson,
bytestring,
--
cgit v1.2.3