WIP experiment

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

@@ -125,7 +125,12 @@ overlayGridExpanded
     baseGrid <> positionedOverlay
    where
     reorientedOverlayCells = applyOrientationTransform orientation overlayArea
-    placementAdjustedByOrigin = (gridPosition baseGrid .+^ asVector yamlPlacementOffset) .-^ asVector childAdjustedOrigin
+
+    -- placementAdjustedByOrigin = (gridPosition baseGrid .+^ asVector yamlPlacementOffset) .-^ asVector childAdjustedOrigin
+    -- 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 Debug.Trace (trace)
 import Control.Applicative
 import Data.Function (on)
 import Data.Int (Int32)
 import Data.Tuple (swap)
-import Linear
+import Linear hiding (trace)
 import Swarm.Game.Location
 import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Grid
@@ -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,47 @@ testOverlay =
             ]
         , testGroup
             "Northwesterly offset of first sibling"
-            [ mkOverlaySequenceOriginTest
-                "positive first south of second"
-                [ placeUnshifted "sibling1" (Location (-1) 1) oneByOneGrid
-                , placeUnshifted "sibling2" (Location 0 0) twoByTwoGrid
-                ]
-                (Location 1 (-1))
+            [
+
+              --  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 +170,6 @@ mkOverlaySequenceTest ::
   TestTree
 mkOverlaySequenceTest f testLabel overlays expectedBaseLoc =
   testCase testLabel $ do
-
     when debugRenderGrid $
       renderGridResult eitherResultGrid
 
@@ -158,7 +187,6 @@ mkOverlaySequenceTest f testLabel overlays expectedBaseLoc =
       overlays
       []
 
-
 getGridFromMergedStructure :: MergedStructure c -> PositionedGrid c
 getGridFromMergedStructure (MergedStructure g _ _) = g
 
@@ -194,6 +222,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 ()