wip

src/swarm-render/Swarm/Render/Structures.hs

@@ -7,7 +7,9 @@ module Swarm.Render.Structures where
 
 import Codec.Picture as JP
 import Control.Carrier.Throw.Either
+import Swarm.Game.Scenario.Topography.WorldDescription
 import Control.Effect.Lift
+import Data.List.NonEmpty qualified as NE
 import Data.GraphViz (GraphvizParams (..))
 import Data.GraphViz qualified as GV
 import Data.GraphViz.Attributes.Complete as GVA
@@ -40,6 +42,12 @@ renderStructuresGraph ::
 renderStructuresGraph imgRendering sMap = do
   g' <- layoutGraph' params Dot g
 
+  putStrLn "Structure keys:"
+  print $ M.keys sMap
+  putStrLn "Edge list:"
+  print edgeList
+
+  putStrLn "------"
   putStrLn . LT.unpack . GV.printDotGraph $ GV.graphToDot params g
   let drawing =
         drawGraph
@@ -138,7 +146,7 @@ renderStructuresGraph imgRendering sMap = do
    where
     i = genStructureImage imgRendering sMap x
 
-  gEdges = makeGraphEdges $ M.elems sMap
+  gEdges = makeStructureGraphEdges $ M.elems sMap
 
   edgeList = [(m, n) | (_, n, neighbors) <- gEdges, m <- neighbors]
   nodeList = [a | (_, a, _) <- gEdges]
@@ -171,12 +179,16 @@ doRenderStructures scenarioFilepath outputFilepath = do
   (scenario, _) <- loadStandaloneScenario scenarioFilepath
 
   let sMap = scenario ^. scenarioDiagnostic . scenarioStructureMap
+      sMapWorld = view worldStructureMap . worldDiagnostic . NE.head $
+        scenario ^. scenarioLandscape . scenarioWorlds 
       aMap = scenario ^. scenarioLandscape . scenarioCosmetics
 
   sendIO $ do
     g <-
       renderStructuresGraph (ImgRendering 8 DiagonalIndicators) $
-        M.map (applyStructureColors aMap) sMap
+        M.map (applyStructureColors aMap)
+          -- sMap
+          sMapWorld
     putStrLn $ "Rendering to path: " ++ outputFilepath
     renderRasterific outputFilepath (mkWidth 2000) g
     putStrLn "Finished rendering."

src/swarm-scenario/Swarm/Game/Scenario.hs

@@ -240,7 +240,7 @@ newtype ScenarioDiagnostic = ScenarioDiagnostic
 
 makeLensesNoSigs ''ScenarioDiagnostic
 
--- | Authorship information about scenario not used at play-time
+-- | Raw structure definitions at the scenario level
 scenarioStructureMap :: Lens' ScenarioDiagnostic (M.Map Structure.StructureName (Structure.NamedStructure (Maybe Cell)))
 
 -- | A 'Scenario' contains all the information to describe a

src/swarm-scenario/Swarm/Game/Scenario/Objective/Graph.hs

@@ -123,8 +123,8 @@ makeGraph edges =
  where
   (myGraph, _, _) = graphFromEdges edges
 
-makeGraphEdges :: [Objective] -> Edges
-makeGraphEdges objectives =
+makeObjectiveGraphEdges :: [Objective] -> Edges
+makeObjectiveGraphEdges objectives =
   rootTuples <> negatedTuples
  where
   rootTuples = map f $ M.toList $ assignIds objectives
@@ -142,6 +142,6 @@ makeGraphInfo oc =
     connectedComponents
     (M.keys $ assignIds objs)
  where
-  edges = makeGraphEdges objs
+  edges = makeObjectiveGraphEdges objs
   connectedComponents = stronglyConnComp edges
   objs = oc ^.. allObjectives

src/swarm-scenario/Swarm/Game/Scenario/Objective/Validation.hs

@@ -45,5 +45,5 @@ validateObjectives objectives = do
 
   return objectives
  where
-  edges = makeGraphEdges objectives
+  edges = makeObjectiveGraphEdges objectives
   allIds = Set.fromList $ mapMaybe (view objectiveId) objectives

src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE RecordWildCards #-}
 
 -- |
@@ -9,6 +10,7 @@ module Swarm.Game.Scenario.Topography.WorldDescription where
 
 import Control.Carrier.Reader (runReader)
 import Control.Carrier.Throw.Either
+import Swarm.Util.Lens (makeLensesNoSigs)
 import Control.Monad (forM)
 import Data.Coerce
 import Data.Functor.Identity
@@ -41,15 +43,29 @@ import Swarm.Game.Scenario.Topography.Structure.Recognition.Static (LocatedStruc
 import Swarm.Game.Scenario.Topography.WorldPalette
 import Swarm.Game.Universe (SubworldName (DefaultRootSubworld))
 import Swarm.Game.World.Parse ()
+import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=))
 import Swarm.Game.World.Syntax
 import Swarm.Game.World.Typecheck
 import Swarm.Pretty (prettyString)
 import Swarm.Util.Yaml
+import Data.Map qualified as M
+import Swarm.Game.Scenario.Topography.Structure qualified as Structure
+import Swarm.Game.Scenario.Topography.Structure.Named qualified as Structure
 
 ------------------------------------------------------------
 -- World description
 ------------------------------------------------------------
 
+newtype WorldDiagnostic = WorldDiagnostic
+  { _worldStructureMap :: M.Map Structure.StructureName (Structure.NamedStructure (Maybe Cell))
+  }
+
+makeLensesNoSigs ''WorldDiagnostic
+
+-- | Raw structure definitions at the subworld level
+worldStructureMap :: Lens' WorldDiagnostic (M.Map Structure.StructureName (Structure.NamedStructure (Maybe Cell)))
+
+
 -- | A description of a world parsed from a YAML file.
 -- This type is parameterized to accommodate Cells that
 -- utilize a less stateful Entity type.
@@ -64,8 +80,8 @@ data PWorldDescription e = WorldDescription
   -- the structure recognizer
   , worldName :: SubworldName
   , worldProg :: Maybe (TTerm '[] (World CellVal))
+  , worldDiagnostic :: WorldDiagnostic
   }
-  deriving (Show)
 
 type WorldDescription = PWorldDescription Entity
 
@@ -91,10 +107,10 @@ instance FromJSONE WorldParseDependencies WorldDescription where
       withDeps $
         v ..:? "structures" ..!= []
 
-    let initialStructureDefs = scenarioLevelStructureDefs <> subworldLocalStructureDefs
-    liftE $ mkWorld tem worldMap palette initialStructureDefs v
+    liftE $ mkWorld tem worldMap palette scenarioLevelStructureDefs subworldLocalStructureDefs v
    where
-    mkWorld tem worldMap palette initialStructureDefs v = do
+    mkWorld tem worldMap palette scenarioLevelStructureDefs subworldLocalStructureDefs v = do
+      let initialStructureDefs = scenarioLevelStructureDefs <> subworldLocalStructureDefs
       MergedStructure mergedGrid staticStructurePlacements unmergedWaypoints <- do
         unflattenedStructure <- parseStructure palette initialStructureDefs v
 
@@ -128,6 +144,7 @@ instance FromJSONE WorldParseDependencies WorldDescription where
             map (offsetLoc $ coerce ul) staticStructurePlacements
 
       let area = modifyLoc ((ul .+^) . asVector) mergedGrid
+      let worldDiagnostic = WorldDiagnostic $ Assembly.makeStructureMap subworldLocalStructureDefs
       return $ WorldDescription {..}
 
 ------------------------------------------------------------

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs

@@ -8,13 +8,14 @@
 module Swarm.Game.Scenario.Topography.Structure.Assembly (
   mergeStructures,
   makeStructureMap,
-  makeGraphEdges,
+  makeStructureGraphEdges,
 
   -- * Exposed for unit tests:
   foldLayer,
 )
 where
 
+import Data.Tree
 import Control.Arrow (left, (&&&))
 import Control.Monad (when)
 import Data.Coerce
@@ -67,8 +68,12 @@ makeStructureMap = M.fromList . map (name &&& id)
 
 type GraphEdge a = (NamedStructure a, StructureName, [StructureName])
 
-makeGraphEdges :: [NamedStructure a] -> [GraphEdge a]
-makeGraphEdges =
+makeStructureDefinitionTree :: NamedStructure a -> Tree (NamedStructure a)
+makeStructureDefinitionTree s =
+  Node s . map makeStructureDefinitionTree . structures $ structure s
+
+makeStructureGraphEdges :: [NamedStructure a] -> [GraphEdge a]
+makeStructureGraphEdges =
   map makeGraphNodeWithEdges
  where
   makeGraphNodeWithEdges s =
@@ -96,7 +101,7 @@ mergeStructures inheritedStrucDefs parentPlacement baseStructure = do
 
   -- deeper definitions override the outer (toplevel) ones
   structureMap = M.union (makeStructureMap subStructures) inheritedStrucDefs
-  gEdges = makeGraphEdges $ M.elems structureMap
+  gEdges = makeStructureGraphEdges $ 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-tui/Swarm/TUI/Editor/Palette.hs

@@ -142,6 +142,7 @@ constructScenario maybeOriginalScenario cellGrid =
       , placedStructures = mempty
       , worldName = DefaultRootSubworld
       , worldProg = Nothing
+      , worldDiagnostic = WorldDiagnostic mempty
       }
 
   extractPalette = unPalette . palette . NE.head . (^. scenarioLandscape . scenarioWorlds)

src/swarm-web/Swarm/Web/GraphRender.hs

@@ -23,5 +23,5 @@ renderGoalsGraph oc =
       (\k -> maybe mempty (\(_, _, c) -> c) $ M.lookup k edgeLookup)
       ([(a, a) | (_, a, _) <- edges])
 
-  edges = makeGraphEdges objs
+  edges = makeObjectiveGraphEdges objs
   objs = oc ^.. allObjectives