better support for structure references

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]

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: ""

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"

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

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

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

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
 

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.

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

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
+        ]

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