From 42313340289b0c82bcd19d277be0e6bef39fc950 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Wed, 31 Jul 2024 11:07:43 -0700 Subject: [PATCH] Structure placeholders in palette (#2086) Closes #1647 ``` scripts/play.sh -i data/scenarios/Testing/2086-structure-palette.yaml --autoplay ``` ![Screenshot from 2024-07-31 10-49-57](https://github.com/user-attachments/assets/594cfc2f-a6d0-4143-a95d-43e7b5443c95) --- data/scenarios/Testing/00-ORDER.txt | 1 + .../Testing/2086-structure-palette.yaml | 55 +++++++++++++++++++ .../Swarm/Game/Scenario/Topography/Cell.hs | 2 +- .../Game/Scenario/Topography/ProtoCell.hs | 15 ++++- .../Game/Scenario/Topography/Structure.hs | 36 ++++++++---- src/swarm-tui/Swarm/TUI/Editor/Palette.hs | 2 +- test/integration/Main.hs | 1 + 7 files changed, 96 insertions(+), 16 deletions(-) create mode 100644 data/scenarios/Testing/2086-structure-palette.yaml diff --git a/data/scenarios/Testing/00-ORDER.txt b/data/scenarios/Testing/00-ORDER.txt index a9d9527c0..e7edbda40 100644 --- a/data/scenarios/Testing/00-ORDER.txt +++ b/data/scenarios/Testing/00-ORDER.txt @@ -68,3 +68,4 @@ Achievements 1533-sow-seed-maturation.yaml 231-requirements 2085-toplevel-mask.yaml +2086-structure-palette.yaml diff --git a/data/scenarios/Testing/2086-structure-palette.yaml b/data/scenarios/Testing/2086-structure-palette.yaml new file mode 100644 index 000000000..157a73863 --- /dev/null +++ b/data/scenarios/Testing/2086-structure-palette.yaml @@ -0,0 +1,55 @@ +version: 1 +name: Structure markers +description: | + Reference structures in the palette +seed: 0 +objectives: + - goal: + - | + `grab` a `tree`{=entity}. + condition: | + as base {has "tree"}; +solution: | + move; move; grab; +robots: + - name: base + dir: east + devices: + - treads + - logger + - grabber +structures: + - name: rect + structure: + palette: + 'o': [dirt, tree] + map: | + ooo + ooo +known: [water, tree] +world: + dsl: | + {grass} + offset: false + palette: + 'B': [stone, erase, base] + '.': [stone] + 'x': + structure: + name: rect + cell: [grass] + 'z': + structure: + name: rect + orientation: + up: east + cell: [grass] + map: |- + ...... + ...z.. + ...... + .B.... + ...... + .x.... + ...... + ...... diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs index 4b0aa4214..853c5a9e9 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Cell.hs @@ -97,7 +97,7 @@ instance FromJSONE (TerrainEntityMaps, RobotMap) Cell where case meName of Nothing -> return ENothing Just "erase" -> return EErase - Just name -> fmap EJust . localE (view entityMap . fst) $ getEntity name + Just n -> fmap EJust . localE (view entityMap . fst) $ getEntity n let name2rob r = do mrName <- liftE $ parseJSON @(Maybe RobotName) r diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs index c5f02f474..64e9653f6 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs @@ -6,6 +6,7 @@ module Swarm.Game.Scenario.Topography.ProtoCell ( SignpostableCell (..), StructurePalette (..), + StructureMarker (..), ) where import Control.Applicative ((<|>)) @@ -15,7 +16,9 @@ import Data.Map (Map, fromList, toList) import Data.Text qualified as T import Data.Tuple (swap) import Data.Yaml as Y +import GHC.Generics (Generic) import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointConfig) +import Swarm.Game.Scenario.Topography.Placement import Swarm.Util (quote) import Swarm.Util.Yaml @@ -42,9 +45,16 @@ instance (FromJSONE e a) => FromJSONE e (StructurePalette a) where , quote $ T.pack x ] --- | Supplements a cell with waypoint information +data StructureMarker = StructureMarker + { name :: StructureName + , orientation :: Maybe Orientation + } + deriving (Eq, Show, Generic, FromJSON) + +-- | Supplements a cell with waypoint and/or structure placement information data SignpostableCell c = SignpostableCell { waypointCfg :: Maybe WaypointConfig + , structureMarker :: Maybe StructureMarker , standardCell :: c } deriving (Eq, Show) @@ -52,9 +62,10 @@ data SignpostableCell c = SignpostableCell instance (FromJSONE e a) => FromJSONE e (SignpostableCell a) where parseJSONE x = withObjectE "SignpostableCell" objParse x - <|> (SignpostableCell Nothing <$> parseJSONE x) + <|> (SignpostableCell Nothing Nothing <$> parseJSONE x) where objParse v = do waypointCfg <- liftE $ v .:? "waypoint" + structureMarker <- liftE $ v .:? "structure" standardCell <- v ..: "cell" pure $ SignpostableCell {..} diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs index 732c6eac8..a917a6eaa 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs @@ -13,7 +13,7 @@ import Control.Monad (forM_, unless) import Data.List (intercalate) import Data.List.NonEmpty qualified as NE import Data.Map qualified as M -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, fromMaybe) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) @@ -105,13 +105,14 @@ parseStructure :: Object -> Parser (PStructure (Maybe c)) parseStructure pal structures v = do - placements <- v .:? "placements" .!= [] + explicitPlacements <- v .:? "placements" .!= [] waypointDefs <- v .:? "waypoints" .!= [] maybeMaskChar <- v .:? "mask" rawGrid <- v .:? "map" .!= EmptyGrid - (maskedArea, mapWaypoints) <- paintMap maybeMaskChar pal rawGrid + (maskedArea, mapWaypoints, palettePlacements) <- paintMap maybeMaskChar pal rawGrid let area = PositionedGrid origin maskedArea waypoints = waypointDefs <> mapWaypoints + placements = explicitPlacements <> palettePlacements return Structure {..} instance (FromJSONE e a) => FromJSONE e (PStructure (Maybe a)) where @@ -129,13 +130,9 @@ paintMap :: Maybe Char -> StructurePalette c -> Grid Char -> - m (Grid (Maybe c), [Waypoint]) + m (Grid (Maybe c), [Waypoint], [Placement]) paintMap maskChar pal g = do nestedLists <- mapM toCell g - let usedChars = Set.fromList $ allMembers g - paletteKeys = M.keysSet $ unPalette pal - unusedPaletteChars = Set.difference paletteKeys usedChars - forM_ maskChar $ \c -> unless (Set.notMember c paletteKeys) $ fail $ @@ -153,13 +150,28 @@ paintMap maskChar pal g = do ] let cells = fmap standardCell <$> nestedLists - getWp coords maybeAugmentedCell = do - wpCfg <- waypointCfg =<< maybeAugmentedCell - return . Waypoint wpCfg . coordsToLoc $ coords wps = catMaybes $ mapIndexedMembers getWp nestedLists - return (cells, wps) + let extraPlacements = + catMaybes $ mapIndexedMembers getStructureMarker nestedLists + + return (cells, wps, extraPlacements) where + getStructureMarker coords maybeAugmentedCell = do + StructureMarker sName orientation <- structureMarker =<< maybeAugmentedCell + return + . Placement sName + . Pose (coordsToLoc coords) + $ fromMaybe defaultOrientation orientation + + getWp coords maybeAugmentedCell = do + wpCfg <- waypointCfg =<< maybeAugmentedCell + return . Waypoint wpCfg . coordsToLoc $ coords + + usedChars = Set.fromList $ allMembers g + paletteKeys = M.keysSet $ unPalette pal + unusedPaletteChars = Set.difference paletteKeys usedChars + toCell c = if Just c == maskChar then return Nothing diff --git a/src/swarm-tui/Swarm/TUI/Editor/Palette.hs b/src/swarm-tui/Swarm/TUI/Editor/Palette.hs index 95e37a052..1f534e45b 100644 --- a/src/swarm-tui/Swarm/TUI/Editor/Palette.hs +++ b/src/swarm-tui/Swarm/TUI/Editor/Palette.hs @@ -43,7 +43,7 @@ makeSuggestedPalette :: Grid (Maybe CellPaintDisplay) -> Map Char (AugmentedCell EntityFacade) makeSuggestedPalette tm originalScenarioPalette cellGrid = - M.map (SignpostableCell Nothing) + M.map (SignpostableCell Nothing Nothing) . M.fromList . M.elems -- NOTE: the left-most maps take precedence! diff --git a/test/integration/Main.hs b/test/integration/Main.hs index ceca656a8..fe5c8ec9a 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -372,6 +372,7 @@ testScenarioSolutions rs ui key = , testSolution (Sec 10) "Testing/1533-sow-command" , testSolution Default "Testing/1533-sow-seed-maturation" , testSolution Default "Testing/2085-toplevel-mask" + , testSolution Default "Testing/2086-structure-palette" , testGroup -- Note that the description of the classic world in -- data/worlds/classic.yaml (automatically tested to some