From 36f6de4da88faab8f1dca0a386e7b0d32a80d267 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Thu, 10 Oct 2024 22:42:28 -0700 Subject: [PATCH] better support for structure references --- .../1138-structures/nested-structure.yaml | 16 +++--- .../_Validation/2164-recursive-structure.yaml | 43 ++++++++++++++++ data/schema/named-structure.json | 2 +- src/swarm-scenario/Swarm/Game/Scenario.hs | 12 ++--- .../Swarm/Game/Scenario/Objective/Graph.hs | 11 +--- .../Game/Scenario/Objective/Validation.hs | 10 ++-- .../Scenario/Topography/WorldDescription.hs | 5 ++ .../Scenario/Topography/Structure/Assembly.hs | 22 ++++++-- .../Topography/Structure/Recognition.hs | 3 ++ src/swarm-util/Swarm/Util/Graph.hs | 51 +++++++++++++++++++ swarm.cabal | 1 + 11 files changed, 143 insertions(+), 33 deletions(-) create mode 100644 data/scenarios/Testing/_Validation/2164-recursive-structure.yaml create mode 100644 src/swarm-util/Swarm/Util/Graph.hs diff --git a/data/scenarios/Testing/1138-structures/nested-structure.yaml b/data/scenarios/Testing/1138-structures/nested-structure.yaml index 0311f4a56..e96eb9c49 100644 --- a/data/scenarios/Testing/1138-structures/nested-structure.yaml +++ b/data/scenarios/Testing/1138-structures/nested-structure.yaml @@ -19,14 +19,6 @@ world: '│': [stone, vertical wall] upperleft: [-1, 1] structures: - - name: bitpair - structure: - palette: - '0': [stone, bit (0)] - '1': [stone, bit (1)] - map: | - 1 - 0 - name: bigbox structure: palette: @@ -57,6 +49,14 @@ world: T.T.T. .T.T.T TTTTTT + - name: bitpair + structure: + palette: + '0': [stone, bit (0)] + '1': [stone, bit (1)] + map: | + 1 + 0 placements: - src: bigbox offset: [1, -1] diff --git a/data/scenarios/Testing/_Validation/2164-recursive-structure.yaml b/data/scenarios/Testing/_Validation/2164-recursive-structure.yaml new file mode 100644 index 000000000..a3e2dfb5c --- /dev/null +++ b/data/scenarios/Testing/_Validation/2164-recursive-structure.yaml @@ -0,0 +1,43 @@ +version: 1 +name: Structure placement (recursive references) +description: | + Recursive structure references are not allowed. +robots: + - name: base + loc: [2, 2] + dir: east +known: [] +world: + structures: + - name: bigbox + structure: + structures: + - name: bitpair + structure: + palette: + '.': [stone, tree] + placements: + - src: minibox + map: | + . + - name: minibox + structure: + palette: + '.': [stone] + placements: + - src: bitpair + map: | + . + placements: + - src: smallbox + - src: bitpair + map: "" + - name: smallbox + structure: + palette: + '.': [grass] + map: | + . + placements: + - src: bigbox + map: "" diff --git a/data/schema/named-structure.json b/data/schema/named-structure.json index b32c08a42..8163d893a 100644 --- a/data/schema/named-structure.json +++ b/data/schema/named-structure.json @@ -19,7 +19,7 @@ "items": { "$ref": "direction.json" }, - "description": "Orientations for which this structure participates in automatic recognition when constructed" + "description": "Orientations for which this structure participates in automatic recognition when constructed. Note that recognition is only supported for structures defined at the scenario top level." }, "structure": { "$ref": "structure.json" diff --git a/src/swarm-scenario/Swarm/Game/Scenario.hs b/src/swarm-scenario/Swarm/Game/Scenario.hs index 8a8ee9675..da955f658 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario.hs @@ -266,12 +266,10 @@ instance FromJSONE ScenarioInputs Scenario where validatedTerrainObjects <- runValidation $ validateTerrainAttrRefs attrsUnion tmRaw - let tm = mkTerrainMap validatedTerrainObjects - runValidation $ validateEntityAttrRefs attrsUnion emRaw em <- runValidation $ buildEntityMap emRaw - + let tm = mkTerrainMap validatedTerrainObjects let scenarioSpecificTerrainEntities = TerrainEntityMaps tm em -- Save the passed in WorldMap for later @@ -307,14 +305,13 @@ instance FromJSONE ScenarioInputs Scenario where -- -- We should also make use of such a pre-computed map in the -- invocation of 'mergeStructures' inside WorldDescription.hs. + let structureMap = Assembly.makeStructureMap rootLevelSharedStructures mergedStructures <- either (fail . T.unpack) return $ mapM - (sequenceA . (id &&& (Assembly.mergeStructures mempty Root . Structure.structure))) + (sequenceA . (id &&& (Assembly.mergeStructures structureMap Root . Structure.structure))) rootLevelSharedStructures - let namedGrids = map (\(ns, Structure.MergedStructure (PositionedGrid _ s) _ _) -> s <$ ns) mergedStructures - allWorlds <- localE (WorldParseDependencies worldMap rootLevelSharedStructures rsMap) $ do rootWorld <- v ..: "world" subworlds <- v ..:? "subworlds" ..!= [] @@ -353,6 +350,9 @@ instance FromJSONE ScenarioInputs Scenario where $ NE.toList allWorlds let mergedNavigation = Navigation mergedWaypoints mergedPortals + + stuffGrid (ns, Structure.MergedStructure (PositionedGrid _ s) _ _) = s <$ ns + namedGrids = map stuffGrid mergedStructures recognizableGrids = filter Structure.isRecognizable namedGrids symmetryAnnotatedGrids <- mapM checkSymmetry recognizableGrids diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Objective/Graph.hs b/src/swarm-scenario/Swarm/Game/Scenario/Objective/Graph.hs index 256ac6d8c..2d13c96d2 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Objective/Graph.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Objective/Graph.hs @@ -11,7 +11,7 @@ import Control.Lens (view, (^.), (^..)) import Data.Aeson import Data.BoolExpr (Signed (Positive)) import Data.BoolExpr qualified as BE -import Data.Graph (Graph, SCC (AcyclicSCC), graphFromEdges, stronglyConnComp) +import Data.Graph (Graph, SCC, graphFromEdges, stronglyConnComp) import Data.Map (Map) import Data.Map.Strict qualified as M import Data.Maybe (mapMaybe) @@ -24,6 +24,7 @@ import Servant.Docs (ToSample) import Servant.Docs qualified as SD import Swarm.Game.Scenario.Objective import Swarm.Game.Scenario.Objective.Logic as L +import Swarm.Util.Graph (isAcyclicGraph) -- | This is only needed for constructing a Graph, -- which requires all nodes to have a key. @@ -133,14 +134,6 @@ makeGraphEdges objectives = f (k, v) = (v, k, maybe [] (map Label . g) $ v ^. objectivePrerequisite) g = Set.toList . getDistinctConstants . logic -isAcyclicGraph :: [SCC Objective] -> Bool -isAcyclicGraph = - all isAcyclicVertex - where - isAcyclicVertex = \case - AcyclicSCC _ -> True - _ -> False - makeGraphInfo :: ObjectiveCompletion -> GraphInfo makeGraphInfo oc = GraphInfo diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Objective/Validation.hs b/src/swarm-scenario/Swarm/Game/Scenario/Objective/Validation.hs index a686ee41a..130c2a4c0 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Objective/Validation.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Objective/Validation.hs @@ -9,13 +9,13 @@ module Swarm.Game.Scenario.Objective.Validation where import Control.Lens (view, (^.)) import Control.Monad (unless) import Data.Foldable (for_, toList) -import Data.Graph (stronglyConnComp) -import Data.Maybe (mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Set qualified as Set import Data.Text qualified as T import Swarm.Game.Scenario.Objective import Swarm.Game.Scenario.Objective.Graph import Swarm.Util (failT, quote) +import Swarm.Util.Graph -- | Performs monadic validation before returning -- the "pure" construction of a wrapper record. @@ -43,10 +43,10 @@ validateObjectives objectives = do remaining = Set.difference refs allIds Nothing -> return () - unless (isAcyclicGraph connectedComponents) $ - failT ["There are dependency cycles in the prerequisites."] + either (fail . T.unpack) return $ + failOnCyclicGraph "Prerequisites" (fromMaybe "N/A" . view objectiveId) edges return objectives where - connectedComponents = stronglyConnComp $ makeGraphEdges objectives + edges = makeGraphEdges objectives allIds = Set.fromList $ mapMaybe (view objectiveId) objectives diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs index dc6edc9a3..e5e827a5d 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs @@ -97,6 +97,11 @@ instance FromJSONE WorldParseDependencies WorldDescription where mkWorld tem worldMap palette initialStructureDefs v = do MergedStructure mergedGrid staticStructurePlacements unmergedWaypoints <- do unflattenedStructure <- parseStructure palette initialStructureDefs v + + -- NOTE: In contrast with the 'Swarm.Game.Scenario' module, + -- we do not need to pass in a structure map here, + -- because all the structure definitions we need are at this + -- point already stored inside the "Structure" object. either (fail . T.unpack) return $ Assembly.mergeStructures mempty Root unflattenedStructure diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs index bf44ad642..7ab35c2d5 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs @@ -7,6 +7,7 @@ -- as well as logic for combining them. module Swarm.Game.Scenario.Topography.Structure.Assembly ( mergeStructures, + makeStructureMap, -- * Exposed for unit tests: foldLayer, @@ -33,6 +34,7 @@ import Swarm.Game.Scenario.Topography.Structure.Overlay import Swarm.Game.Scenario.Topography.Structure.Recognition.Static import Swarm.Language.Syntax.Direction (directionJsonModifier) import Swarm.Util (commaList, quote, showT) +import Swarm.Util.Graph -- | Destructively overlays one direct child structure -- upon the input structure. @@ -59,6 +61,18 @@ overlaySingleStructure offsetLoc (coerce loc) . modifyLoc (reorientLandmark orientation $ getGridDimensions overArea) +makeStructureMap :: [NamedStructure a] -> M.Map StructureName (NamedStructure a) +makeStructureMap = M.fromList . map (name &&& id) + +type GraphEdge a = (NamedStructure a, StructureName, [StructureName]) + +makeGraphEdges :: [NamedStructure a] -> [GraphEdge a] +makeGraphEdges = + map makeGraphNodeWithEdges + where + makeGraphNodeWithEdges s = + (s, name s, map src $ placements $ structure s) + -- | Overlays all of the "child placements", such that the children encountered later -- in the YAML file supersede the earlier ones (dictated by using 'foldl' instead of 'foldr'). mergeStructures :: @@ -67,6 +81,8 @@ mergeStructures :: PStructure (Maybe a) -> Either Text (MergedStructure (Maybe a)) mergeStructures inheritedStrucDefs parentPlacement baseStructure = do + failOnCyclicGraph "Structure" (getStructureName . name) gEdges + overlays <- left (elaboratePlacement parentPlacement <>) $ mapM (validatePlacement structureMap) subPlacements @@ -78,10 +94,8 @@ mergeStructures inheritedStrucDefs parentPlacement baseStructure = do originatedWaypoints = map (Originated parentPlacement) subWaypoints -- deeper definitions override the outer (toplevel) ones - structureMap = - M.union - (M.fromList $ map (name &&& id) subStructures) - inheritedStrucDefs + structureMap = M.union (makeStructureMap subStructures) inheritedStrucDefs + gEdges = makeGraphEdges $ M.elems structureMap -- | NOTE: Each successive overlay may alter the coordinate origin. -- We make sure this new origin is propagated to subsequent sibling placements. diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs index 457ac7fe8..d16d1b337 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs @@ -4,6 +4,9 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Public interface for structure recognizer. +-- +-- Note that we only support "recognition" of structures defined at the +-- scenario-global level. module Swarm.Game.Scenario.Topography.Structure.Recognition where import Control.Lens diff --git a/src/swarm-util/Swarm/Util/Graph.hs b/src/swarm-util/Swarm/Util/Graph.hs new file mode 100644 index 000000000..fbdcaca3e --- /dev/null +++ b/src/swarm-util/Swarm/Util/Graph.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Graph utilities shared by multiple aspects of scenarios +module Swarm.Util.Graph ( + isAcyclicGraph, + failOnCyclicGraph, +) where + +import Control.Monad (forM_) +import Data.Graph (SCC (..), stronglyConnComp) +import Data.List.NonEmpty qualified as NE +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Swarm.Util + +isAcyclicGraph :: [SCC a] -> Bool +isAcyclicGraph = + all isAcyclicVertex + where + isAcyclicVertex = \case + AcyclicSCC _ -> True + _ -> False + +getGraphCycles :: [SCC a] -> [[a]] +getGraphCycles = + mapMaybe getCycle + where + getCycle = \case + AcyclicSCC _ -> Nothing + CyclicSCC c -> Just c + +failOnCyclicGraph :: + Ord key => + Text -> + (a -> Text) -> + [(a, key, [key])] -> + Either Text () +failOnCyclicGraph graphType keyFunction gEdges = + forM_ (NE.nonEmpty $ getGraphCycles $ stronglyConnComp gEdges) $ \cycles -> + Left $ + T.unwords + [ graphType + , "graph contains cycles!" + , commaList $ + NE.toList $ + fmap (brackets . T.intercalate " -> " . fmap keyFunction) cycles + ] diff --git a/swarm.cabal b/swarm.cabal index 351c6437d..5fceedc67 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -886,6 +886,7 @@ library swarm-util Swarm.Util Swarm.Util.Effect Swarm.Util.Erasable + Swarm.Util.Graph Swarm.Util.JSON Swarm.Util.Lens Swarm.Util.OccurrenceEncoder