Restyle [WIP] another test case for structure placement

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,50 @@
+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
+known: [boulder, gold, log]
+world:
+  structures:
+    - name: house
+      structure:
+        palette:
+          'x': [stone, boulder]
+          'o': [stone, gold]
+        map: |
+          xxxo
+          xxoo
+          xooo
+          oooo
+    - name: block
+      structure:
+        palette:
+          'x': [ice, log]
+        placements:
+          - src: house
+            orient:
+              flip: true
+            offset: [-6, 0]
+          - src: house
+
+          # - src: house
+          #   orient:
+          #     flip: true
+          # - src: house
+          #   offset: [6, 0]
+        map: "xx"
+  palette:
+    'Ω': [grass, erase, base]
+  mask: '.'
+  placements:
+    - src: block
+      offset: [0, -1]
+  upperleft: [0, 0]
+  dsl: |
+    {grass}
+  map: |
+    Ω

data/test/standalone-topography/flip-duplicate.yaml

@@ -0,0 +1,46 @@
+structures:
+  - name: house
+    structure:
+      palette:
+        'x': "#ff0000"
+        'A': "#ff8800"
+        '.': "#ffff00"
+      map: |
+        xxxx
+        x..x
+        x..A
+        xxAA
+  - name: street pair
+    structure:
+      palette:
+        '.': "#00ff00"
+      placements:
+        - src: house
+          offset: [-1, 0]
+          orient:
+            up: south
+      map: |
+        .
+        .
+        .
+        .
+        .
+        .
+        .
+        .
+        .
+  - name: block
+    structure:
+      placements:
+        - src: street pair
+          orient:
+            flip: true
+        - src: street pair
+      map: ""
+placements:
+  - src: street pair
+    orient:
+      flip: true
+  - src: street pair
+upperleft: [0, 0]
+map: ""

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

@@ -19,10 +19,10 @@ import Data.Map qualified as M
 import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Text qualified as T
+import Debug.Trace
 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 +42,26 @@ 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
+        mergedArea2 = overlayGridExpanded (show sName) inputArea pose overlayArea
+        mergedArea =
+          trace
+            ( unwords
+                [ "For placement of"
+                , show sName
+                , "at loc"
+                , show loc
+                , "where input has offset"
+                , show $ offset pose
+                ]
+            )
+            mergedArea2
 
     return $ MergedStructure mergedArea mergedPlacements mergedWaypoints
    where
@@ -81,6 +93,8 @@ mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStruct
         map wrapPlacement $
           filter (\(Placed _ ns) -> isRecognizable ns) overlays
 
+  -- TODO: Each successive overlay may alter the coordinate origin.
+  -- Make sure this new origin is propagated to subsequent placements.
   foldlM
     (flip $ overlaySingleStructure structureMap)
     (MergedStructure origArea wrappedOverlays originatedWaypoints)
@@ -97,18 +111,39 @@ mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStruct
 -- * Grid manipulation
 
 overlayGridExpanded ::
-  Grid (Maybe a) ->
+  String ->
+  PositionedGrid (Maybe a) ->
   Pose ->
   PositionedGrid (Maybe a) ->
   PositionedGrid (Maybe a)
 overlayGridExpanded
-  inputGrid
-  (Pose loc orientation)
-  (PositionedGrid _ overlayArea) =
-    PositionedGrid origin inputGrid <> positionedOverlay
+  note
+  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) =
+    trace
+      ( unwords
+          [ "In overlayGridExpanded for"
+          , note
+          , "where childAdjustedOrigin ="
+          , show childAdjustedOrigin
+          , "and placementOffset ="
+          , show yamlPlacementOffset
+          , "and placementAdjustedByOrigin ="
+          , show placementAdjustedByOrigin
+          , ". New origin will be:"
+          , show $ gridPosition output
+          ]
+      )
+      output
    where
+    output = baseGrid <> positionedOverlay
     reorientedOverlayCells = applyOrientationTransform orientation overlayArea
-    positionedOverlay = PositionedGrid loc reorientedOverlayCells
+    placementAdjustedByOrigin = gridPosition baseGrid .+^ (yamlPlacementOffset .-. origin)
+    positionedOverlay = PositionedGrid placementAdjustedByOrigin reorientedOverlayCells
 
 -- * Validation
 

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

@@ -12,7 +12,8 @@ import Control.Applicative
 import Data.Function (on)
 import Data.Int (Int32)
 import Data.Tuple (swap)
-import Linear
+import Debug.Trace
+import Linear hiding (trace)
 import Swarm.Game.Location
 import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Grid
@@ -113,10 +114,23 @@ instance (Alternative f) => Semigroup (PositionedGrid (f a)) where
     -- 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
+    newOrigin2 = baseLoc .-^ clampedDelta
+
+    newOrigin =
+      trace
+        ( unwords
+            [ "COMBINING baseLoc"
+            , show baseLoc
+            , "with overlayLoc"
+            , show overlayLoc
+            , "to get"
+            , show newOrigin2
+            ]
+        )
+        newOrigin2
 
     paddedOverlayPair =
-      padSouthwest originDelta $
+      padSouthwest (overlayLoc .-. origin) $
         OverlayPair baseGrid overlayGrid
 
 -- | NOTE: We only make explicit grid adjustments for

test/integration/Main.hs

@@ -440,7 +440,14 @@ testScenarioSolutions rs ui key =
             [ testSolution Default "Testing/1535-ping/1535-in-range"
             , testSolution Default "Testing/1535-ping/1535-out-of-range"
             ]
-        , testGroup
+        , -- , testGroup
+          --     "Structure placement (#1780)"
+          --     [ 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"
+          --     , testSolution Default "Testing/1780-structure-merge-expansion/sequential-placement"
+          --     ]
+          testGroup
             "Structure recognition (#1575)"
             [ testSolution Default "Testing/1575-structure-recognizer/1575-browse-structures"
             , testSolution Default "Testing/1575-structure-recognizer/1575-nested-structure-definition"

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,48 @@
 -- SPDX-License-Identifier: BSD-3-Clause
 module Main where
 
-import Test.Tasty (defaultMain, testGroup)
+import Data.Proxy
+import Data.Typeable (Typeable)
+import Test.Tasty
 import Test.Tasty.HUnit (testCase)
+import Test.Tasty.Options
 
-import Lib
+import Lib (compareToReferenceImage)
+
+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 ingreds $ 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"
+              , "flip-duplicate"
+              ]
           ]
-      ]
  where
-  doTest stem =
-    testCase (unwords ["Image equality:", stem]) $
-      compareToReferenceImage stem
-
-  mkGroup title members =
-    testGroup title $
-      map
-        doTest
-        members
+  ingreds = includingOptions [Option (Proxy :: Proxy UpdateGoldenTests)] : defaultIngredients