Restyle fix placement offsets

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

@@ -22,6 +22,7 @@ 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 (trace)
 import Linear.Affine
 import Swarm.Game.Location
 import Swarm.Game.Scenario.Topography.Area
@@ -122,10 +123,27 @@ overlayGridExpanded
   -- The 'childAdjustedOrigin' is the sum of origin adjustments
   -- to completely assemble some substructure.
   (PositionedGrid childAdjustedOrigin overlayArea) =
-    baseGrid <> positionedOverlay
+    trace
+      ( unwords
+          [ "Merging base grid at position"
+          , show $ gridPosition baseGrid
+          , "with overlay grid at position"
+          , show $ gridPosition positionedOverlay
+          ]
+      )
+      result
    where
+    result = baseGrid <> positionedOverlay
+
     reorientedOverlayCells = applyOrientationTransform orientation overlayArea
-    placementAdjustedByOrigin = (gridPosition baseGrid .+^ asVector yamlPlacementOffset) .-^ asVector childAdjustedOrigin
+
+    -- placementAdjustedByOrigin = (gridPosition baseGrid .+^ asVector yamlPlacementOffset) .-^ asVector childAdjustedOrigin
+    placementAdjustedByOrigin = yamlPlacementOffset
+
+    -- FIXME This experiment gives incorrect results
+    -- (examine "simultaneous-north-and-west-offset.yaml"):
+    -- placementAdjustedByOrigin = yamlPlacementOffset .-^ asVector childAdjustedOrigin
+
     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 Data.Function (on)
 import Data.Int (Int32)
 import Data.Tuple (swap)
-import Linear
+import Debug.Trace (trace)
+import Linear hiding (trace)
 import Swarm.Game.Location
 import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Grid
@@ -79,7 +84,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
 
@@ -102,7 +107,8 @@ instance (Alternative f) => Semigroup (PositionedGrid (f a)) where
   a1@(PositionedGrid baseLoc baseGrid) <> a2@(PositionedGrid overlayLoc overlayGrid) =
     PositionedGrid newOrigin combinedGrid
    where
-    mergedSize = computeMergedArea $ OverlayPair a1 a2
+    mergedSize2 = computeMergedArea $ OverlayPair a1 a2
+    mergedSize = trace (unwords ["Merged size for ", show a1, "and", show a2, ":", show mergedSize2]) mergedSize2
     combinedGrid = zipGridRows mergedSize paddedOverlayPair
 
     -- We create a vector from the overlay position,
@@ -119,20 +125,20 @@ instance (Alternative f) => Semigroup (PositionedGrid (f a)) where
     newOrigin = baseLoc .-^ clampedDelta
 
     paddedOverlayPair =
-      padSouthwest originDelta $
+      padNorthwest originDelta $
         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 ::
+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

@@ -45,27 +45,43 @@ import Witch (from)
 
 main :: IO ()
 main = do
-  ms <- runExceptT classicGame0
-  case ms of
-    Left err -> assertFailure (from err)
-    Right s -> defaultMain (tests s)
+  defaultMain statelessTests
 
-tests :: AppState -> TestTree
-tests s =
+-- ms <- runExceptT classicGame0
+-- case ms of
+--   Left err -> assertFailure (from err)
+--   Right s -> defaultMain (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
-    "Tests"
+    "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

@@ -9,6 +9,7 @@ module TestOverlay where
 import Control.Monad (when)
 import Data.Text (Text)
 import Swarm.Game.Location
+import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Scenario.Topography.Placement
 import Swarm.Game.Scenario.Topography.Structure
@@ -27,7 +28,6 @@ debugRenderGrid = True
 oneByOneGrid :: [[Int]]
 oneByOneGrid = [[0]]
 
-
 -- | Single row with two columns
 oneByTwoGrid :: [[Int]]
 oneByTwoGrid = [[5, 6]]
@@ -98,17 +98,45 @@ testOverlay =
             ]
         , testGroup
             "Northwesterly offset of first sibling"
-            [ mkOverlaySequenceOriginTest
+            [ --  testMergedSize
+              --   "test merged size"
+              --   (placeUnshifted "baseLayer" (Location 0 0) [[]])
+              --   (placeUnshifted "sibling1" (Location (-1) 1) oneByOneGrid)
+              --   (AreaDimensions 1 1)
+
+              -- , testMergedSize
+              --   "test merged size"
+              --   (place (Location 1 (-1)) "sibling1" (Location (-1) 1) oneByOneGrid)
+              --   (placeUnshifted "sibling2" (Location 0 0) twoByTwoGrid)
+              --   (AreaDimensions 3 3)
+              -- ,
+
+              mkOverlaySequenceOriginTest
                 "positive first south of second"
                 [ placeUnshifted "sibling1" (Location (-1) 1) oneByOneGrid
                 , placeUnshifted "sibling2" (Location 0 0) twoByTwoGrid
+                -- [ placeUnshifted "sibling2" (Location 0 0) twoByTwoGrid
+                -- , placeUnshifted "sibling1" (Location (-1) 1) oneByOneGrid
                 ]
                 (Location 1 (-1))
             ]
         ]
     ]
 
 -- * Test construction
+testMergedSize ::
+  String ->
+  Placed (Maybe Int) ->
+  Placed (Maybe Int) ->
+  AreaDimensions ->
+  TestTree
+testMergedSize testLabel (Placed _ ns1) (Placed _ ns2) expectedArea =
+  testCase testLabel $ do
+    assertEqual "Merged area is wrong" expectedArea mergedSize
+ where
+  a1 = area $ structure ns1
+  a2 = area $ structure ns2
+  mergedSize = computeMergedArea $ OverlayPair a1 a2
 
 -- | Base layer is at the origin (0, 0).
 mkOriginTestCase ::
@@ -140,7 +168,6 @@ mkOverlaySequenceTest ::
   TestTree
 mkOverlaySequenceTest f testLabel overlays expectedBaseLoc =
   testCase testLabel $ do
-
     when debugRenderGrid $
       renderGridResult eitherResultGrid
 
@@ -158,7 +185,6 @@ mkOverlaySequenceTest f testLabel overlays expectedBaseLoc =
       overlays
       []
 
-
 getGridFromMergedStructure :: MergedStructure c -> PositionedGrid c
 getGridFromMergedStructure (MergedStructure g _ _) = g
 
@@ -194,6 +220,6 @@ place localOrigin theName placementOffset g =
 renderGridResult :: Either a (PositionedGrid (Maybe Int)) -> IO ()
 renderGridResult eitherResult = case eitherResult of
   Right pg -> do
-      print pg
-      print $ getRows $ gridContent pg
-  Left _ -> return ()
+    print pg
+    print $ getRows $ gridContent pg
+  Left _ -> return ()