Propagate origin displacements of child structures to parent (#2150)

Builds upon #2127 to fix the remaining issues with #1826.

If a structure incorporates sub-placements entailing northwesterly offsets, its "coordinate origin" will be shifted relative to the top-left cell in the grid.  This updated coordinate origin should be propagated to parent structures for use when placing it.  This includes placement of the main "area" onto the toplevel world map.  This is essential when composing a large scene that needs to line up with features generated by the DSL.

Another bug fixed in this PR involved incorrect "area" computation within sibling placements when both a "northward" and "westward" offset were used; existing tests only covered each of these directions separately.

## Changes in this PR

* Refactoring for readability
* Improved naming
    * Fixed typo `padSouthwest` -> `padNorthwest`
* Export some functions for unit tests
* Utilize propagated coordinate offset in `WorldDescription`

## Testing

### Unit tests

```
scripts/test/run-tests.sh swarm-unit --test-options '--pattern "Overlay"'
```

### Scenarios

```
scripts/play.sh -i data/scenarios/Testing/1780-structure-merge-expansion/coordinate-offset-propagation.yaml --hide-goal
```
| Before | After |
| --- | --- |
| ![Screenshot from 2024-09-22 19-54-13](https://github.com/user-attachments/assets/b7d79232-7435-4cdf-a586-4df4df5cd978) | ![Screenshot from 2024-09-22 19-50-10](https://github.com/user-attachments/assets/4c6a248c-153c-4461-9012-526f59d1ce35) |

```
scripts/play.sh -i data/scenarios/Testing/1780-structure-merge-expansion/simultaneous-north-and-west-offset.yaml --hide-goal
```


| Before | After |
| --- | --- |
| ![Screenshot from 2024-09-22 19-53-50](https://github.com/user-attachments/assets/2049c905-c283-4c43-adc2-f355ea055ada) | ![Screenshot from 2024-09-22 19-53-07](https://github.com/user-attachments/assets/d120d084-31c6-4a67-855d-e08043a93891) |

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

@@ -1,4 +1,6 @@
 nonoverlapping-structure-merge.yaml
 root-map-expansion.yaml
 structure-composition.yaml
-sequential-placement.yaml
+sequential-placement.yaml
+coordinate-offset-propagation.yaml
+simultaneous-north-and-west-offset.yaml

data/scenarios/Testing/1780-structure-merge-expansion/coordinate-offset-propagation.yaml

@@ -0,0 +1,77 @@
+version: 1
+name: Structure coordinate offset propagation
+author: Karl Ostmo
+description: |
+  If a structure incorporates subplacements
+  entailing negative offsets, its coordinate origin must be shifted.
+
+  The updated coordinate origin should be propagated to parent structures
+  and utilized to offset placement.
+robots:
+  - name: base
+    dir: north
+    loc: [0, 3]
+objectives:
+  - goal:
+      - Enjoy the view.
+    condition: |
+      return true
+solution: |
+  noop
+known: [boulder, log, pixel (R), pixel (G), pixel (B), gold]
+world:
+  structures:
+    - name: micro
+      structure:
+        mask: '.'
+        palette:
+          'x': [stone, gold]
+        map: |
+          xx
+    - name: block
+      structure:
+        mask: '.'
+        palette:
+          'x': [stone, pixel (R)]
+        map: |
+          xx
+          xx
+    - name: master
+      structure:
+        mask: '.'
+        palette:
+          'x': [stone, pixel (B)]
+        placements:
+          - src: block
+            offset: [0, 1]
+          - src: micro
+            offset: [-2, 0]
+        map: |
+          ..x
+          ..x
+          ..x
+    - name: final
+      structure:
+        mask: '.'
+        palette:
+          'x': [stone, pixel (G)]
+        placements:
+          - src: master
+        map: |
+          x
+          x
+          x
+          x
+  dsl: |
+    overlay
+    [ {grass}
+    , mask (y > -4 && y < 4 || x > -4 && x < 4) {stone}
+    , mask (y > -2 && y < 2 || x > -2 && x < 2) {ice}
+    , mask (y > -1 && y < 1 || x > -1 && x < 1) {dirt}
+    ]
+  mask: '.'
+  placements:
+    - src: final
+      offset: [0, 0]
+  upperleft: [0, 0]
+  map: ""

data/scenarios/Testing/1780-structure-merge-expansion/sequential-placement.yaml

@@ -13,7 +13,7 @@ objectives:
       - Must have 3 of each color visible
     condition: |
       def countColor = \e.
-        resonate e ((0, 0), (10, -5));
+        resonate e ((-6, 0), (4, -4));
         end;
 
       as base {
@@ -87,7 +87,7 @@ world:
   mask: '.'
   placements:
     - src: block
-      offset: [0, -1]
+      offset: [0, -2]
   upperleft: [0, 0]
   dsl: |
     {grass}

data/scenarios/Testing/1780-structure-merge-expansion/simultaneous-north-and-west-offset.yaml

@@ -0,0 +1,56 @@
+version: 1
+name: Northwest sibling structure coordinate offsets
+author: Karl Ostmo
+description: |
+  Make sure that the second sibling is displayed correctly when there
+  is a simultaneous negative-x and positive-y offset on the first sibling.
+robots:
+  - name: base
+    dir: north
+    loc: [0, 2]
+objectives:
+  - goal:
+      - Enjoy the view.
+    condition: |
+      return true
+solution: |
+  noop
+known: [pixel (R), gold]
+world:
+  structures:
+    - name: micro
+      structure:
+        mask: '.'
+        palette:
+          'x': [stone, gold]
+        map: |
+          x
+    - name: block
+      structure:
+        mask: '.'
+        palette:
+          'x': [stone, pixel (R)]
+        map: |
+          xx
+          xx
+    - name: master
+      structure:
+        mask: '.'
+        placements:
+          - src: micro
+            offset: [-1, 1]
+          - src: block
+        map: ""
+  dsl: |
+    overlay
+    [ {grass}
+    , mask (y > -4 && y < 4 || x > -4 && x < 4) {stone}
+    , mask (y > -2 && y < 2 || x > -2 && x < 2) {ice}
+    , mask (y > -1 && y < 1 || x > -1 && x < 1) {dirt}
+    ]
+  mask: '.'
+  placements:
+    - src: master
+      offset: [0, 0]
+  upperleft: [0, 0]
+  map: ""

data/test/standalone-topography/circle-and-crosses.yaml

@@ -55,5 +55,5 @@ placements:
     orient:
       up: west
   - src: disc
-    offset: [8, -8]
+    offset: [5, -8]
 map: ""

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

@@ -122,9 +122,7 @@ instance FromJSONE WorldParseDependencies WorldDescription where
       let placedStructures =
             map (offsetLoc $ coerce ul) staticStructurePlacements
 
-      -- Override upper-left corner with explicit location
+      let area = modifyLoc ((ul .+^) . asVector) mergedGrid
-      let area = mergedGrid {gridPosition = ul}
-
       return $ WorldDescription {..}
 
 ------------------------------------------------------------

src/swarm-topography/Swarm/Game/Location.hs

@@ -202,7 +202,7 @@ euclidean p1 p2 = norm (fromIntegral <$> (p2 .-. p1))
 
 -- | Converts a 'Point' to a vector offset from the 'origin'.
 asVector :: Location -> V2 Int32
-asVector loc = loc .-. origin
+asVector (P vec) = vec
 
 -- | Get all the locations that are within a certain manhattan
 --   distance from a given location.

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

@@ -18,6 +18,7 @@ data AreaDimensions = AreaDimensions
   { rectWidth :: Int32
   , rectHeight :: Int32
   }
+  deriving (Show, Eq)
 
 getGridDimensions :: Grid a -> AreaDimensions
 getGridDimensions g = getAreaDimensions $ getRows g

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

@@ -7,6 +7,9 @@
 -- as well as logic for combining them.
 module Swarm.Game.Scenario.Topography.Structure.Assembly (
   mergeStructures,
+
+  -- * Exposed for unit tests:
+  foldLayer,
 )
 where
 
@@ -63,30 +66,15 @@ mergeStructures ::
   Parentage Placement ->
   PStructure (Maybe a) ->
   Either Text (MergedStructure (Maybe a))
-mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStructures subPlacements subWaypoints) = do
+mergeStructures inheritedStrucDefs parentPlacement baseStructure = do
   overlays <-
     left (elaboratePlacement parentPlacement <>) $
       mapM (validatePlacement structureMap) subPlacements
 
-  let wrapPlacement (Placed z ns) =
+  foldLayer structureMap origArea overlays originatedWaypoints
-        LocatedStructure
-          (name ns)
-          (up $ orient structPose)
-          (offset structPose)
-       where
-        structPose = structurePose z
-
-      wrappedOverlays =
-        map wrapPlacement $
-          filter (\(Placed _ ns) -> isRecognizable ns) overlays
-
-  -- NOTE: Each successive overlay may alter the coordinate origin.
-  -- We make sure this new origin is propagated to subsequent sibling placements.
-  foldlM
-    (flip $ overlaySingleStructure structureMap)
-    (MergedStructure origArea wrappedOverlays originatedWaypoints)
-    overlays
  where
+  Structure origArea subStructures subPlacements subWaypoints = baseStructure
+
   originatedWaypoints = map (Originated parentPlacement) subWaypoints
 
   -- deeper definitions override the outer (toplevel) ones
@@ -95,6 +83,32 @@ mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStruct
       (M.fromList $ map (name &&& id) subStructures)
       inheritedStrucDefs
 
+-- | NOTE: Each successive overlay may alter the coordinate origin.
+-- We make sure this new origin is propagated to subsequent sibling placements.
+foldLayer ::
+  M.Map StructureName (NamedStructure (Maybe a)) ->
+  PositionedGrid (Maybe a) ->
+  [Placed (Maybe a)] ->
+  [Originated Waypoint] ->
+  Either Text (MergedStructure (Maybe a))
+foldLayer structureMap origArea overlays originatedWaypoints =
+  foldlM
+    (flip $ overlaySingleStructure structureMap)
+    (MergedStructure origArea wrappedOverlays originatedWaypoints)
+    overlays
+ where
+  wrappedOverlays =
+    map wrapPlacement $
+      filter (\(Placed _ ns) -> isRecognizable ns) overlays
+
+  wrapPlacement (Placed z ns) =
+    LocatedStructure
+      (name ns)
+      (up $ orient structPose)
+      (offset structPose)
+   where
+    structPose = structurePose z
+
 -- * Grid manipulation
 
 overlayGridExpanded ::
@@ -105,14 +119,13 @@ overlayGridExpanded ::
 overlayGridExpanded
   baseGrid
   (Pose yamlPlacementOffset orientation)
-  -- NOTE: The '_childAdjustedOrigin' is the sum of origin adjustments
+  -- The 'childAdjustedOrigin' is the sum of origin adjustments
-  -- to completely assemble some substructure. However, we discard
+  -- to completely assemble some substructure.
-  -- this when we place a substructure into a new base grid.
+  (PositionedGrid childAdjustedOrigin overlayArea) =
-  (PositionedGrid _childAdjustedOrigin overlayArea) =
     baseGrid <> positionedOverlay
    where
     reorientedOverlayCells = applyOrientationTransform orientation overlayArea
-    placementAdjustedByOrigin = gridPosition baseGrid .+^ asVector yamlPlacementOffset
+    placementAdjustedByOrigin = childAdjustedOrigin .+^ asVector yamlPlacementOffset
     positionedOverlay = PositionedGrid placementAdjustedByOrigin reorientedOverlayCells
 
 -- * Validation

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

@@ -6,13 +6,18 @@
 -- Generic overlay operations on grids
 module Swarm.Game.Scenario.Topography.Structure.Overlay (
   PositionedGrid (..),
+
+  -- * Exported for unit tests
+  computeMergedArea,
+  OverlayPair (..),
 ) where
 
 import Control.Applicative
+import Control.Lens (view)
 import Data.Function (on)
 import Data.Int (Int32)
 import Data.Tuple (swap)
-import Linear
+import Linear.V2 (R1 (_x), R2 (_y), V2 (..))
 import Swarm.Game.Location
 import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Grid
@@ -25,6 +30,10 @@ data PositionedGrid a = PositionedGrid
   }
   deriving (Eq)
 
+instance HasLocation (PositionedGrid a) where
+  modifyLoc f (PositionedGrid originalLoc g) =
+    PositionedGrid (f originalLoc) g
+
 instance Show (PositionedGrid a) where
   show (PositionedGrid p g) =
     unwords
@@ -46,16 +55,27 @@ data SubsumingRect = SubsumingRect
   , _southeastCorner :: Location
   }
 
+getNorthwesternExtent :: Location -> Location -> Location
+getNorthwesternExtent ul1 ul2 =
+  Location westernMostX northernMostY
+ where
+  westernMostX = (min `on` view _x) ul1 ul2
+  northernMostY = (max `on` view _y) ul1 ul2
+
+getSoutheasternExtent :: Location -> Location -> Location
+getSoutheasternExtent br1 br2 =
+  Location easternMostX southernMostY
+ where
+  easternMostX = (max `on` view _x) br1 br2
+  southernMostY = (min `on` view _y) br1 br2
+
 -- | @r1 <> r2@ is the smallest rectangle that contains both @r1@ and @r2@.
 instance Semigroup SubsumingRect where
-  SubsumingRect (Location ulx1 uly1) (Location brx1 bry1)
+  SubsumingRect ul1 br1 <> SubsumingRect ul2 br2 =
-    <> SubsumingRect (Location ulx2 uly2) (Location brx2 bry2) =
+    SubsumingRect northwesternExtent southeasternExtent
-      SubsumingRect (Location westernMostX northernMostY) (Location easternMostX southernMostY)
+   where
-     where
+    northwesternExtent = getNorthwesternExtent ul1 ul2
-      westernMostX = min ulx1 ulx2
+    southeasternExtent = getSoutheasternExtent br1 br2
-      northernMostY = max uly1 uly2
-      easternMostX = max brx1 brx2
-      southernMostY = min bry1 bry2
 
 getSubsumingRect :: PositionedGrid a -> SubsumingRect
 getSubsumingRect (PositionedGrid loc g) =
@@ -75,7 +95,7 @@ zipGridRows ::
 zipGridRows dims (OverlayPair paddedBaseRows paddedOverlayRows) =
   mkGrid $ (pad2D paddedBaseRows . pad2D paddedOverlayRows) blankGrid
  where
-  -- Right-bias; that is, take the last non-empty value
+  -- Right-biased; that is, takes the last non-empty value
   pad2D = zipPadded $ zipPadded $ flip (<|>)
   blankGrid = getRows $ fillGrid dims empty
 
@@ -96,7 +116,7 @@ zipGridRows dims (OverlayPair paddedBaseRows paddedOverlayRows) =
 -- of the base layer.
 instance (Alternative f) => Semigroup (PositionedGrid (f a)) where
   a1@(PositionedGrid baseLoc baseGrid) <> a2@(PositionedGrid overlayLoc overlayGrid) =
-    PositionedGrid newOrigin combinedGrid
+    PositionedGrid newUpperLeftCornerPosition combinedGrid
    where
     mergedSize = computeMergedArea $ OverlayPair a1 a2
     combinedGrid = zipGridRows mergedSize paddedOverlayPair
@@ -105,30 +125,36 @@ instance (Alternative f) => Semigroup (PositionedGrid (f a)) where
     -- 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) = asVector overlayLoc
+    upperLeftCornersDelta = 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
+    newUpperLeftCornerPosition = getNorthwesternExtent baseLoc overlayLoc
-    -- 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 $
+      padNorthwest upperLeftCornersDelta $
         OverlayPair baseGrid overlayGrid
 
--- | NOTE: We only make explicit grid adjustments for
+-- |
+-- 'deltaX' and 'deltaY' refer to the positioning of the *overlay grid*
+-- relative to the *base grid*.
+-- A negative 'deltaY' means that the top edge of the overlay
+-- lies to the south of the top edge of the base grid.
+-- A positive 'deltaX' means that the left edge of the overlay
+-- lies to the east of the left edge of base grid.
+--
+-- We add padding to either the overlay grid or the base grid
+-- so as to align their upper-left corners.
+--
+-- 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.
 --
 -- TODO(#2004): The return type should be 'Grid'.
-padSouthwest ::
+padNorthwest ::
   Alternative f =>
   V2 Int32 ->
   OverlayPair (Grid (f a)) ->
   OverlayPair [[f a]]
-padSouthwest (V2 deltaX deltaY) (OverlayPair baseGrid overlayGrid) =
+padNorthwest (V2 deltaX deltaY) (OverlayPair baseGrid overlayGrid) =
   OverlayPair paddedBaseGrid paddedOverlayGrid
  where
   prefixPadDimension delta f = f (padding <>)

test/integration/Main.hs

@@ -444,6 +444,8 @@ testScenarioSolutions rs ui key =
         , testGroup
             "Structure placement (#1780)"
             [ testSolution Default "Testing/1780-structure-merge-expansion/sequential-placement"
+            , testSolution Default "Testing/1780-structure-merge-expansion/coordinate-offset-propagation"
+            , testSolution Default "Testing/1780-structure-merge-expansion/simultaneous-north-and-west-offset"
             -- TODO(#2148) define goal conditions or convert to image fixtures
             -- , testSolution Default "Testing/1780-structure-merge-expansion/nonoverlapping-structure-merge"
             -- , testSolution Default "Testing/1780-structure-merge-expansion/root-map-expansion"

test/unit/Main.hs

@@ -54,18 +54,38 @@ tests :: AppState -> TestTree
 tests s =
   testGroup
     "Tests"
+    [ statelessTests
+    , stateDependentTests s
+    ]
+
+-- | Initializing an 'AppState' entails loading challenge scenarios, etc. from
+-- disk.  We might not want to do this, in case we inject a 'trace' somewhere
+-- in the scenario loading code and want to minimize the noise.
+--
+-- So we keep this list separate from the stateless tests so we can easily
+-- comment it out.
+stateDependentTests :: AppState -> TestTree
+stateDependentTests s =
+  testGroup
+    "Stateful tests"
+    [ testEval (s ^. gameState)
+    , testPedagogy (s ^. runtimeState)
+    , testNotification (s ^. gameState)
+    ]
+
+statelessTests :: TestTree
+statelessTests =
+  testGroup
+    "Stateless tests"
     [ testLanguagePipeline
     , testParse
     , testPrettyConst
     , testBoolExpr
     , testCommands
     , testHighScores
-    , testEval (s ^. gameState)
     , testRepl
     , testRequirements
-    , testPedagogy (s ^. runtimeState)
     , testInventory
-    , testNotification (s ^. gameState)
     , testOrdering
     , testOverlay
     , testMisc

test/unit/TestOverlay.hs

@@ -4,30 +4,128 @@
 -- SPDX-License-Identifier: BSD-3-Clause
 --
 -- Unit tests for generic grid overlay logic
-module TestOverlay where
+module TestOverlay (testOverlay) where
 
+import Control.Monad (when)
+import Data.Function (on)
+import Data.Text (Text)
 import Swarm.Game.Location
+import Swarm.Game.Scenario.Topography.Area (
+  AreaDimensions (AreaDimensions),
+ )
 import Swarm.Game.Scenario.Topography.Grid
+import Swarm.Game.Scenario.Topography.Placement
+import Swarm.Game.Scenario.Topography.Structure
+import Swarm.Game.Scenario.Topography.Structure.Assembly (
+  foldLayer,
+ )
+import Swarm.Game.Scenario.Topography.Structure.Named
 import Swarm.Game.Scenario.Topography.Structure.Overlay
 import Test.Tasty
 import Test.Tasty.HUnit
 
+debugRenderGrid :: Bool
+debugRenderGrid = False
+
+-- * Example grids
+
+-- | Single cell
+oneByOneGrid :: [[Int]]
+oneByOneGrid = [[0]]
+
+-- | Single row with two columns
+oneByTwoGrid :: [[Int]]
+oneByTwoGrid = [[5, 6]]
+
+-- | Two rows with two columns
+twoByTwoGrid :: [[Int]]
+twoByTwoGrid =
+  [ [1, 2]
+  , [3, 4]
+  ]
+
 testOverlay :: TestTree
 testOverlay =
   testGroup
     "Overlay"
-    [ -- Overlay is to the east and north of the base.
+    [ testGroup
-      -- Therefore, the origin of the combined grid must
+        "Empty grids, base grid at origin"
-      -- be adjusted southward to match its original position
+        [ mkOriginTestCase "Northward" (Location 3 2) (Location 0 2)
-      -- in the base layer.
+        , mkOriginTestCase "Westward" (Location (-7) (-1)) (Location (-7) 0)
-      mkOriginTestCase "Southward" (Location 3 2) (Location 0 (-2))
+        ]
-    , -- Overlay is to the west and south of the base.
+    , testGroup
-      -- Therefore, the origin of the combined grid must
+        "Overlay sequences"
-      -- be adjusted eastward to match its original position
+        [ testGroup
-      -- in the base layer.
+            "Horizontal siblings"
-      mkOriginTestCase "Eastward" (Location (-7) (-1)) (Location 7 0)
+            [ mkOverlaySequenceOriginTest
+                "negative first west of second"
+                [ placeUnshifted "sibling1" (Location (-2) 0) twoByTwoGrid
+                , placeUnshifted "sibling2" (Location 0 0) oneByTwoGrid
+                ]
+                (Location (-2) 0)
+            , mkOverlaySequenceOriginTest
+                "first east of negative second"
+                [ placeUnshifted "sibling1" (Location 0 0) twoByTwoGrid
+                , placeUnshifted "sibling2" (Location (-2) 0) oneByTwoGrid
+                ]
+                (Location (-2) 0)
+            ]
+        , testGroup
+            "Vertical siblings"
+            [ mkOverlaySequenceOriginTest
+                "positive first south of second"
+                [ placeUnshifted "sibling1" (Location 0 2) twoByTwoGrid
+                , placeUnshifted "sibling2" (Location 0 0) oneByTwoGrid
+                ]
+                (Location 0 2)
+            , mkOverlaySequenceOriginTest
+                "first north of positive second"
+                [ placeUnshifted "sibling1" (Location 0 0) twoByTwoGrid
+                , placeUnshifted "sibling2" (Location 0 2) oneByTwoGrid
+                ]
+                (Location 0 2)
+            ]
+        , testGroup
+            "Merge sizes"
+            [ testMergedSize
+                "merge an offset 1x1 atop a 0x0 base"
+                (mkNamedStructure "baseLayer" (Location 0 0) [[]])
+                (mkNamedStructure "sibling1" (Location (-1) 1) oneByOneGrid)
+                (AreaDimensions 1 1)
+            , testMergedSize
+                "merge a 2x2 atop a 1x1 with an offset"
+                (mkNamedStructure "sibling1" (Location (-1) 1) oneByOneGrid)
+                (mkNamedStructure "sibling2" (Location 0 0) twoByTwoGrid)
+                (AreaDimensions 3 3)
+            ]
+        , testGroup
+            "Northwesterly offset of first sibling"
+            [ mkOverlaySequenceOriginTest
+                "positive first south of second"
+                [ placeUnshifted "sibling1" (Location (-1) 1) oneByOneGrid
+                , placeUnshifted "sibling2" (Location 0 0) twoByTwoGrid
+                ]
+                (Location (-1) 1)
+            ]
+        ]
     ]
 
+-- * Test construction
+testMergedSize ::
+  String ->
+  NamedStructure (Maybe Int) ->
+  NamedStructure (Maybe Int) ->
+  AreaDimensions ->
+  TestTree
+testMergedSize testLabel ns1 ns2 expectedArea =
+  testCase testLabel $ do
+    assertEqual "Merged area is wrong" expectedArea mergedSize
+ where
+  mergedSize =
+    computeMergedArea $
+      (OverlayPair `on` (area . structure)) ns1 ns2
+
+-- | Base layer is at the origin (0, 0).
 mkOriginTestCase ::
   String ->
   Location ->
@@ -40,3 +138,84 @@ mkOriginTestCase adjustmentDescription overlayLocation expectedBaseLoc =
   baseLayer = PositionedGrid (Location 0 0) (EmptyGrid :: Grid (Maybe ()))
   overlayLayer = PositionedGrid overlayLocation EmptyGrid
   PositionedGrid actualBaseLoc _ = baseLayer <> overlayLayer
+
+mkOverlaySequenceOriginTest ::
+  String ->
+  [Placed (Maybe Int)] ->
+  Location ->
+  TestTree
+mkOverlaySequenceOriginTest = mkOverlaySequenceTest gridPosition
+
+mkOverlaySequenceTest ::
+  (Show a, Eq a) =>
+  (PositionedGrid (Maybe Int) -> a) ->
+  String ->
+  [Placed (Maybe Int)] ->
+  a ->
+  TestTree
+mkOverlaySequenceTest f testLabel overlays expectedBaseLoc =
+  testCase testLabel $ do
+    when debugRenderGrid $
+      renderGridResult eitherResultGrid
+
+    assertEqual "Base loc wrong" (Right expectedBaseLoc) $
+      f <$> eitherResultGrid
+ where
+  baseArea = PositionedGrid (Location 0 0) (EmptyGrid :: Grid (Maybe Int))
+
+  eitherResultGrid = getGridFromMergedStructure <$> eitherResult
+  eitherResult =
+    foldLayer
+      mempty
+      baseArea
+      overlays
+      []
+
+getGridFromMergedStructure :: MergedStructure c -> PositionedGrid c
+getGridFromMergedStructure (MergedStructure g _ _) = g
+
+-- | Place an structure at an offset.
+-- The structure's local origin is (0, 0).
+placeUnshifted ::
+  Text ->
+  Location ->
+  [[a]] ->
+  Placed (Maybe a)
+placeUnshifted = place (Location 0 0)
+
+-- | Place a structure at an offset.
+-- That structure's local origin might not be (0, 0).
+place ::
+  Location ->
+  Text ->
+  Location ->
+  [[a]] ->
+  Placed (Maybe a)
+place localOrigin theName placementOffset g =
+  Placed (Placement sName (Pose placementOffset defaultOrientation)) $
+    mkNamedStructure theName localOrigin g
+ where
+  sName = StructureName theName
+
+mkNamedStructure ::
+  Text ->
+  Location ->
+  [[a]] ->
+  NamedArea (PStructure (Maybe a))
+mkNamedStructure theName pos g =
+  NamedArea sName mempty mempty s
+ where
+  sName = StructureName theName
+  s =
+    Structure
+      (PositionedGrid pos $ Just <$> mkGrid g)
+      mempty
+      mempty
+      mempty
+
+renderGridResult :: Either a (PositionedGrid (Maybe Int)) -> IO ()
+renderGridResult eitherResult = case eitherResult of
+  Right pg -> do
+    print pg
+    print $ getRows $ gridContent pg
+  Left _ -> return ()