diff --git a/data/scenarios/Testing/_Validation/9999-palette-chars.yaml b/data/scenarios/Testing/_Validation/9999-palette-chars.yaml new file mode 100644 index 000000000..aef24c857 --- /dev/null +++ b/data/scenarios/Testing/_Validation/9999-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 2139b363d..8cf5967e3 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs @@ -4,9 +4,7 @@ -- 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.Key qualified as K import Data.Aeson.KeyMap qualified as KM import Data.Map qualified as M import Data.Maybe (catMaybes) @@ -106,7 +104,7 @@ prepForJson (PaletteAndMaskChar (StructurePalette suggestedPalette) maybeMaskCha where preassignments :: [(Char, TerrainWith EntityFacade)] preassignments = - map (first (T.head . K.toText) . fmap (cellToTerrainPair . standardCell)) $ + map (fmap (cellToTerrainPair . standardCell)) $ M.toList suggestedPalette entityCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade) diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs index 15e792876..371814fc1 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs @@ -11,19 +11,36 @@ module Swarm.Game.Scenario.Topography.ProtoCell ( import Control.Applicative ((<|>)) import Data.Aeson.Key qualified as K import Data.Aeson.KeyMap qualified as KM -import Data.Map (Map) +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 :: Map K.Key (SignpostableCell e)} + {unPalette :: Map Char (SignpostableCell e)} deriving (Eq, Show) instance (FromJSONE e a) => FromJSONE e (StructurePalette a) where parseJSONE = - withObjectE "palette" $ - fmap (StructurePalette . KM.toMap) . 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. + let swappedPairs = map swap $ toList $ KM.toMap m + swappedAgainPairs <- mapM (traverse $ ensureSingleChar . K.toString) swappedPairs + return . StructurePalette . fromList $ map swap swappedAgainPairs + where + 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 eaf010c2c..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,10 +132,9 @@ 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) - . map Key.toText . M.keys $ unPalette pal @@ -144,7 +142,7 @@ paintMap maskChar pal g = do 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 M.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 3b8467d79..95e37a052 100644 --- a/src/swarm-tui/Swarm/TUI/Editor/Palette.hs +++ b/src/swarm-tui/Swarm/TUI/Editor/Palette.hs @@ -7,9 +7,6 @@ module Swarm.TUI.Editor.Palette where import Control.Lens import Control.Monad (guard) -import Data.Aeson.Key qualified as K -import Data.Aeson.KeyMap qualified as KM -import Data.Bifunctor (first) import Data.List (sortOn) import Data.List.NonEmpty qualified as NE import Data.Map (Map) @@ -18,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) @@ -43,13 +39,12 @@ import Swarm.Util.Erasable makeSuggestedPalette :: TerrainMap -> - Map KM.Key (AugmentedCell Entity) -> + Map Char (AugmentedCell Entity) -> Grid (Maybe CellPaintDisplay) -> - Map KM.Key (AugmentedCell EntityFacade) + Map Char (AugmentedCell EntityFacade) makeSuggestedPalette tm originalScenarioPalette cellGrid = M.map (SignpostableCell Nothing) . M.fromList - . map (first K.fromText) . M.elems -- NOTE: the left-most maps take precedence! $ paletteCellsByKey <> pairsWithDisplays <> terrainOnlyPalette @@ -89,9 +84,9 @@ 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 (first K.toText . NE.head . NE.sortWith toSortVal) + M.map (NE.head . NE.sortWith toSortVal) . binTuples . invertPaletteMapToDedupe $ originalPalette @@ -101,11 +96,11 @@ makeSuggestedPalette tm originalScenarioPalette cellGrid = excludedPaletteChars :: Set Char excludedPaletteChars = Set.fromList [' '] - originalPalette :: Map KM.Key CellPaintDisplay + originalPalette :: Map Char CellPaintDisplay originalPalette = 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 @@ -113,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