Fix growable structure grids for multiple children with negative coordinates

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

@@ -1,3 +1,4 @@
 nonoverlapping-structure-merge.yaml
 root-map-expansion.yaml
-structure-composition.yaml
+structure-composition.yaml
+sequential-placement.yaml

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

@@ -0,0 +1,95 @@
+version: 1
+name: Flipped structure placement
+author: Karl Ostmo
+description: |
+  Sequentially place structures that are larger than the map
+  with flipped orientation.
+robots:
+  - name: base
+    dir: north
+creative: true
+objectives:
+  - goal:
+      - Must have 3 of each color visible
+    condition: |
+      def countColor = \e.
+        resonate e ((0, 0), (10, -5));
+        end;
+
+      as base {
+        r <- countColor "pixel (R)";
+        g <- countColor "pixel (G)";
+        b <- countColor "pixel (B)";
+        y <- countColor "gold";
+        return $ r == 3 && g == 3 && b == 3 && y == 3;
+      }
+solution: |
+  noop
+known: [boulder, log, pixel (R), pixel (G), pixel (B), gold]
+world:
+  structures:
+    - name: reddish
+      structure:
+        mask: '.'
+        palette:
+          'x': [stone, pixel (R)]
+        map: |
+          xx
+          x.
+    - name: greenish
+      structure:
+        mask: '.'
+        palette:
+          'x': [stone, pixel (G)]
+        map: |
+          xx
+          x.
+    - name: bluish
+      structure:
+        mask: '.'
+        palette:
+          'x': [stone, pixel (B)]
+        map: |
+          xx
+          x.
+    - name: goldish
+      structure:
+        mask: '.'
+        palette:
+          'x': [stone, gold]
+        map: |
+          xx
+          x.
+    - name: block
+      structure:
+        mask: '.'
+        palette:
+          'x': [ice, log]
+        placements:
+          - src: greenish
+            orient:
+              flip: true
+            offset: [-3, 2]
+          - src: reddish
+            offset: [-6, 0]
+          - src: goldish
+            orient:
+              flip: true
+            offset: [3, -1]
+          - src: bluish
+            offset: [0, 1]
+        map: |
+          xxx
+          xx.
+          x..
+  palette:
+    'Ω': [grass, erase, base]
+  mask: '.'
+  placements:
+    - src: block
+      offset: [0, -1]
+  upperleft: [0, 0]
+  dsl: |
+    {grass}
+  map: |
+    Ω

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

@@ -19,7 +19,7 @@ structures:
               fff
       placements:
         - src: beam
-          offset: [0, 3]
+          offset: [0, 0]
         - src: beam
           offset: [-3, -3]
           orient:

src/swarm-scenario/Swarm/Game/Scenario/Topography/Navigation/Portal.hs

@@ -179,7 +179,7 @@ validatePartialNavigation currentSubworldName upperLeft unmergedWaypoints portal
   correctedWaypoints =
     binTuples $
       map
-        (\x -> (wpName $ wpConfig $ value x, fmap (offsetLoc $ upperLeft .-. origin) x))
+        (\x -> (wpName $ wpConfig $ value x, fmap (offsetLoc $ asVector upperLeft) x))
         unmergedWaypoints
   bareWaypoints = M.map (NE.map extractLoc) correctedWaypoints
   waypointsWithUniqueFlag = M.filter (any $ wpUnique . wpConfig . value) correctedWaypoints

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

@@ -29,6 +29,7 @@ module Swarm.Game.Location (
   -- ** Utility functions
   manhattan,
   euclidean,
+  asVector,
   getLocsInArea,
   getElemsInArea,
 
@@ -199,6 +200,10 @@ manhattan (Location x1 y1) (Location x2 y2) = abs (x1 - x2) + abs (y1 - y2)
 euclidean :: Location -> Location -> Double
 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
+
 -- | 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

@@ -22,7 +22,6 @@ import Data.Text qualified as T
 import Linear.Affine
 import Swarm.Game.Location
 import Swarm.Game.Scenario.Topography.Area
-import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint
 import Swarm.Game.Scenario.Topography.Placement
 import Swarm.Game.Scenario.Topography.Structure
@@ -42,14 +41,14 @@ overlaySingleStructure ::
   Either Text (MergedStructure (Maybe a))
 overlaySingleStructure
   inheritedStrucDefs
-  (Placed p@(Placement _ pose@(Pose loc orientation)) ns)
+  (Placed p@(Placement _sName 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 = overlayGridExpanded (gridContent inputArea) pose overlayArea
+        mergedArea = overlayGridExpanded inputArea pose overlayArea
 
     return $ MergedStructure mergedArea mergedPlacements mergedWaypoints
    where
@@ -81,6 +80,8 @@ mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStruct
         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)
@@ -97,18 +98,22 @@ mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStruct
 -- * Grid manipulation
 
 overlayGridExpanded ::
-  Grid (Maybe a) ->
+  PositionedGrid (Maybe a) ->
   Pose ->
   PositionedGrid (Maybe a) ->
   PositionedGrid (Maybe a)
 overlayGridExpanded
-  inputGrid
-  (Pose loc orientation)
-  (PositionedGrid _ overlayArea) =
-    PositionedGrid origin inputGrid <> positionedOverlay
+  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) =
+    baseGrid <> positionedOverlay
    where
     reorientedOverlayCells = applyOrientationTransform orientation overlayArea
-    positionedOverlay = PositionedGrid loc reorientedOverlayCells
+    placementAdjustedByOrigin = gridPosition baseGrid .+^ asVector yamlPlacementOffset
+    positionedOverlay = PositionedGrid placementAdjustedByOrigin reorientedOverlayCells
 
 -- * Validation
 

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

@@ -101,12 +101,11 @@ instance (Alternative f) => Semigroup (PositionedGrid (f a)) 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:
+    -- We create a vector 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
+    originDelta@(V2 deltaX deltaY) = asVector overlayLoc
     -- 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).

test/integration/Main.hs

@@ -440,6 +440,13 @@ testScenarioSolutions rs ui key =
             [ testSolution Default "Testing/1535-ping/1535-in-range"
             , testSolution Default "Testing/1535-ping/1535-out-of-range"
             ]
+        , testGroup
+            "Structure placement (#1780)"
+            [ testSolution Default "Testing/1780-structure-merge-expansion/sequential-placement"
+            -- , testSolution Default "Testing/1780-structure-merge-expansion/nonoverlapping-structure-merge"
+            -- , testSolution Default "Testing/1780-structure-merge-expansion/root-map-expansion"
+            -- , testSolution Default "Testing/1780-structure-merge-expansion/structure-composition"
+            ]
         , testGroup
             "Structure recognition (#1575)"
             [ testSolution Default "Testing/1575-structure-recognizer/1575-browse-structures"

test/standalone-topography/src/Lib.hs

@@ -32,8 +32,12 @@ parseStructures dataDir baseFilename = do
       dataDir </> "test/standalone-topography" </> baseFilename
   return $ forceEither $ left prettyPrintParseException eitherResult
 
-compareToReferenceImage :: FilePath -> Assertion
-compareToReferenceImage fileStem = do
+compareToReferenceImage ::
+  -- | set this to update the golden tests
+  Bool ->
+  FilePath ->
+  Assertion
+compareToReferenceImage refreshReferenceImage fileStem = do
   dataDir <- getDataDir
   parentStruct <- parseStructures dataDir $ fileStem <.> "yaml"
   let MergedStructure overlayArea _ _ = forceEither $ mergeStructures mempty Root parentStruct
@@ -44,6 +48,3 @@ compareToReferenceImage fileStem = do
     else do
       decodedImg <- LBS.readFile referenceFilepath
       assertEqual "Generated image must equal reference image!" decodedImg encodedImgBytestring
- where
-  -- Manually toggle this to update the golden tests
-  refreshReferenceImage = False

test/standalone-topography/src/Main.hs

@@ -4,33 +4,46 @@
 -- SPDX-License-Identifier: BSD-3-Clause
 module Main where
 
-import Test.Tasty (defaultMain, testGroup)
+import Data.Proxy
+import Data.Typeable (Typeable)
+import Lib (compareToReferenceImage)
+import Test.Tasty
 import Test.Tasty.HUnit (testCase)
+import Test.Tasty.Options
 
-import Lib
+newtype UpdateGoldenTests = UpdateGoldenTests Bool
+  deriving (Eq, Ord, Typeable)
+
+instance IsOption UpdateGoldenTests where
+  parseValue = fmap UpdateGoldenTests . safeRead
+  defaultValue = UpdateGoldenTests False
+  optionName = return "refresh"
+  optionHelp = return "Should overwrite the golden test images"
+  optionCLParser = mkFlagCLParser mempty (UpdateGoldenTests True)
 
 main :: IO ()
 main = do
-  defaultMain $
-    testGroup
-      "Test structure assembly"
-      [ mkGroup
-          "Black and white"
-          [ "circle-and-crosses"
-          , "checkerboard"
-          ]
-      , mkGroup
-          "Color"
-          [ "rainbow"
+  defaultMainWithIngredients ingredients $ askOption $ \(UpdateGoldenTests shouldRefreshTests) ->
+    let doTest stem =
+          testCase (unwords ["Image equality:", stem]) $
+            compareToReferenceImage shouldRefreshTests stem
+
+        mkGroup title members =
+          testGroup title $
+            map
+              doTest
+              members
+     in testGroup
+          "Test structure assembly"
+          [ mkGroup
+              "Black and white"
+              [ "circle-and-crosses"
+              , "checkerboard"
+              ]
+          , mkGroup
+              "Color"
+              [ "rainbow"
+              ]
           ]
-      ]
  where
-  doTest stem =
-    testCase (unwords ["Image equality:", stem]) $
-      compareToReferenceImage stem
-
-  mkGroup title members =
-    testGroup title $
-      map
-        doTest
-        members
+  ingredients = includingOptions [Option (Proxy :: Proxy UpdateGoldenTests)] : defaultIngredients