diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs index 6f6c632e9..d6cd81ee5 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs +++ b/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 diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs index f8f5ae1d6..eee275202 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs +++ b/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 diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs index e866c1c43..338d41ce8 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs +++ b/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,7 +125,7 @@ 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 @@ -127,12 +133,12 @@ instance (Alternative f) => Semigroup (PositionedGrid (f a)) where -- 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 <>) diff --git a/test/unit/Main.hs b/test/unit/Main.hs index d67f9d696..e03caccb6 100644 --- a/test/unit/Main.hs +++ b/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 diff --git a/test/unit/TestOverlay.hs b/test/unit/TestOverlay.hs index 1481c3f79..1ab19012a 100644 --- a/test/unit/TestOverlay.hs +++ b/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,10 +98,25 @@ 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)) ] @@ -109,6 +124,19 @@ testOverlay = ] -- * 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 () \ No newline at end of file + print pg + print $ getRows $ gridContent pg + Left _ -> return ()