diff --git a/data/scenarios/Testing/_Validation/2077-palette-chars.yaml b/data/scenarios/Testing/_Validation/2077-palette-chars.yaml new file mode 100644 index 000000000..aef24c857 --- /dev/null +++ b/data/scenarios/Testing/_Validation/2077-palette-chars.yaml @@ -0,0 +1,14 @@ +version: 1 +name: Enforce single-char palette keys +description: | + No multiple-char or zero-length entries allowed. +robots: [] +world: + palette: + '.': [grass] + '': [stone] + 'foo': [dirt] + upperleft: [0, 0] + map: | + .. + .. diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs index 8c9aac09d..8cf5967e3 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs @@ -4,7 +4,6 @@ -- SPDX-License-Identifier: BSD-3-Clause module Swarm.Game.Scenario.Topography.WorldPalette where -import Control.Arrow (first) import Control.Lens hiding (from, (.=), (<.>)) import Data.Aeson.KeyMap qualified as KM import Data.Map qualified as M @@ -105,9 +104,8 @@ prepForJson (PaletteAndMaskChar (StructurePalette suggestedPalette) maybeMaskCha where preassignments :: [(Char, TerrainWith EntityFacade)] preassignments = - map (first T.head . fmap (cellToTerrainPair . standardCell)) $ - M.toList $ - KM.toMapText suggestedPalette + map (fmap (cellToTerrainPair . standardCell)) $ + M.toList suggestedPalette entityCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade) entityCells = getUniqueTerrainFacadePairs $ catMaybes $ allMembers cellGrid diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs index 5f472674c..c5f02f474 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs @@ -9,19 +9,38 @@ module Swarm.Game.Scenario.Topography.ProtoCell ( ) where import Control.Applicative ((<|>)) -import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM +import Data.Map (Map, fromList, toList) +import Data.Text qualified as T +import Data.Tuple (swap) import Data.Yaml as Y import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointConfig) +import Swarm.Util (quote) import Swarm.Util.Yaml newtype StructurePalette e = StructurePalette - {unPalette :: KeyMap (SignpostableCell e)} + {unPalette :: Map Char (SignpostableCell e)} deriving (Eq, Show) instance (FromJSONE e a) => FromJSONE e (StructurePalette a) where parseJSONE = - withObjectE "palette" $ - fmap StructurePalette . mapM parseJSONE + withObjectE "palette" $ \v -> do + m <- mapM parseJSONE v + -- We swap the tuples twice so we can traverse over the second + -- element of the tuple in between. + swappedPairs <- mapM (verifyChar . swap) $ toList $ KM.toMap m + return . StructurePalette . fromList $ map swap swappedPairs + where + verifyChar = traverse $ ensureSingleChar . K.toString + ensureSingleChar [x] = return x + ensureSingleChar x = + fail $ + T.unpack $ + T.unwords + [ "Palette entry is not a single character:" + , quote $ T.pack x + ] -- | Supplements a cell with waypoint information data SignpostableCell c = SignpostableCell diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs index 63ffb447a..ac21f0d02 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs @@ -10,8 +10,7 @@ module Swarm.Game.Scenario.Topography.Structure where import Control.Monad (unless) -import Data.Aeson.Key qualified as Key -import Data.Aeson.KeyMap qualified as KeyMap +import Data.List (intercalate) import Data.List.NonEmpty qualified as NE import Data.Map qualified as M import Data.Maybe (catMaybes) @@ -133,18 +132,17 @@ paintMap :: m (Grid (Maybe c), [Waypoint]) paintMap maskChar pal g = do nestedLists <- mapM toCell g - let usedChars = Set.fromList $ map T.singleton $ allMembers g + let usedChars = Set.fromList $ allMembers g unusedChars = filter (`Set.notMember` usedChars) . M.keys - . KeyMap.toMapText $ unPalette pal unless (null unusedChars) $ fail $ unwords [ "Unused characters in palette:" - , T.unpack $ T.intercalate ", " unusedChars + , intercalate ", " $ map pure unusedChars ] let cells = fmap standardCell <$> nestedLists @@ -158,6 +156,6 @@ paintMap maskChar pal g = do toCell c = if Just c == maskChar then return Nothing - else case KeyMap.lookup (Key.fromString [c]) (unPalette pal) of + else case M.lookup c (unPalette pal) of Nothing -> failT ["Char not in world palette:", showT c] Just cell -> return $ Just cell diff --git a/src/swarm-tui/Swarm/TUI/Editor/Palette.hs b/src/swarm-tui/Swarm/TUI/Editor/Palette.hs index d562d6003..95e37a052 100644 --- a/src/swarm-tui/Swarm/TUI/Editor/Palette.hs +++ b/src/swarm-tui/Swarm/TUI/Editor/Palette.hs @@ -7,7 +7,6 @@ module Swarm.TUI.Editor.Palette where import Control.Lens import Control.Monad (guard) -import Data.Aeson.KeyMap qualified as KM import Data.List (sortOn) import Data.List.NonEmpty qualified as NE import Data.Map (Map) @@ -16,7 +15,6 @@ import Data.Maybe (catMaybes, mapMaybe) import Data.Ord (Down (..)) import Data.Set (Set) import Data.Set qualified as Set -import Data.Text qualified as T import Data.Tuple (swap) import Swarm.Game.Display (Display, defaultChar) import Swarm.Game.Entity (Entity, EntityName, entitiesByName) @@ -41,12 +39,11 @@ import Swarm.Util.Erasable makeSuggestedPalette :: TerrainMap -> - KM.KeyMap (AugmentedCell Entity) -> + Map Char (AugmentedCell Entity) -> Grid (Maybe CellPaintDisplay) -> - KM.KeyMap (AugmentedCell EntityFacade) + Map Char (AugmentedCell EntityFacade) makeSuggestedPalette tm originalScenarioPalette cellGrid = - KM.fromMapText - . M.map (SignpostableCell Nothing) + M.map (SignpostableCell Nothing) . M.fromList . M.elems -- NOTE: the left-most maps take precedence! @@ -87,23 +84,23 @@ makeSuggestedPalette tm originalScenarioPalette cellGrid = invertPaletteMapToDedupe = map (\x@(_, c) -> (toKey $ cellToTerrainPair c, x)) . M.toList - paletteCellsByKey :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) + paletteCellsByKey :: Map (TerrainWith EntityName) (Char, CellPaintDisplay) paletteCellsByKey = M.map (NE.head . NE.sortWith toSortVal) . binTuples . invertPaletteMapToDedupe - $ KM.toMapText originalPalette + $ originalPalette where toSortVal (symbol, Cell _terrain _maybeEntity robots) = Down (null robots, symbol) excludedPaletteChars :: Set Char excludedPaletteChars = Set.fromList [' '] - originalPalette :: KM.KeyMap CellPaintDisplay + originalPalette :: Map Char CellPaintDisplay originalPalette = - KM.map (toCellPaintDisplay . standardCell) originalScenarioPalette + M.map (toCellPaintDisplay . standardCell) originalScenarioPalette - pairsWithDisplays :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) + pairsWithDisplays :: Map (TerrainWith EntityName) (Char, CellPaintDisplay) pairsWithDisplays = M.fromList $ mapMaybe g entitiesWithModalTerrain where g (terrain, eName) = do @@ -111,14 +108,14 @@ makeSuggestedPalette tm originalScenarioPalette cellGrid = let displayChar = eDisplay ^. defaultChar guard $ Set.notMember displayChar excludedPaletteChars let cell = Cell terrain (EJust $ EntityFacade eName eDisplay) [] - return ((terrain, EJust eName), (T.singleton displayChar, cell)) + return ((terrain, EJust eName), (displayChar, cell)) -- TODO (#1153): Filter out terrain-only palette entries that aren't actually -- used in the map. - terrainOnlyPalette :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay) + terrainOnlyPalette :: Map (TerrainWith EntityName) (Char, CellPaintDisplay) terrainOnlyPalette = M.fromList . map f . M.keys $ terrainByName tm where - f x = ((x, ENothing), (T.singleton $ getTerrainDefaultPaletteChar x, Cell x ENothing [])) + f x = ((x, ENothing), (getTerrainDefaultPaletteChar x, Cell x ENothing [])) -- | Generate a \"skeleton\" scenario with placeholders for certain required fields constructScenario :: Maybe Scenario -> Grid (Maybe CellPaintDisplay) -> SkeletonScenario