diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/LayerData.hs | 42 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 2 | ||||
| -rw-r--r-- | lib/Properties.hs | 17 | ||||
| -rw-r--r-- | lib/Util.hs | 5 |
4 files changed, 65 insertions, 1 deletions
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 |