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