fix placement offsets

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

@@ -27,27 +27,41 @@ world:
         palette:
           'x': [stone, gold]
         map: |
-          xxx
-          x.x
-          xxx
+          xx
     - name: block
       structure:
         mask: '.'
         palette:
           'x': [stone, pixel (R)]
         map: |
-          xxxx
-          x..x
-          x..x
-          xxxx
+          xx
+          xx
     - name: master
       structure:
         mask: '.'
+        palette:
+          'x': [stone, pixel (B)]
         placements:
           - src: block
+            offset: [0, 1]
           - src: micro
-            offset: [-3, 1]
-        map: ""
+            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}
@@ -59,7 +73,7 @@ world:
     'Ω': [grass, erase, base]
   mask: '.'
   placements:
-    - src: master
+    - src: final
       offset: [0, 0]
   upperleft: [0, 0]
   map: |

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

@@ -122,8 +122,7 @@ instance FromJSONE WorldParseDependencies WorldDescription where
       let placedStructures =
             map (offsetLoc $ coerce ul) staticStructurePlacements
 
-      -- Override upper-left corner with explicit location
-      let area = mergedGrid {gridPosition = ul}
+      let area = modifyLoc ((ul .-^) . asVector) mergedGrid
 
       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/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) =
-        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
+  foldLayer structureMap origArea overlays originatedWaypoints
  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
-  -- to completely assemble some substructure. However, we discard
-  -- this when we place a substructure into a new base grid.
-  (PositionedGrid _childAdjustedOrigin overlayArea) =
+  -- The 'childAdjustedOrigin' is the sum of origin adjustments
+  -- to completely assemble some substructure.
+  (PositionedGrid childAdjustedOrigin overlayArea) =
     baseGrid <> positionedOverlay
    where
     reorientedOverlayCells = applyOrientationTransform orientation overlayArea
-    placementAdjustedByOrigin = gridPosition baseGrid .+^ asVector yamlPlacementOffset
+    placementAdjustedByOrigin = (gridPosition baseGrid .+^ asVector yamlPlacementOffset) .-^ asVector childAdjustedOrigin
     positionedOverlay = PositionedGrid placementAdjustedByOrigin reorientedOverlayCells
 
 -- * Validation

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

@@ -25,6 +25,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

test/unit/TestOverlay.hs

@@ -6,28 +6,93 @@
 -- Unit tests for generic grid overlay logic
 module TestOverlay where
 
+import Data.Text (Text)
 import Swarm.Game.Location
 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
+import Swarm.Game.Scenario.Topography.Structure.Named
 import Swarm.Game.Scenario.Topography.Structure.Overlay
 import Test.Tasty
 import Test.Tasty.HUnit
 
+-- * Example grids
+
+-- | 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.
-      -- 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)
+    [ testGroup
+        "Empty grids, base grid at origin"
+        [ -- 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)
+        ]
+    , testGroup
+        "Overlay sequences"
+        [ testGroup
+            "Horizontal siblings"
+            [ 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
+            "Nonzero local origin"
+            [ mkOverlaySequenceOriginTest
+                "positive first south of second"
+                [ place (Location 2 0) "sibling1" (Location 0 0) twoByTwoGrid
+                ]
+                (Location 2 0)
+            ]
+        ]
     ]
 
+-- * Test construction
+
+-- | Base layer is at the origin (0, 0).
 mkOriginTestCase ::
   String ->
   Location ->
@@ -40,3 +105,63 @@ 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
+    assertEqual "Base loc wrong" (Right expectedBaseLoc) $
+      f . getGridFromMergedStructure <$> eitherResult
+ where
+  baseArea = PositionedGrid (Location 0 0) (EmptyGrid :: Grid (Maybe Int))
+
+  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)) $
+    NamedArea sName mempty mempty s
+ where
+  sName = StructureName theName
+  s =
+    Structure
+      (PositionedGrid localOrigin $ Just <$> mkGrid g)
+      mempty
+      mempty
+      mempty