structure grid expansion (#1826)

Closes #1780.

This change allows "child" structures to be placed outside of the bounds of their "parent" map.  Until now, any child structures that exceed the bounds of their parent were simply truncated.

# Demo
```
scripts/play.sh -i data/scenarios/Testing/1780-structure-merge-expansion/structure-composition.yaml
```

data/scenarios/Testing/00-ORDER.txt

@@ -62,4 +62,5 @@ Achievements
 1747-volume-command.yaml
 1777-capability-cost.yaml
 1775-custom-terrain.yaml
-1642-biomes.yaml
+1642-biomes.yaml
+1780-structure-merge-expansion

data/scenarios/Testing/1780-structure-merge-expansion/00-ORDER.txt

@@ -0,0 +1,3 @@
+nonoverlapping-structure-merge.yaml
+root-map-expansion.yaml
+structure-composition.yaml

data/scenarios/Testing/1780-structure-merge-expansion/nonoverlapping-structure-merge.yaml

@@ -0,0 +1,61 @@
+version: 1
+name: Expansion of a substructure to fit its placements
+description: |
+  Define two structures and place them on the map.
+robots:
+  - name: base
+    loc: [4, -4]
+    dir: east
+known: [water, sand, tree]
+world:
+  palette:
+    '.': [grass]
+  upperleft: [-1, 1]
+  structures:
+    - name: vertical rectangle
+      structure:
+        palette:
+          'x': [blank, tree]
+        map: |
+          xx
+          xx
+          xx
+          xx
+    - name: horizontal rectangle
+      structure:
+        palette:
+          'x': [blank, sand]
+        map: |
+          xxxx
+          xxxx
+    - name: disjoint rectangles
+      structure:
+        palette:
+          'x': [blank, water]
+        map: |
+          xx
+          xx
+        placements:
+          - src: vertical rectangle
+            truncate: false
+            offset: [-7, 7]
+          - src: horizontal rectangle
+            truncate: false
+            offset: [7, -7]
+  placements:
+    - src: disjoint rectangles
+      offset: [2, -2]
+  map: |
+    ...............
+    ...............
+    ...............
+    ...............
+    ...............
+    ...............
+    ...............
+    ...............
+    ...............
+    ...............
+    ...............
+    ...............
+    ...............

data/scenarios/Testing/1780-structure-merge-expansion/root-map-expansion.yaml

@@ -0,0 +1,34 @@
+version: 1
+name: Non-overlapping merging with expansion
+description: |
+  Define two structures and place them on the map.
+
+  Demonstrates automatic expansion of the root map grid.
+robots:
+  - name: base
+    loc: [8, 0]
+    dir: east
+known: [tree, sand, water]
+world:
+  palette:
+    '.': [grass]
+    'i': [ice]
+    'j': [dirt]
+    'k': [stone]
+    'l': [stone, sand]
+    'm': [stone, water]
+  upperleft: [3, 3]
+  structures:
+    - name: single tree
+      structure:
+        palette:
+          'x': [blank, tree]
+        map: |
+          x
+  placements:
+    - src: single tree
+      truncate: false
+      offset: [-2, -4]
+  map: |
+    i.
+    .j

data/scenarios/Testing/1780-structure-merge-expansion/structure-composition.yaml

@@ -0,0 +1,111 @@
+version: 1
+name: Various structure merging arrangements
+description: |
+  Define two structures and place them on the map.
+robots:
+  - name: base
+    loc: [11, 0]
+    dir: east
+known: [water, sand]
+world:
+  palette:
+    '.': [grass]
+  upperleft: [-1, 1]
+  structures:
+    - name: vertical rectangle
+      structure:
+        palette:
+          'x': [blank, water]
+        map: |
+          xx
+          xx
+          xx
+          xx
+    - name: horizontal rectangle
+      structure:
+        palette:
+          'x': [blank, sand]
+        map: |
+          xxxx
+          xxxx
+    - name: combined rectangles blank base
+      structure:
+        palette:
+          'x': [blank]
+        map: |
+          xxxx
+          xxxx
+          xxxx
+          xxxx
+        placements:
+          - src: vertical rectangle
+          - src: horizontal rectangle
+    - name: combined rectangles empty base
+      structure:
+        palette:
+          'x': [blank]
+        map: ""
+        placements:
+          - src: vertical rectangle
+            truncate: false
+          - src: horizontal rectangle
+            truncate: false
+    - name: combined rectangles single cell base
+      structure:
+        palette:
+          'x': [blank]
+        map: |
+          x
+        placements:
+          - src: vertical rectangle
+            truncate: false
+          - src: horizontal rectangle
+            truncate: false
+    - name: multi overlap
+      structure:
+        palette:
+          'x': [blank]
+        map: |
+          xxxx
+        placements:
+          - src: vertical rectangle
+            offset: [1, 0]
+            truncate: false
+          - src: horizontal rectangle
+            truncate: false
+            offset: [0, -2]
+          - src: vertical rectangle
+            offset: [3, -2]
+            truncate: false
+          - src: horizontal rectangle
+            truncate: false
+            offset: [3, -4]
+          - src: vertical rectangle
+            offset: [5, -4]
+            truncate: false
+  placements:
+    - src: vertical rectangle
+      offset: [1, -1]
+    - src: horizontal rectangle
+      offset: [1, -1]
+    - src: multi overlap
+      offset: [1, -6]
+      truncate: false
+    - src: combined rectangles blank base
+      offset: [6, -1]
+    - src: combined rectangles empty base
+      offset: [11, -1]
+    - src: combined rectangles single cell base
+      offset: [11, -6]
+  map: |
+    ................
+    ................
+    ................
+    ................
+    ................
+    ................
+    ................
+    ................
+    ................
+    ................
+    ................

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

@@ -99,6 +99,7 @@ import Swarm.Game.Scenario.Topography.Navigation.Portal
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint (Parentage (..))
 import Swarm.Game.Scenario.Topography.Structure qualified as Structure
 import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly
+import Swarm.Game.Scenario.Topography.Structure.Overlay
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (SymmetryAnnotatedGrid (..))
 import Swarm.Game.Scenario.Topography.WorldDescription
@@ -336,7 +337,7 @@ instance FromJSONE ScenarioInputs Scenario where
             (sequenceA . (id &&& (Assembly.mergeStructures mempty Root . Structure.structure)))
             rootLevelSharedStructures
 
-      let namedGrids = map (\(ns, Structure.MergedStructure s _ _) -> s <$ ns) mergedStructures
+      let namedGrids = map (\(ns, Structure.MergedStructure (PositionedGrid _ s) _ _) -> s <$ ns) mergedStructures
 
       allWorlds <- localE (WorldParseDependencies worldMap rootLevelSharedStructures rsMap) $ do
         rootWorld <- v ..: "world"

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

@@ -16,6 +16,12 @@ newtype Grid c = Grid
   }
   deriving (Show, Eq, Functor, Foldable, Traversable)
 
+-- | Since the derived 'Functor' instance applies to the
+-- type parameter that is nested within lists, we define
+-- an explicit function for mapping over the enclosing lists.
+mapRows :: ([[a]] -> [[b]]) -> Grid a -> Grid b
+mapRows f (Grid rows) = Grid $ f rows
+
 instance (ToJSON a) => ToJSON (Grid a) where
   toJSON (Grid g) = toJSON g
 
@@ -41,21 +47,25 @@ invertY (V2 x y) = V2 x (-y)
 -- | Incorporates an offset by @-1@, since the area is
 -- "inclusive" of the lower-right coordinate.
 -- Inverse of 'cornersToArea'.
-upperLeftToBottomRight :: AreaDimensions -> Location -> Location
-upperLeftToBottomRight (AreaDimensions w h) upperLeft =
+computeBottomRightFromUpperLeft :: AreaDimensions -> Location -> Location
+computeBottomRightFromUpperLeft a upperLeft =
   upperLeft .+^ displacement
  where
-  displacement = invertY $ subtract 1 <$> V2 w h
+  displacement = invertY $ computeAbsoluteCornerDisplacement a
+
+computeAbsoluteCornerDisplacement :: AreaDimensions -> V2 Int32
+computeAbsoluteCornerDisplacement (AreaDimensions w h) =
+  subtract 1 <$> V2 w h
 
 -- | Converts the displacement vector between the two
 -- diagonal corners of the rectangle into an 'AreaDimensions' record.
 -- Adds one to both dimensions since the corner coordinates are "inclusive".
--- Inverse of 'upperLeftToBottomRight'.
+-- Inverse of 'computeBottomRightFromUpperLeft'.
 cornersToArea :: Location -> Location -> AreaDimensions
-cornersToArea upperLeft lowerRight =
+cornersToArea upperLeft bottomRight =
   AreaDimensions x y
  where
-  V2 x y = (+ 1) <$> invertY (lowerRight .-. upperLeft)
+  V2 x y = (+ 1) <$> invertY (bottomRight .-. upperLeft)
 
 -- | Has zero width or height.
 isEmpty :: AreaDimensions -> Bool
@@ -71,3 +81,9 @@ getAreaDimensions cellGrid =
 
 computeArea :: AreaDimensions -> Int32
 computeArea (AreaDimensions w h) = w * h
+
+fillGrid :: AreaDimensions -> a -> Grid a
+fillGrid (AreaDimensions w h) =
+  Grid
+    . replicate (fromIntegral h)
+    . replicate (fromIntegral w)

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

@@ -21,6 +21,7 @@ import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint
 import Swarm.Game.Scenario.Topography.Placement
+import Swarm.Game.Scenario.Topography.Structure.Overlay
 import Swarm.Game.Scenario.Topography.WorldPalette
 import Swarm.Language.Syntax.Direction (AbsoluteDir)
 import Swarm.Util (failT, showT)
@@ -60,7 +61,7 @@ instance FromJSONE (TerrainEntityMaps, RobotMap) (NamedArea (PStructure (Maybe C
         ..: "structure"
 
 data PStructure c = Structure
-  { area :: Grid c
+  { area :: PositionedGrid c
   , structures :: [NamedStructure c]
   -- ^ structure definitions from parents shall be accessible by children
   , placements :: [Placement]
@@ -84,7 +85,7 @@ instance HasLocation LocatedStructure where
   modifyLoc f (LocatedStructure x y originalLoc) =
     LocatedStructure x y $ f originalLoc
 
-data MergedStructure c = MergedStructure (Grid c) [LocatedStructure] [Originated Waypoint]
+data MergedStructure c = MergedStructure (PositionedGrid c) [LocatedStructure] [Originated Waypoint]
 
 instance FromJSONE (TerrainEntityMaps, RobotMap) (PStructure (Maybe Cell)) where
   parseJSONE = withObjectE "structure definition" $ \v -> do
@@ -98,7 +99,7 @@ instance FromJSONE (TerrainEntityMaps, RobotMap) (PStructure (Maybe Cell)) where
       (maskedArea, mapWaypoints) <- (v .:? "map" .!= "") >>= paintMap maybeMaskChar pal
       return $
         Structure
-          (Grid maskedArea)
+          (PositionedGrid origin $ Grid maskedArea)
           localStructureDefs
           placementDefs
           (waypointDefs <> mapWaypoints)

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

@@ -20,11 +20,13 @@ import Data.Map qualified as M
 import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Text qualified as T
+import Linear.Affine
 import Swarm.Game.Location
 import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint
 import Swarm.Game.Scenario.Topography.Placement
 import Swarm.Game.Scenario.Topography.Structure
+import Swarm.Game.Scenario.Topography.Structure.Overlay
 import Swarm.Language.Syntax.Direction (directionJsonModifier)
 import Swarm.Util (commaList, quote, showT)
 
@@ -38,18 +40,23 @@ overlaySingleStructure ::
   Either Text (MergedStructure (Maybe a))
 overlaySingleStructure
   inheritedStrucDefs
-  (Placed p@(Placement _ _shouldTruncate pose@(Pose loc orientation)) ns)
+  (Placed p@(Placement _ shouldTruncate pose@(Pose loc orientation)) ns)
   (MergedStructure inputArea inputPlacements inputWaypoints) = do
     MergedStructure overlayArea overlayPlacements overlayWaypoints <-
       mergeStructures inheritedStrucDefs (WithParent p) $ structure ns
 
     let mergedWaypoints = inputWaypoints <> map (fmap $ placeOnArea overlayArea) overlayWaypoints
         mergedPlacements = inputPlacements <> map (placeOnArea overlayArea) overlayPlacements
-        mergedArea = overlayGrid inputArea pose overlayArea
+        mergedArea = mergeFunc (gridContent inputArea) pose overlayArea
 
     return $ MergedStructure mergedArea mergedPlacements mergedWaypoints
    where
-    placeOnArea overArea =
+    mergeFunc =
+      if shouldTruncate
+        then overlayGridTruncated
+        else overlayGridExpanded
+
+    placeOnArea (PositionedGrid _ overArea) =
       offsetLoc (coerce loc)
         . modifyLoc (reorientLandmark orientation $ getGridDimensions overArea)
 
@@ -92,18 +99,34 @@ mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStruct
 
 -- * Grid manipulation
 
-overlayGrid ::
+overlayGridExpanded ::
   Grid (Maybe a) ->
   Pose ->
+  PositionedGrid (Maybe a) ->
+  PositionedGrid (Maybe a)
+overlayGridExpanded
+  inputGrid
+  (Pose loc orientation)
+  (PositionedGrid _ (Grid overlayArea)) =
+    PositionedGrid origin inputGrid <> positionedOverlay
+   where
+    reorientedOverlayCells = Grid $ applyOrientationTransform orientation overlayArea
+    positionedOverlay = PositionedGrid loc reorientedOverlayCells
+
+-- | NOTE: This ignores the 'loc' parameter of 'PositionedGrid'.
+overlayGridTruncated ::
   Grid (Maybe a) ->
-  Grid (Maybe a)
-overlayGrid
+  Pose ->
+  PositionedGrid (Maybe a) ->
+  PositionedGrid (Maybe a)
+overlayGridTruncated
   (Grid inputArea)
   (Pose (Location colOffset rowOffset) orientation)
-  (Grid overlayArea) =
-    Grid $
-      zipWithPad mergeSingleRow inputArea $
-        paddedOverlayRows overlayArea
+  (PositionedGrid _ (Grid overlayArea)) =
+    PositionedGrid origin
+      . Grid
+      . zipWithPad mergeSingleRow inputArea
+      $ paddedOverlayRows overlayArea
    where
     zipWithPad f a b = zipWith f a $ b <> repeat Nothing
 

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

@@ -0,0 +1,163 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- Generic overlay operations on grids
+module Swarm.Game.Scenario.Topography.Structure.Overlay (
+  PositionedGrid (..),
+) where
+
+import Control.Applicative
+import Data.Function (on)
+import Data.Int (Int32)
+import Data.Tuple (swap)
+import Linear
+import Swarm.Game.Location
+import Swarm.Game.Scenario.Topography.Area
+import Swarm.Util (applyWhen)
+
+data PositionedGrid a = PositionedGrid
+  { gridPosition :: Location
+  , gridContent :: Grid a
+  }
+  deriving (Eq)
+
+instance Show (PositionedGrid a) where
+  show (PositionedGrid p g) =
+    unwords
+      [ "Grid with dimension"
+      , renderRectDimensions $ getGridDimensions g
+      , "located at"
+      , show p
+      ]
+
+data OverlayPair a = OverlayPair
+  { _base :: a
+  , _overlay :: a
+  }
+
+-- | Has a 'Semigroup' instance to determine the smallest
+-- bounds that enclose two rectangles
+data SubsumingRect = SubsumingRect
+  { _northwestCorner :: Location
+  , _southeastCorner :: Location
+  }
+
+-- | @r1 <> r2@ is the smallest rectangle that contains both @r1@ and @r2@.
+instance Semigroup SubsumingRect where
+  SubsumingRect (Location ulx1 uly1) (Location brx1 bry1)
+    <> SubsumingRect (Location ulx2 uly2) (Location brx2 bry2) =
+      SubsumingRect (Location westernMostX northernMostY) (Location easternMostX southernMostY)
+     where
+      westernMostX = min ulx1 ulx2
+      northernMostY = max uly1 uly2
+      easternMostX = max brx1 brx2
+      southernMostY = min bry1 bry2
+
+getSubsumingRect :: PositionedGrid a -> SubsumingRect
+getSubsumingRect (PositionedGrid loc g) =
+  SubsumingRect loc $ computeBottomRightFromUpperLeft (getGridDimensions g) loc
+
+computeMergedArea :: OverlayPair (PositionedGrid a) -> AreaDimensions
+computeMergedArea (OverlayPair pg1 pg2) =
+  cornersToArea ul br
+ where
+  SubsumingRect ul br = ((<>) `on` getSubsumingRect) pg1 pg2
+
+zipGridRows ::
+  Alternative f =>
+  AreaDimensions ->
+  OverlayPair (Grid (f a)) ->
+  Grid (f a)
+zipGridRows dims (OverlayPair (Grid paddedBaseRows) (Grid paddedOverlayRows)) =
+  mapRows (pad2D paddedBaseRows . pad2D paddedOverlayRows) emptyGrid
+ where
+  -- Right-bias; that is, take the last non-empty value
+  pad2D = zipPadded $ zipPadded $ flip (<|>)
+  emptyGrid = fillGrid dims empty
+
+-- |
+-- First arg: base layer
+-- Second arg: overlay layer
+--
+-- The upper-left corner of the base layer is the original "origin".
+--
+-- If the overlay is to the west or north of the base layer,
+-- then we must pad the base layer on the left or top.
+-- And since the area expands relative to the "origin" of the
+-- base layer, we must shift the combined grid's "origin" location
+-- to the new position of the base layer's upper-left corner.
+--
+-- If the overlay is to the east/south, we do not have to
+-- modify the origin, since no padding is added to the left/top
+-- of the base layer.
+instance (Alternative f) => Semigroup (PositionedGrid (f a)) where
+  a1@(PositionedGrid baseLoc baseGrid) <> a2@(PositionedGrid overlayLoc overlayGrid) =
+    PositionedGrid newOrigin combinedGrid
+   where
+    mergedSize = computeMergedArea $ OverlayPair a1 a2
+    combinedGrid = zipGridRows mergedSize paddedOverlayPair
+
+    -- We subtract the base origin from the
+    -- overlay position, such that the displacement vector
+    -- will have:
+    -- \* negative X component if the origin must be shifted east
+    -- \* positive Y component if the origin must be shifted south
+    originDelta@(V2 deltaX deltaY) = overlayLoc .-. baseLoc
+    -- Note that the adjustment vector will only ever have
+    -- a non-negative X component (i.e. loc of upper-left corner must be shifted east) and
+    -- a non-positive Y component (i.e. loc of upper-left corner must be shifted south).
+    -- We don't have to adjust the origin if the base layer lies
+    -- to the northwest of the overlay layer.
+    clampedDelta = V2 (min 0 deltaX) (max 0 deltaY)
+    newOrigin = baseLoc .-^ clampedDelta
+
+    paddedOverlayPair =
+      padSouthwest originDelta $
+        OverlayPair baseGrid overlayGrid
+
+-- | NOTE: We only make explicit grid adjustments for
+-- left/top padding.  Any padding that is needed on the right/bottom
+-- of either grid will be taken care of by the 'zipPadded' function.
+padSouthwest ::
+  Alternative f =>
+  V2 Int32 ->
+  OverlayPair (Grid (f a)) ->
+  OverlayPair (Grid (f a))
+padSouthwest (V2 deltaX deltaY) (OverlayPair baseGrid overlayGrid) =
+  OverlayPair paddedBaseGrid paddedOverlayGrid
+ where
+  prefixPadDimension delta f = mapRows $ f (padding <>)
+   where
+    padding = replicate (abs $ fromIntegral delta) empty
+
+  prefixPadRows = prefixPadDimension deltaY id
+  prefixPadColumns = prefixPadDimension deltaX map
+
+  -- Assume only the *overlay* requires vertical (top-)padding.
+  -- However, if the conditional is true, then
+  -- the *base* needs vertical padding instead.
+  (baseVerticalPadFunc, overlayVerticalPadFunc) =
+    applyWhen (deltaY > 0) swap (id, prefixPadRows)
+
+  -- Assume only the *overlay* requires horizontal (left-)padding.
+  -- However, if the conditional is true, then
+  -- the *base* needs horizontal padding instead.
+  (baseHorizontalPadFunc, overlayHorizontalPadFunc) =
+    applyWhen (deltaX < 0) swap (id, prefixPadColumns)
+
+  paddedBaseGrid = baseVerticalPadFunc $ baseHorizontalPadFunc baseGrid
+  paddedOverlayGrid = overlayVerticalPadFunc $ overlayHorizontalPadFunc overlayGrid
+
+-- * Utils
+
+-- | Apply a function to combine elements from two lists
+-- of potentially different lengths.
+-- Produces a result with length equal to the longer list.
+-- Elements from the longer list are placed directly in the
+-- resulting list when the shorter list runs out of elements.
+zipPadded :: (a -> a -> a) -> [a] -> [a] -> [a]
+zipPadded _ [] ys = ys
+zipPadded _ xs [] = xs
+zipPadded f (x : xs) (y : ys) = f x y : zipPadded f xs ys

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

@@ -11,7 +11,6 @@ import Control.Carrier.Throw.Either
 import Control.Monad (forM)
 import Data.Coerce
 import Data.Functor.Identity
-import Data.Maybe (catMaybes)
 import Data.Text qualified as T
 import Data.Yaml as Y
 import Swarm.Game.Entity
@@ -34,6 +33,7 @@ import Swarm.Game.Scenario.Topography.Structure (
  )
 import Swarm.Game.Scenario.Topography.Structure qualified as Structure
 import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly
+import Swarm.Game.Scenario.Topography.Structure.Overlay
 import Swarm.Game.Scenario.Topography.WorldPalette
 import Swarm.Game.Universe
 import Swarm.Game.World.Parse ()
@@ -54,7 +54,7 @@ data PWorldDescription e = WorldDescription
   , scrollable :: Bool
   , palette :: WorldPalette e
   , ul :: Location
-  , area :: [[PCell e]]
+  , area :: PositionedGrid (Maybe (PCell e))
   , navigation :: Navigation Identity WaypointName
   , placedStructures :: [LocatedStructure]
   , worldName :: SubworldName
@@ -91,7 +91,7 @@ instance FromJSONE WorldParseDependencies WorldDescription where
     let initialStructureDefs = scenarioLevelStructureDefs <> rootWorldStructureDefs
         struc =
           Structure
-            (Grid initialArea)
+            (PositionedGrid origin $ Grid initialArea)
             initialStructureDefs
             placementDefs
             (waypointDefs <> mapWaypoints)
@@ -121,7 +121,7 @@ instance FromJSONE WorldParseDependencies WorldDescription where
       <*> liftE (v .:? "scrollable" .!= True)
       <*> pure pal
       <*> pure upperLeft
-      <*> pure (map catMaybes $ unGrid mergedArea) -- Root-level map has no transparent cells.
+      <*> pure mergedArea
       <*> pure validatedNavigation
       <*> pure absoluteStructurePlacements
       <*> pure subWorldName
@@ -144,6 +144,6 @@ instance ToJSON WorldDescriptionPaint where
       , "map" .= Y.toJSON mapText
       ]
    where
-    cellGrid = area w
-    suggestedPalette = palette w
+    cellGrid = gridContent $ area w
+    suggestedPalette = PaletteAndMaskChar (palette w) Nothing
     (mapText, paletteKeymap) = prepForJson suggestedPalette cellGrid

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

@@ -9,6 +9,7 @@ import Control.Lens hiding (from, (.=), (<.>))
 import Data.Aeson.KeyMap (KeyMap)
 import Data.Aeson.KeyMap qualified as KM
 import Data.Map qualified as M
+import Data.Maybe (catMaybes)
 import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Text qualified as T
@@ -16,6 +17,7 @@ import Data.Tuple (swap)
 import Swarm.Game.Entity
 import Swarm.Game.Land
 import Swarm.Game.Scenario.RobotLookup
+import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.EntityFacade
 import Swarm.Game.Terrain (TerrainType)
@@ -28,7 +30,9 @@ newtype WorldPalette e = WorldPalette
   deriving (Eq, Show)
 
 instance FromJSONE (TerrainEntityMaps, RobotMap) (WorldPalette Entity) where
-  parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE
+  parseJSONE =
+    withObjectE "palette" $
+      fmap WorldPalette . mapM parseJSONE
 
 type TerrainWith a = (TerrainType, Erasable a)
 
@@ -70,19 +74,23 @@ constructPalette mappedPairs =
 
 constructWorldMap ::
   [(Char, TerrainWith EntityFacade)] ->
-  [[CellPaintDisplay]] ->
+  -- | Mask char
+  Char ->
+  Grid (Maybe CellPaintDisplay) ->
   Text
-constructWorldMap mappedPairs =
-  T.unlines . map (T.pack . map renderMapCell)
+constructWorldMap mappedPairs maskChar =
+  T.unlines . map (T.pack . map renderMapCell) . unGrid
  where
   invertedMappedPairs = map (swap . fmap toKey) mappedPairs
 
-  renderMapCell c =
-    -- NOTE: This lookup should never fail
-    M.findWithDefault (error "Palette lookup failed!") k $
-      M.fromList invertedMappedPairs
-   where
-    k = toKey $ cellToTerrainPair c
+  renderMapCell maybeC = case maybeC of
+    Nothing -> maskChar
+    Just c ->
+      -- NOTE: This lookup should never fail
+      M.findWithDefault (error "Palette lookup failed!") k $
+        M.fromList invertedMappedPairs
+     where
+      k = toKey $ cellToTerrainPair c
 
 -- | All alphanumeric characters. These are used as supplemental
 -- map placeholders in case a pre-existing display character is
@@ -90,15 +98,21 @@ constructWorldMap mappedPairs =
 genericCharacterPool :: Set.Set Char
 genericCharacterPool = Set.fromList $ ['A' .. 'Z'] <> ['a' .. 'z'] <> ['0' .. '9']
 
+data PaletteAndMaskChar = PaletteAndMaskChar
+  { paletteEntries :: WorldPalette EntityFacade
+  , reservedMaskChar :: Maybe Char
+  -- ^ represents a transparent cell
+  }
+
 -- | Note that display characters are not unique
 -- across different entities! However, the palette KeyMap
 -- as a conveyance serves to dedupe them.
 prepForJson ::
-  WorldPalette EntityFacade ->
-  [[CellPaintDisplay]] ->
+  PaletteAndMaskChar ->
+  Grid (Maybe CellPaintDisplay) ->
   (Text, KM.KeyMap CellPaintDisplay)
-prepForJson (WorldPalette suggestedPalette) cellGrid =
-  (constructWorldMap mappedPairs cellGrid, constructPalette mappedPairs)
+prepForJson (PaletteAndMaskChar (WorldPalette suggestedPalette) maybeMaskChar) cellGrid =
+  (constructWorldMap mappedPairs maskCharacter cellGrid, constructPalette mappedPairs)
  where
   preassignments :: [(Char, TerrainWith EntityFacade)]
   preassignments =
@@ -107,7 +121,7 @@ prepForJson (WorldPalette suggestedPalette) cellGrid =
         KM.toMapText suggestedPalette
 
   entityCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
-  entityCells = getUniqueTerrainFacadePairs cellGrid
+  entityCells = getUniqueTerrainFacadePairs $ map catMaybes $ unGrid cellGrid
 
   unassignedCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
   unassignedCells =
@@ -115,11 +129,17 @@ prepForJson (WorldPalette suggestedPalette) cellGrid =
       Set.fromList $
         map (toKey . snd) preassignments
 
+  (maskCharacter, availableCharacterPool) = case maybeMaskChar of
+    Just c -> (c, genericCharacterPool)
+    Nothing -> Set.deleteFindMin genericCharacterPool
+
   unassignedCharacters :: Set.Set Char
   unassignedCharacters =
     -- TODO (#1149): How can we efficiently use the Unicode categories (in "Data.Char")
     -- to generate this pool?
-    Set.difference genericCharacterPool $
+    Set.difference availableCharacterPool usedCharacters
+   where
+    usedCharacters =
       Set.fromList $
         map fst preassignments
 

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

@@ -24,7 +24,7 @@ module Swarm.Game.State.Landscape (
 ) where
 
 import Control.Arrow (Arrow ((&&&)))
-import Control.Lens hiding (Const, use, uses, (%=), (+=), (.=), (<+=), (<<.=))
+import Control.Lens hiding (Const, both, use, uses, (%=), (+=), (.=), (<+=), (<<.=))
 import Data.Array (Array, listArray)
 import Data.Bifunctor (first)
 import Data.Int (Int32)
@@ -32,17 +32,21 @@ import Data.List (sortOn)
 import Data.List.NonEmpty (NonEmpty)
 import Data.List.NonEmpty qualified as NE
 import Data.Map qualified as M
-import Data.Maybe (isJust, listToMaybe)
+import Data.Maybe (isJust)
+import Data.Tuple.Extra (both, swap)
 import Swarm.Game.Entity
 import Swarm.Game.Land
 import Swarm.Game.Location
 import Swarm.Game.Robot (TRobot, trobotLocation)
 import Swarm.Game.Scenario
+import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..))
+import Swarm.Game.Scenario.Topography.Structure.Overlay
 import Swarm.Game.State.Config
 import Swarm.Game.Terrain (TerrainType (..), terrainIndexByName)
 import Swarm.Game.Universe as U
 import Swarm.Game.World
+import Swarm.Game.World.Coords (addTuple)
 import Swarm.Game.World.Eval (runWorld)
 import Swarm.Game.World.Gen (Seed, findGoodOrigin)
 import Swarm.Util (applyWhen)
@@ -115,37 +119,59 @@ genMultiWorld worldTuples s =
 
 -- | Take a world description, parsed from a scenario file, and turn
 --   it into a list of located robots and a world function.
-buildWorld :: TerrainEntityMaps -> WorldDescription -> ([IndexedTRobot], Seed -> WorldFun Int Entity)
+buildWorld ::
+  TerrainEntityMaps ->
+  WorldDescription ->
+  ([IndexedTRobot], Seed -> WorldFun Int Entity)
 buildWorld tem WorldDescription {..} =
   (robots worldName, first getTerrainIndex . wf)
  where
-  getTerrainIndex t = M.findWithDefault 0 t $ terrainIndexByName $ tem ^. terrainMap
-  rs = fromIntegral $ length area
-  cs = fromIntegral $ maybe 0 length $ listToMaybe area
-  Coords (ulr, ulc) = locToCoords ul
+  getTerrainIndex t =
+    M.findWithDefault 0 t $
+      terrainIndexByName $
+        tem ^. terrainMap
 
-  worldGrid :: [[(TerrainType, Erasable Entity)]]
-  worldGrid = (map . map) (cellTerrain &&& cellEntity) area
+  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
+
+  arrayMaxBound =
+    both (subtract 1)
+      . unCoords
+      . offsetCoordsByArea coords
+      $ getGridDimensions g
+
+  arrayBoundsTuple = (unCoords coords, arrayMaxBound)
 
   worldArray :: Array (Int32, Int32) (TerrainType, Erasable Entity)
-  worldArray = listArray ((ulr, ulc), (ulr + rs - 1, ulc + cs - 1)) (concat worldGrid)
+  worldArray = listArray arrayBoundsTuple $ concat $ unGrid worldGrid
 
   dslWF, arrayWF :: Seed -> WorldFun TerrainType Entity
   dslWF = maybe mempty ((applyWhen offsetOrigin findGoodOrigin .) . runWorld) worldProg
-  arrayWF = const (worldFunFromArray worldArray)
+  arrayWF = const $ worldFunFromArray worldArray
 
   wf = dslWF <> arrayWF
 
   -- Get all the robots described in cells and set their locations appropriately
   robots :: SubworldName -> [IndexedTRobot]
   robots swName =
-    area
+    unGrid g
       & traversed Control.Lens.<.> traversed %@~ (,) -- add (r,c) indices
       & concat
       & concatMap
-        ( \((fromIntegral -> r, fromIntegral -> c), Cell _ _ robotList) ->
-            let robotWithLoc = trobotLocation ?~ Cosmic swName (coordsToLoc (Coords (ulr + r, ulc + c)))
-             in map (fmap robotWithLoc) robotList
+        ( \((fromIntegral -> r, fromIntegral -> c), maybeCell) ->
+            let robotWithLoc = trobotLocation ?~ Cosmic swName (coordsToLoc (coords `addTuple` (r, c)))
+             in map (fmap robotWithLoc) (maybe [] cellRobots maybeCell)
         )
 
 -- |

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

@@ -8,6 +8,7 @@ module Swarm.Game.World.Coords (
   Coords (..),
   locToCoords,
   coordsToLoc,
+  addTuple,
   BoundsRectangle,
 )
 where
@@ -43,6 +44,9 @@ locToCoords (Location x y) = Coords (-y, x)
 coordsToLoc :: Coords -> Location
 coordsToLoc (Coords (r, c)) = Location c (-r)
 
+addTuple :: Coords -> (Int32, Int32) -> Coords
+addTuple (Coords (r, c)) (addR, addC) = Coords (r + addR, c + addC)
+
 -- | Represents the top-left and bottom-right coordinates
 -- of a bounding rectangle of cells in the world map
 type BoundsRectangle = (Coords, Coords)

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

@@ -27,6 +27,7 @@ import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.Center
 import Swarm.Game.Scenario.Topography.EntityFacade (EntityFacade (..), mkFacade)
+import Swarm.Game.Scenario.Topography.Structure.Overlay
 import Swarm.Game.State.Landscape
 import Swarm.Game.Universe
 import Swarm.Game.World qualified as W
@@ -111,11 +112,11 @@ getBoundingBox vc scenarioWorld maybeSize =
   mkBoundingBox areaDimens upperLeftLoc =
     both W.locToCoords locationBounds
    where
-    lowerRightLocation = upperLeftToBottomRight areaDimens upperLeftLoc
+    lowerRightLocation = computeBottomRightFromUpperLeft areaDimens upperLeftLoc
     locationBounds = (upperLeftLoc, lowerRightLocation)
 
-  worldArea = area scenarioWorld
-  mapAreaDims = getAreaDimensions worldArea
+  worldArea = gridContent $ area scenarioWorld
+  mapAreaDims = getGridDimensions worldArea
   areaDims@(AreaDimensions w h) =
     fromMaybe (AreaDimensions 20 10) $
       maybeSize <|> surfaceEmpty isEmpty mapAreaDims

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

@@ -17,6 +17,7 @@ import Data.Map qualified as M
 import Data.Yaml qualified as Y
 import Graphics.Vty qualified as V
 import Swarm.Game.Land
+import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.EntityFacade
 import Swarm.Game.State
 import Swarm.Game.State.Landscape
@@ -146,7 +147,9 @@ saveMapFile = do
   maybeBounds <- use $ uiState . uiGameplay . uiWorldEditor . editingBounds . boundsRect
   w <- use $ gameState . landscape . multiWorld
   tm <- use $ gameState . landscape . terrainAndEntities . terrainMap
-  let mapCellGrid = EU.getEditedMapRectangle tm (worldEditor ^. worldOverdraw) maybeBounds w
+  let mapCellGrid =
+        mapRows (map (map Just)) $
+          EU.getEditedMapRectangle tm (worldEditor ^. worldOverdraw) maybeBounds w
 
   let fp = worldEditor ^. outputFilePath
   maybeScenarioPair <- use $ uiState . uiGameplay . scenarioRef

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

@@ -12,7 +12,7 @@ import Data.List (sortOn)
 import Data.List.NonEmpty qualified as NE
 import Data.Map (Map)
 import Data.Map qualified as M
-import Data.Maybe (mapMaybe)
+import Data.Maybe (catMaybes, mapMaybe)
 import Data.Ord (Down (..))
 import Data.Set (Set)
 import Data.Set qualified as Set
@@ -27,6 +27,7 @@ import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.EntityFacade
 import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..))
+import Swarm.Game.Scenario.Topography.Structure.Overlay
 import Swarm.Game.Scenario.Topography.WorldPalette
 import Swarm.Game.Terrain (TerrainMap, TerrainType, getTerrainDefaultPaletteChar, terrainByName)
 import Swarm.Game.Universe
@@ -38,7 +39,7 @@ import Swarm.Util.Erasable
 makeSuggestedPalette ::
   TerrainMap ->
   KM.KeyMap (AugmentedCell Entity) ->
-  [[CellPaintDisplay]] ->
+  Grid (Maybe CellPaintDisplay) ->
   KM.KeyMap (AugmentedCell EntityFacade)
 makeSuggestedPalette tm originalScenarioPalette cellGrid =
   KM.fromMapText
@@ -48,6 +49,8 @@ makeSuggestedPalette tm originalScenarioPalette cellGrid =
     -- NOTE: the left-most maps take precedence!
     $ paletteCellsByKey <> pairsWithDisplays <> terrainOnlyPalette
  where
+  cellList = concatMap catMaybes $ unGrid cellGrid
+
   getMaybeEntityDisplay :: PCell EntityFacade -> Maybe (EntityName, Display)
   getMaybeEntityDisplay (Cell _terrain (erasableToMaybe -> maybeEntity) _) = do
     EntityFacade eName d <- maybeEntity
@@ -60,11 +63,11 @@ makeSuggestedPalette tm originalScenarioPalette cellGrid =
 
   getEntityTerrainMultiplicity :: Map EntityName (Map TerrainType Int)
   getEntityTerrainMultiplicity =
-    M.map histogram $ binTuples $ concatMap (mapMaybe getMaybeEntityNameTerrainPair) cellGrid
+    M.map histogram $ binTuples $ mapMaybe getMaybeEntityNameTerrainPair cellList
 
   usedEntityDisplays :: Map EntityName Display
   usedEntityDisplays =
-    M.fromList $ concatMap (mapMaybe getMaybeEntityDisplay) cellGrid
+    M.fromList $ mapMaybe getMaybeEntityDisplay cellList
 
   -- Finds the most-used terrain type (the "mode" in the statistical sense)
   -- paired with each entity
@@ -115,8 +118,8 @@ makeSuggestedPalette tm originalScenarioPalette cellGrid =
     f x = ((x, ENothing), (T.singleton $ getTerrainDefaultPaletteChar x, Cell x ENothing []))
 
 -- | Generate a \"skeleton\" scenario with placeholders for certain required fields
-constructScenario :: Maybe Scenario -> Grid CellPaintDisplay -> SkeletonScenario
-constructScenario maybeOriginalScenario (Grid cellGrid) =
+constructScenario :: Maybe Scenario -> Grid (Maybe CellPaintDisplay) -> SkeletonScenario
+constructScenario maybeOriginalScenario cellGrid =
   SkeletonScenario
     (maybe 1 (^. scenarioMetadata . scenarioVersion) maybeOriginalScenario)
     (maybe "My Scenario" (^. scenarioMetadata . scenarioName) maybeOriginalScenario)
@@ -135,7 +138,7 @@ constructScenario maybeOriginalScenario (Grid cellGrid) =
       , scrollable = True
       , palette = WorldPalette suggestedPalette
       , ul = upperLeftCoord
-      , area = cellGrid
+      , area = PositionedGrid upperLeftCoord cellGrid
       , navigation = Navigation mempty mempty
       , placedStructures = mempty
       , worldName = DefaultRootSubworld
@@ -151,4 +154,4 @@ constructScenario maybeOriginalScenario (Grid cellGrid) =
       (negate $ w `div` 2)
       (h `div` 2)
    where
-    AreaDimensions w h = getAreaDimensions cellGrid
+    AreaDimensions w h = getGridDimensions cellGrid

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

@@ -13,6 +13,7 @@ import Swarm.Game.Entity
 import Swarm.Game.Scenario.Topography.Area qualified as EA
 import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.EntityFacade
+import Swarm.Game.Scenario.Topography.Structure.Overlay
 import Swarm.Game.Scenario.Topography.WorldDescription
 import Swarm.Game.Terrain (TerrainMap, TerrainType)
 import Swarm.Game.Universe
@@ -33,8 +34,8 @@ getEditingBounds myWorld =
  where
   newBounds = Cosmic DefaultRootSubworld (W.locToCoords upperLeftLoc, W.locToCoords lowerRightLoc)
   upperLeftLoc = ul myWorld
-  a = EA.getAreaDimensions $ area myWorld
-  lowerRightLoc = EA.upperLeftToBottomRight a upperLeftLoc
+  a = EA.getGridDimensions $ gridContent $ area myWorld
+  lowerRightLoc = EA.computeBottomRightFromUpperLeft a upperLeftLoc
 
 getEditorContentAt ::
   TerrainMap ->

swarm.cabal

@@ -236,6 +236,7 @@ library swarm-scenario
     Swarm.Game.Scenario.Topography.Placement
     Swarm.Game.Scenario.Topography.Structure
     Swarm.Game.Scenario.Topography.Structure.Assembly
+    Swarm.Game.Scenario.Topography.Structure.Overlay
     Swarm.Game.Scenario.Topography.Structure.Recognition
     Swarm.Game.Scenario.Topography.Structure.Recognition.Log
     Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute
@@ -799,6 +800,7 @@ test-suite swarm-unit
     TestLanguagePipeline
     TestNotification
     TestOrdering
+    TestOverlay
     TestParse
     TestPedagogy
     TestPretty

test/unit/Main.hs

@@ -36,6 +36,7 @@ import TestLSP (testLSP)
 import TestLanguagePipeline (testLanguagePipeline)
 import TestNotification (testNotification)
 import TestOrdering (testOrdering)
+import TestOverlay (testOverlay)
 import TestParse (testParse)
 import TestPedagogy (testPedagogy)
 import TestPretty (testPrettyConst)
@@ -68,6 +69,7 @@ tests s =
     , testInventory
     , testNotification (s ^. gameState)
     , testOrdering
+    , testOverlay
     , testMisc
     , testLSP
     ]

test/unit/TestOverlay.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- Unit tests for generic grid overlay logic
+module TestOverlay where
+
+import Swarm.Game.Location
+import Swarm.Game.Scenario.Topography.Area
+import Swarm.Game.Scenario.Topography.Structure.Overlay
+import Test.Tasty
+import Test.Tasty.HUnit
+
+testOverlay :: TestTree
+testOverlay =
+  testGroup
+    "Overlay"
+    [ -- Overlay is to the east and north of the base.
+      -- Therefore, the origin of the combined grid must
+      -- be adjusted southward to match its original position
+      -- in the base layer.
+      mkOriginTestCase "Southward" (Location 3 2) (Location 0 (-2))
+    , -- Overlay is to the west and south of the base.
+      -- Therefore, the origin of the combined grid must
+      -- be adjusted eastward to match its original position
+      -- in the base layer.
+      mkOriginTestCase "Eastward" (Location (-7) (-1)) (Location 7 0)
+    ]
+
+mkOriginTestCase ::
+  String ->
+  Location ->
+  Location ->
+  TestTree
+mkOriginTestCase adjustmentDescription overlayLocation expectedBaseLoc =
+  testCase (unwords [adjustmentDescription, "origin adjustment"]) $ do
+    assertEqual "Base loc wrong" expectedBaseLoc actualBaseLoc
+ where
+  baseLayer = PositionedGrid (Location 0 0) $ Grid [[] :: [Maybe Int]]
+  overlayLayer = PositionedGrid overlayLocation $ Grid [[]]
+  PositionedGrid actualBaseLoc _ = baseLayer <> overlayLayer