diff --git a/data/scenarios/Testing/1780-structure-merge-expansion/simultaneous-north-and-west-offset.yaml b/data/scenarios/Testing/1780-structure-merge-expansion/simultaneous-north-and-west-offset.yaml index 3619d7aba..ca7c54648 100644 --- a/data/scenarios/Testing/1780-structure-merge-expansion/simultaneous-north-and-west-offset.yaml +++ b/data/scenarios/Testing/1780-structure-merge-expansion/simultaneous-north-and-west-offset.yaml @@ -7,6 +7,7 @@ description: | robots: - name: base dir: north + loc: [0, 2] creative: true objectives: - goal: @@ -48,12 +49,9 @@ world: , mask (y > -2 && y < 2 || x > -2 && x < 2) {ice} , mask (y > -1 && y < 1 || x > -1 && x < 1) {dirt} ] - palette: - 'Ω': [grass, erase, base] mask: '.' placements: - src: master offset: [0, 0] upperleft: [0, 0] - map: | - Ω + map: "" diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs index 92ec53f14..a05d1680b 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs @@ -122,8 +122,7 @@ instance FromJSONE WorldParseDependencies WorldDescription where let placedStructures = map (offsetLoc $ coerce ul) staticStructurePlacements - let area = modifyLoc ((ul .-^) . asVector) mergedGrid - + let area = modifyLoc ((ul .+^) . asVector) mergedGrid return $ WorldDescription {..} ------------------------------------------------------------ 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..4b2fa8c4d 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,20 @@ 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 = 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..d2ee7e33a 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 @@ -50,16 +55,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) = @@ -79,7 +95,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 @@ -100,26 +116,33 @@ 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 + 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, -- 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 @@ -127,12 +150,22 @@ 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 :: +-- +-- '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 <>) 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..42297d08b 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]] @@ -45,16 +45,12 @@ testOverlay = "Overlay" [ testGroup "Empty grids, base grid at origin" - [ -- Overlay is to the east and north of the base. - -- Therefore, the origin of the combined grid must - -- be adjusted southward to match its original position - -- in the base layer. - mkOriginTestCase "Southward" (Location 3 2) (Location 0 (-2)) + [ 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 "Eastward" (Location (-7) (-1)) (Location (-7) 0) ] , testGroup "Overlay sequences" @@ -65,13 +61,13 @@ testOverlay = [ placeUnshifted "sibling1" (Location (-2) 0) twoByTwoGrid , placeUnshifted "sibling2" (Location 0 0) oneByTwoGrid ] - (Location 2 0) + (Location (-2) 0) , mkOverlaySequenceOriginTest "first east of negative second" [ placeUnshifted "sibling1" (Location 0 0) twoByTwoGrid , placeUnshifted "sibling2" (Location (-2) 0) oneByTwoGrid ] - (Location 2 0) + (Location (-2) 0) ] , testGroup "Vertical siblings" @@ -80,13 +76,13 @@ testOverlay = [ placeUnshifted "sibling1" (Location 0 2) twoByTwoGrid , placeUnshifted "sibling2" (Location 0 0) oneByTwoGrid ] - (Location 0 (-2)) + (Location 0 2) , mkOverlaySequenceOriginTest "first north of positive second" [ placeUnshifted "sibling1" (Location 0 0) twoByTwoGrid , placeUnshifted "sibling2" (Location 0 2) oneByTwoGrid ] - (Location 0 (-2)) + (Location 0 2) ] , testGroup "Nonzero local origin" @@ -98,17 +94,43 @@ 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 ] - (Location 1 (-1)) + (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 +162,6 @@ mkOverlaySequenceTest :: TestTree mkOverlaySequenceTest f testLabel overlays expectedBaseLoc = testCase testLabel $ do - when debugRenderGrid $ renderGridResult eitherResultGrid @@ -158,7 +179,6 @@ mkOverlaySequenceTest f testLabel overlays expectedBaseLoc = overlays [] - getGridFromMergedStructure :: MergedStructure c -> PositionedGrid c getGridFromMergedStructure (MergedStructure g _ _) = g @@ -194,6 +214,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 ()