Consolidate code in WorldDescription (#2071)

Closes #2069

Simplifies the code in `WorldDescription.hs` in three ways:
* extract many `liftE` invocations to a single location
* use a new `genStructure` function consolidated with `Structure.hs`
* remove a now-redundant `ul :: Location` field from `WorldDescription`

Also used this PR to remove some re-exports from `Scenario.hs`.

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

@@ -14,11 +14,6 @@
 -- tutorials and for standalone puzzles and scenarios.
 module Swarm.Game.Scenario (
   -- * WorldDescription
-  PCell (..),
-  Cell,
-  PWorldDescription (..),
-  WorldDescription,
-  IndexedTRobot,
   StructureCells,
 
   -- * Scenario

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

@@ -14,30 +14,32 @@ import Data.Coerce
 import Data.Functor.Identity
 import Data.Text qualified as T
 import Data.Yaml as Y
-import Swarm.Game.Entity
+import Swarm.Game.Entity (Entity)
 import Swarm.Game.Land
 import Swarm.Game.Location
-import Swarm.Game.Scenario.RobotLookup
+import Swarm.Game.Scenario.RobotLookup (RobotMap)
 import Swarm.Game.Scenario.Topography.Cell
-import Swarm.Game.Scenario.Topography.EntityFacade
-import Swarm.Game.Scenario.Topography.Grid (Grid (EmptyGrid))
+import Swarm.Game.Scenario.Topography.EntityFacade (EntityFacade)
 import Swarm.Game.Scenario.Topography.Navigation.Portal
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint (
   Parentage (Root),
   WaypointName,
  )
-import Swarm.Game.Scenario.Topography.ProtoCell
+import Swarm.Game.Scenario.Topography.ProtoCell (
+  StructurePalette (StructurePalette),
+ )
 import Swarm.Game.Scenario.Topography.Structure (
   LocatedStructure,
   MergedStructure (MergedStructure),
   NamedStructure,
-  PStructure (Structure),
-  paintMap,
+  parseStructure,
  )
 import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly
-import Swarm.Game.Scenario.Topography.Structure.Overlay
+import Swarm.Game.Scenario.Topography.Structure.Overlay (
+  PositionedGrid (..),
+ )
 import Swarm.Game.Scenario.Topography.WorldPalette
-import Swarm.Game.Universe
+import Swarm.Game.Universe (SubworldName (DefaultRootSubworld))
 import Swarm.Game.World.Parse ()
 import Swarm.Game.World.Syntax
 import Swarm.Game.World.Typecheck
@@ -55,10 +57,11 @@ data PWorldDescription e = WorldDescription
   { offsetOrigin :: Bool
   , scrollable :: Bool
   , palette :: WorldPalette e
-  , ul :: Location
   , area :: PositionedGrid (Maybe (PCell e))
   , navigation :: Navigation Identity WaypointName
   , placedStructures :: [LocatedStructure]
+  -- ^ statically-placed structures to pre-populate
+  -- the structure recognizer
   , worldName :: SubworldName
   , worldProg :: Maybe (TTerm '[] (World CellVal))
   }
@@ -76,25 +79,6 @@ data WorldParseDependencies
       -- | last for the benefit of partial application
       TerrainEntityMaps
 
-integrateArea ::
-  WorldPalette e ->
-  [NamedStructure (Maybe (PCell e))] ->
-  Object ->
-  Parser (MergedStructure (Maybe (PCell e)))
-integrateArea palette initialStructureDefs v = do
-  placementDefs <- v .:? "placements" .!= []
-  waypointDefs <- v .:? "waypoints" .!= []
-  rawMap <- v .:? "map" .!= EmptyGrid
-  (initialArea, mapWaypoints) <- paintMap Nothing palette rawMap
-  let unflattenedStructure =
-        Structure
-          (PositionedGrid origin initialArea)
-          initialStructureDefs
-          placementDefs
-          (waypointDefs <> mapWaypoints)
-  either (fail . T.unpack) return $
-    Assembly.mergeStructures mempty Root unflattenedStructure
-
 instance FromJSONE WorldParseDependencies WorldDescription where
   parseJSONE = withObjectE "world description" $ \v -> do
     WorldParseDependencies worldMap scenarioLevelStructureDefs rm tem <- getE
@@ -107,32 +91,41 @@ instance FromJSONE WorldParseDependencies WorldDescription where
       withDeps $
         v ..:? "structures" ..!= []
 
-    let structureDefs = scenarioLevelStructureDefs <> subworldLocalStructureDefs
-    MergedStructure area staticStructurePlacements unmergedWaypoints <-
-      liftE $ integrateArea palette structureDefs v
-
-    worldName <- liftE $ v .:? "name" .!= DefaultRootSubworld
-    ul <- liftE $ v .:? "upperleft" .!= origin
-    portalDefs <- liftE $ v .:? "portals" .!= []
-    navigation <-
-      validatePartialNavigation
-        worldName
-        ul
-        unmergedWaypoints
-        portalDefs
-
-    mwexp <- liftE $ v .:? "dsl"
-    worldProg <- forM mwexp $ \wexp -> do
-      let checkResult =
-            run . runThrow @CheckErr . runReader worldMap . runReader tem $
-              check CNil (TTyWorld TTyCell) wexp
-      either (fail . prettyString) return checkResult
-
-    offsetOrigin <- liftE $ v .:? "offset" .!= False
-    scrollable <- liftE $ v .:? "scrollable" .!= True
-    let placedStructures =
-          map (offsetLoc $ coerce ul) staticStructurePlacements
-    return $ WorldDescription {..}
+    let initialStructureDefs = scenarioLevelStructureDefs <> subworldLocalStructureDefs
+    liftE $ mkWorld tem worldMap palette initialStructureDefs v
+   where
+    mkWorld tem worldMap palette initialStructureDefs v = do
+      MergedStructure mergedGrid staticStructurePlacements unmergedWaypoints <- do
+        unflattenedStructure <- parseStructure palette initialStructureDefs v
+        either (fail . T.unpack) return $
+          Assembly.mergeStructures mempty Root unflattenedStructure
+
+      worldName <- v .:? "name" .!= DefaultRootSubworld
+      ul <- v .:? "upperleft" .!= origin
+      portalDefs <- v .:? "portals" .!= []
+      navigation <-
+        validatePartialNavigation
+          worldName
+          ul
+          unmergedWaypoints
+          portalDefs
+
+      mwexp <- v .:? "dsl"
+      worldProg <- forM mwexp $ \wexp -> do
+        let checkResult =
+              run . runThrow @CheckErr . runReader worldMap . runReader tem $
+                check CNil (TTyWorld TTyCell) wexp
+        either (fail . prettyString) return checkResult
+
+      offsetOrigin <- v .:? "offset" .!= False
+      scrollable <- v .:? "scrollable" .!= True
+      let placedStructures =
+            map (offsetLoc $ coerce ul) staticStructurePlacements
+
+      -- Override upper-left corner with explicit location
+      let area = mergedGrid {gridPosition = ul}
+
+      return $ WorldDescription {..}
 
 ------------------------------------------------------------
 -- World editor
@@ -147,7 +140,7 @@ instance ToJSON WorldDescriptionPaint where
     object
       [ "offset" .= offsetOrigin w
       , "palette" .= Y.toJSON paletteKeymap
-      , "upperleft" .= ul w
+      , "upperleft" .= gridPosition (area w)
       , "map" .= Y.toJSON mapText
       ]
    where

src/swarm-scenario/Swarm/Game/State/Landscape.hs

@@ -39,10 +39,13 @@ import Swarm.Game.Land
 import Swarm.Game.Location
 import Swarm.Game.Robot (TRobot, trobotLocation)
 import Swarm.Game.Scenario
+import Swarm.Game.Scenario.RobotLookup (IndexedTRobot)
 import Swarm.Game.Scenario.Topography.Area
+import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..))
 import Swarm.Game.Scenario.Topography.Structure.Overlay
+import Swarm.Game.Scenario.Topography.WorldDescription
 import Swarm.Game.State.Config
 import Swarm.Game.Terrain (TerrainType (..), terrainIndexByName)
 import Swarm.Game.Universe as U
@@ -134,17 +137,14 @@ buildWorld tem WorldDescription {..} =
 
   g = gridContent area
 
-  ulOffset = origin .-. gridPosition area
-  ulModified = ul .+^ ulOffset
-
   worldGrid :: Grid (TerrainType, Erasable Entity)
   worldGrid = maybe (BlankT, ENothing) (cellTerrain &&& cellEntity) <$> g
 
   offsetCoordsByArea :: Coords -> AreaDimensions -> Coords
   offsetCoordsByArea x a =
     x `addTuple` swap (asTuple a)
 
-  coords = locToCoords ulModified
+  coords = locToCoords $ gridPosition area
 
   arrayMaxBound =
     both (subtract 1)

src/swarm-scenario/Swarm/Game/World/Render.hs

@@ -29,6 +29,7 @@ import Swarm.Game.Scenario.Topography.EntityFacade (EntityFacade (..), mkFacade)
 import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Scenario.Topography.Rasterize
 import Swarm.Game.Scenario.Topography.Structure.Overlay
+import Swarm.Game.Scenario.Topography.WorldDescription
 import Swarm.Game.State.Landscape
 import Swarm.Game.Universe
 import Swarm.Game.World.Coords
@@ -106,7 +107,7 @@ getBoundingBox vc scenarioWorld maybeSize =
  where
   upperLeftLocation =
     if null maybeSize && not (isEmpty mapAreaDims)
-      then ul scenarioWorld
+      then gridPosition $ area scenarioWorld
       else vc .+^ ((`div` 2) <$> V2 (negate w) h)
 
   mkBoundingBox areaDimens upperLeftLoc =

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

@@ -100,19 +100,26 @@ instance FromJSON (Grid Char) where
           fail "Grid is not rectangular!"
         return g
 
+parseStructure ::
+  StructurePalette c ->
+  [NamedStructure (Maybe c)] ->
+  Object ->
+  Parser (PStructure (Maybe c))
+parseStructure pal structures v = do
+  placements <- v .:? "placements" .!= []
+  waypointDefs <- v .:? "waypoints" .!= []
+  maybeMaskChar <- v .:? "mask"
+  rawGrid <- v .:? "map" .!= EmptyGrid
+  (maskedArea, mapWaypoints) <- paintMap maybeMaskChar pal rawGrid
+  let area = PositionedGrid origin maskedArea
+      waypoints = waypointDefs <> mapWaypoints
+  return Structure {..}
+
 instance (FromJSONE e a) => FromJSONE e (PStructure (Maybe a)) where
   parseJSONE = withObjectE "structure definition" $ \v -> do
     pal <- v ..:? "palette" ..!= StructurePalette mempty
     structures <- v ..:? "structures" ..!= []
-    liftE $ do
-      placements <- v .:? "placements" .!= []
-      waypointDefs <- v .:? "waypoints" .!= []
-      maybeMaskChar <- v .:? "mask"
-      rawGrid <- v .:? "map" .!= EmptyGrid
-      (maskedArea, mapWaypoints) <- paintMap maybeMaskChar pal rawGrid
-      let area = PositionedGrid origin maskedArea
-          waypoints = waypointDefs <> mapWaypoints
-      return Structure {..}
+    liftE $ parseStructure pal structures v
 
 -- | \"Paint\" a world map using a 'WorldPalette', turning it from a raw
 --   string into a nested list of 'PCell' values by looking up each

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

@@ -20,6 +20,7 @@ import Swarm.Util (applyWhen)
 
 data PositionedGrid a = PositionedGrid
   { gridPosition :: Location
+  -- ^ location of the upper-left cell
   , gridContent :: Grid a
   }
   deriving (Eq)

src/swarm-tui/Swarm/TUI/Editor/Palette.hs

@@ -30,6 +30,7 @@ import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..))
 import Swarm.Game.Scenario.Topography.ProtoCell
 import Swarm.Game.Scenario.Topography.Structure.Overlay
+import Swarm.Game.Scenario.Topography.WorldDescription
 import Swarm.Game.Scenario.Topography.WorldPalette
 import Swarm.Game.Terrain (TerrainMap, TerrainType, getTerrainDefaultPaletteChar, terrainByName)
 import Swarm.Game.Universe
@@ -139,7 +140,6 @@ constructScenario maybeOriginalScenario cellGrid =
       { offsetOrigin = False
       , scrollable = True
       , palette = StructurePalette suggestedPalette
-      , ul = upperLeftCoord
       , area = PositionedGrid upperLeftCoord cellGrid
       , navigation = Navigation mempty mempty
       , placedStructures = mempty

src/swarm-tui/Swarm/TUI/Editor/Util.hs

@@ -35,7 +35,7 @@ getEditingBounds myWorld =
   (EA.isEmpty a, newBounds)
  where
   newBounds = Cosmic DefaultRootSubworld (locToCoords upperLeftLoc, locToCoords lowerRightLoc)
-  upperLeftLoc = ul myWorld
+  upperLeftLoc = gridPosition $ area myWorld
   a = EA.getGridDimensions $ gridContent $ area myWorld
   lowerRightLoc = EA.computeBottomRightFromUpperLeft a upperLeftLoc