fix offset logic

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 = 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/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) =
-        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 = childAdjustedOrigin .+^ asVector yamlPlacementOffset
     positionedOverlay = PositionedGrid placementAdjustedByOrigin reorientedOverlayCells
 
 -- * Validation

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

@@ -6,13 +6,17 @@
 -- Generic overlay operations on grids
 module Swarm.Game.Scenario.Topography.Structure.Overlay (
   PositionedGrid (..),
+
+  -- * Exported for unit tests
+  computeMergedArea,
+  OverlayPair (..),
 ) where
 
 import Control.Applicative
 import Data.Function (on)
 import Data.Int (Int32)
 import Data.Tuple (swap)
-import Linear
+import Linear (V2 (..))
 import Swarm.Game.Location
 import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Grid
@@ -25,6 +29,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 +54,27 @@ data SubsumingRect = SubsumingRect
   , _southeastCorner :: Location
   }
 
+getNorthwesternExtent :: Location -> Location -> Location
+getNorthwesternExtent (Location ulx1 uly1) (Location ulx2 uly2) =
+  Location westernMostX northernMostY
+ where
+  westernMostX = min ulx1 ulx2
+  northernMostY = max uly1 uly2
+
+getSoutheasternExtent :: Location -> Location -> Location
+getSoutheasternExtent (Location brx1 bry1) (Location brx2 bry2) =
+  Location easternMostX southernMostY
+ where
+  easternMostX = max brx1 brx2
+  southernMostY = min bry1 bry2
+
 -- | @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
+  SubsumingRect ul1 br1 <> SubsumingRect ul2 br2 =
+    SubsumingRect northwesternExtent southeasternExtent
+   where
+    northwesternExtent = getNorthwesternExtent ul1 ul2
+    southeasternExtent = getSoutheasternExtent br1 br2
 
 getSubsumingRect :: PositionedGrid a -> SubsumingRect
 getSubsumingRect (PositionedGrid loc g) =
@@ -75,7 +94,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 +115,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 +124,35 @@ 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
-    -- 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
+    upperLeftCornersDelta = overlayLoc .-. baseLoc
+
+    newUpperLeftCornerPosition = getNorthwesternExtent baseLoc overlayLoc
 
     paddedOverlayPair =
-      padSouthwest originDelta $
+      padNorthwest upperLeftCornersDelta $
         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.
 --
 -- TODO(#2004): The return type should be 'Grid'.
-padSouthwest ::
+--
+-- '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.
+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/unit/Main.hs

@@ -54,18 +54,40 @@ 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 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