fixup tests

test/unit/Main.hs

@@ -45,12 +45,18 @@ import Witch (from)
 
 main :: IO ()
 main = do
-  defaultMain statelessTests
+  ms <- runExceptT classicGame0
+  case ms of
+    Left err -> assertFailure (from err)
+    Right s -> defaultMain (tests s)
 
--- ms <- runExceptT classicGame0
--- case ms of
---   Left err -> assertFailure (from err)
---   Right s -> defaultMain (stateDependentTests s)
+tests :: AppState -> TestTree
+tests s =
+  testGroup
+    "Tests"
+    [ statelessTests
+    , stateDependentTests s
+    ]
 
 -- | Initializing an 'AppState' entails
 -- loading challenge scenarios, etc. from

test/unit/TestOverlay.hs

@@ -20,7 +20,7 @@ import Test.Tasty
 import Test.Tasty.HUnit
 
 debugRenderGrid :: Bool
-debugRenderGrid = True
+debugRenderGrid = False
 
 -- * Example grids
 
@@ -45,12 +45,8 @@ testOverlay =
     "Overlay"
     [ testGroup
         "Empty grids, base grid at origin"
-        [ mkOriginTestCase "Southward" (Location 3 2) (Location 0 2)
-        , -- Overlay is to the west and south of the base.
-          -- Therefore, the origin of the combined grid must
-          -- be adjusted eastward to match its original position
-          -- in the base layer.
-          mkOriginTestCase "Eastward" (Location (-7) (-1)) (Location (-7) 0)
+        [ mkOriginTestCase "Northward" (Location 3 2) (Location 0 2)
+        , mkOriginTestCase "Westward" (Location (-7) (-1)) (Location (-7) 0)
         ]
     , testGroup
         "Overlay sequences"
@@ -85,29 +81,21 @@ testOverlay =
                 (Location 0 2)
             ]
         , testGroup
-            "Nonzero local origin"
-            [ mkOverlaySequenceOriginTest
-                "positive first south of second"
-                [ place (Location 2 0) "sibling1" (Location 0 0) twoByTwoGrid
-                ]
-                (Location 2 0)
+            "Merge sizes"
+            [ testMergedSize
+                "merge an offset 1x1 atop a 0x0 base"
+                (mkNamedStructure "baseLayer" (Location 0 0) [[]])
+                (mkNamedStructure "sibling1" (Location (-1) 1) oneByOneGrid)
+                (AreaDimensions 1 1)
+            , testMergedSize
+                "merge a 2x2 atop a 1x1 with an offset"
+                (mkNamedStructure "sibling1" (Location (-1) 1) oneByOneGrid)
+                (mkNamedStructure "sibling2" (Location 0 0) twoByTwoGrid)
+                (AreaDimensions 3 3)
             ]
         , testGroup
             "Northwesterly offset of first sibling"
-            [ --  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
+            [ mkOverlaySequenceOriginTest
                 "positive first south of second"
                 [ placeUnshifted "sibling1" (Location (-1) 1) oneByOneGrid
                 , placeUnshifted "sibling2" (Location 0 0) twoByTwoGrid
@@ -120,11 +108,11 @@ testOverlay =
 -- * Test construction
 testMergedSize ::
   String ->
-  Placed (Maybe Int) ->
-  Placed (Maybe Int) ->
+  NamedStructure (Maybe Int) ->
+  NamedStructure (Maybe Int) ->
   AreaDimensions ->
   TestTree
-testMergedSize testLabel (Placed _ ns1) (Placed _ ns2) expectedArea =
+testMergedSize testLabel ns1 ns2 expectedArea =
   testCase testLabel $ do
     assertEqual "Merged area is wrong" expectedArea mergedSize
  where
@@ -171,7 +159,6 @@ mkOverlaySequenceTest f testLabel overlays expectedBaseLoc =
   baseArea = PositionedGrid (Location 0 0) (EmptyGrid :: Grid (Maybe Int))
 
   eitherResultGrid = getGridFromMergedStructure <$> eitherResult
-
   eitherResult =
     foldLayer
       mempty
@@ -201,12 +188,22 @@ place ::
   Placed (Maybe a)
 place localOrigin theName placementOffset g =
   Placed (Placement sName (Pose placementOffset defaultOrientation)) $
-    NamedArea sName mempty mempty s
+    mkNamedStructure theName localOrigin g
+ where
+  sName = StructureName theName
+
+mkNamedStructure ::
+  Text ->
+  Location ->
+  [[a]] ->
+  NamedArea (PStructure (Maybe a))
+mkNamedStructure theName pos g =
+  NamedArea sName mempty mempty s
  where
   sName = StructureName theName
   s =
     Structure
-      (PositionedGrid localOrigin $ Just <$> mkGrid g)
+      (PositionedGrid pos $ Just <$> mkGrid g)
       mempty
       mempty
       mempty