From 2808cddd3d319303397de8d34b14f1507c38418f Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sun, 22 Sep 2024 19:49:06 -0700 Subject: [PATCH] fix offset logic --- .../Scenario/Topography/WorldDescription.hs | 4 +- src/swarm-topography/Swarm/Game/Location.hs | 2 +- .../Swarm/Game/Scenario/Topography/Area.hs | 1 + .../Scenario/Topography/Structure/Assembly.hs | 61 +++--- .../Scenario/Topography/Structure/Overlay.hs | 68 ++++-- test/unit/Main.hs | 28 ++- test/unit/TestOverlay.hs | 194 +++++++++++++++++- 7 files changed, 295 insertions(+), 63 deletions(-) diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs index 729d087f0..a05d1680b 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs @@ -122,9 +122,7 @@ instance FromJSONE WorldParseDependencies WorldDescription where let placedStructures = map (offsetLoc $ coerce ul) staticStructurePlacements - -- Override upper-left corner with explicit location - let area = mergedGrid {gridPosition = ul} - + let area = modifyLoc ((ul .+^) . asVector) mergedGrid return $ WorldDescription {..} ------------------------------------------------------------ diff --git a/src/swarm-topography/Swarm/Game/Location.hs b/src/swarm-topography/Swarm/Game/Location.hs index 884705733..03b48382e 100644 --- a/src/swarm-topography/Swarm/Game/Location.hs +++ b/src/swarm-topography/Swarm/Game/Location.hs @@ -202,7 +202,7 @@ euclidean p1 p2 = norm (fromIntegral <$> (p2 .-. p1)) -- | Converts a 'Point' to a vector offset from the 'origin'. asVector :: Location -> V2 Int32 -asVector loc = loc .-. origin +asVector (P vec) = vec -- | Get all the locations that are within a certain manhattan -- distance from a given location. 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 3c620ef99..bf44ad642 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs @@ -7,6 +7,9 @@ -- as well as logic for combining them. module Swarm.Game.Scenario.Topography.Structure.Assembly ( mergeStructures, + + -- * Exposed for unit tests: + foldLayer, ) where @@ -63,30 +66,15 @@ mergeStructures :: Parentage Placement -> PStructure (Maybe a) -> Either Text (MergedStructure (Maybe a)) -mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStructures subPlacements subWaypoints) = do +mergeStructures inheritedStrucDefs parentPlacement baseStructure = do overlays <- left (elaboratePlacement parentPlacement <>) $ mapM (validatePlacement structureMap) subPlacements - let wrapPlacement (Placed z ns) = - LocatedStructure - (name ns) - (up $ orient structPose) - (offset structPose) - where - structPose = structurePose z - - wrappedOverlays = - map wrapPlacement $ - filter (\(Placed _ ns) -> isRecognizable ns) overlays - - -- NOTE: Each successive overlay may alter the coordinate origin. - -- We make sure this new origin is propagated to subsequent sibling placements. - foldlM - (flip $ overlaySingleStructure structureMap) - (MergedStructure origArea wrappedOverlays originatedWaypoints) - overlays + foldLayer structureMap origArea overlays originatedWaypoints where + Structure origArea subStructures subPlacements subWaypoints = baseStructure + originatedWaypoints = map (Originated parentPlacement) subWaypoints -- deeper definitions override the outer (toplevel) ones @@ -95,6 +83,32 @@ mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStruct (M.fromList $ map (name &&& id) subStructures) inheritedStrucDefs +-- | NOTE: Each successive overlay may alter the coordinate origin. +-- We make sure this new origin is propagated to subsequent sibling placements. +foldLayer :: + M.Map StructureName (NamedStructure (Maybe a)) -> + PositionedGrid (Maybe a) -> + [Placed (Maybe a)] -> + [Originated Waypoint] -> + Either Text (MergedStructure (Maybe a)) +foldLayer structureMap origArea overlays originatedWaypoints = + foldlM + (flip $ overlaySingleStructure structureMap) + (MergedStructure origArea wrappedOverlays originatedWaypoints) + overlays + where + wrappedOverlays = + map wrapPlacement $ + filter (\(Placed _ ns) -> isRecognizable ns) overlays + + wrapPlacement (Placed z ns) = + LocatedStructure + (name ns) + (up $ orient structPose) + (offset structPose) + where + structPose = structurePose z + -- * Grid manipulation overlayGridExpanded :: @@ -105,14 +119,13 @@ overlayGridExpanded :: overlayGridExpanded baseGrid (Pose yamlPlacementOffset orientation) - -- NOTE: The '_childAdjustedOrigin' is the sum of origin adjustments - -- to completely assemble some substructure. However, we discard - -- this when we place a substructure into a new base grid. - (PositionedGrid _childAdjustedOrigin overlayArea) = + -- The 'childAdjustedOrigin' is the sum of origin adjustments + -- to completely assemble some substructure. + (PositionedGrid childAdjustedOrigin overlayArea) = baseGrid <> positionedOverlay where reorientedOverlayCells = applyOrientationTransform orientation overlayArea - placementAdjustedByOrigin = gridPosition baseGrid .+^ asVector yamlPlacementOffset + placementAdjustedByOrigin = childAdjustedOrigin .+^ asVector yamlPlacementOffset 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 cb95e82a1..08496e241 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,17 @@ -- 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 Linear (V2 (..)) import Swarm.Game.Location import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.Grid @@ -25,6 +29,10 @@ data PositionedGrid a = PositionedGrid } deriving (Eq) +instance HasLocation (PositionedGrid a) where + modifyLoc f (PositionedGrid originalLoc g) = + PositionedGrid (f originalLoc) g + instance Show (PositionedGrid a) where show (PositionedGrid p g) = unwords @@ -46,16 +54,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) = @@ -75,7 +94,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 @@ -96,7 +115,7 @@ 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 combinedGrid = zipGridRows mergedSize paddedOverlayPair @@ -105,17 +124,12 @@ instance (Alternative f) => Semigroup (PositionedGrid (f a)) where -- 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 @@ -123,12 +137,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..8d1f0a656 100644 --- a/test/unit/Main.hs +++ b/test/unit/Main.hs @@ -54,18 +54,40 @@ tests :: AppState -> TestTree tests s = testGroup "Tests" + [ statelessTests + , 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 + "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 1b353ef0b..c02f14f85 100644 --- a/test/unit/TestOverlay.hs +++ b/test/unit/TestOverlay.hs @@ -6,28 +6,121 @@ -- Unit tests for generic grid overlay logic 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 +import Swarm.Game.Scenario.Topography.Structure.Assembly +import Swarm.Game.Scenario.Topography.Structure.Named import Swarm.Game.Scenario.Topography.Structure.Overlay import Test.Tasty import Test.Tasty.HUnit +debugRenderGrid :: Bool +debugRenderGrid = False + +-- * Example grids + +-- | Single cell +oneByOneGrid :: [[Int]] +oneByOneGrid = [[0]] + +-- | Single row with two columns +oneByTwoGrid :: [[Int]] +oneByTwoGrid = [[5, 6]] + +-- | Two rows with two columns +twoByTwoGrid :: [[Int]] +twoByTwoGrid = + [ [1, 2] + , [3, 4] + ] + testOverlay :: TestTree testOverlay = testGroup "Overlay" - [ -- 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)) - , -- 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) + [ testGroup + "Empty grids, base grid at origin" + [ mkOriginTestCase "Northward" (Location 3 2) (Location 0 2) + , mkOriginTestCase "Westward" (Location (-7) (-1)) (Location (-7) 0) + ] + , testGroup + "Overlay sequences" + [ testGroup + "Horizontal siblings" + [ mkOverlaySequenceOriginTest + "negative first west of second" + [ placeUnshifted "sibling1" (Location (-2) 0) twoByTwoGrid + , placeUnshifted "sibling2" (Location 0 0) oneByTwoGrid + ] + (Location (-2) 0) + , mkOverlaySequenceOriginTest + "first east of negative second" + [ placeUnshifted "sibling1" (Location 0 0) twoByTwoGrid + , placeUnshifted "sibling2" (Location (-2) 0) oneByTwoGrid + ] + (Location (-2) 0) + ] + , testGroup + "Vertical siblings" + [ mkOverlaySequenceOriginTest + "positive first south of second" + [ placeUnshifted "sibling1" (Location 0 2) twoByTwoGrid + , placeUnshifted "sibling2" (Location 0 0) oneByTwoGrid + ] + (Location 0 2) + , mkOverlaySequenceOriginTest + "first north of positive second" + [ placeUnshifted "sibling1" (Location 0 0) twoByTwoGrid + , placeUnshifted "sibling2" (Location 0 2) oneByTwoGrid + ] + (Location 0 2) + ] + , testGroup + "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" + [ mkOverlaySequenceOriginTest + "positive first south of second" + [ placeUnshifted "sibling1" (Location (-1) 1) oneByOneGrid + , placeUnshifted "sibling2" (Location 0 0) twoByTwoGrid + ] + (Location (-1) 1) + ] + ] ] +-- * Test construction +testMergedSize :: + String -> + NamedStructure (Maybe Int) -> + NamedStructure (Maybe Int) -> + AreaDimensions -> + TestTree +testMergedSize testLabel ns1 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 :: String -> Location -> @@ -40,3 +133,84 @@ mkOriginTestCase adjustmentDescription overlayLocation expectedBaseLoc = baseLayer = PositionedGrid (Location 0 0) (EmptyGrid :: Grid (Maybe ())) overlayLayer = PositionedGrid overlayLocation EmptyGrid PositionedGrid actualBaseLoc _ = baseLayer <> overlayLayer + +mkOverlaySequenceOriginTest :: + String -> + [Placed (Maybe Int)] -> + Location -> + TestTree +mkOverlaySequenceOriginTest = mkOverlaySequenceTest gridPosition + +mkOverlaySequenceTest :: + (Show a, Eq a) => + (PositionedGrid (Maybe Int) -> a) -> + String -> + [Placed (Maybe Int)] -> + a -> + TestTree +mkOverlaySequenceTest f testLabel overlays expectedBaseLoc = + testCase testLabel $ do + when debugRenderGrid $ + renderGridResult eitherResultGrid + + assertEqual "Base loc wrong" (Right expectedBaseLoc) $ + f <$> eitherResultGrid + where + baseArea = PositionedGrid (Location 0 0) (EmptyGrid :: Grid (Maybe Int)) + + eitherResultGrid = getGridFromMergedStructure <$> eitherResult + eitherResult = + foldLayer + mempty + baseArea + overlays + [] + +getGridFromMergedStructure :: MergedStructure c -> PositionedGrid c +getGridFromMergedStructure (MergedStructure g _ _) = g + +-- | Place an structure at an offset. +-- The structure's local origin is (0, 0). +placeUnshifted :: + Text -> + Location -> + [[a]] -> + Placed (Maybe a) +placeUnshifted = place (Location 0 0) + +-- | Place a structure at an offset. +-- That structure's local origin might not be (0, 0). +place :: + Location -> + Text -> + Location -> + [[a]] -> + Placed (Maybe a) +place localOrigin theName placementOffset g = + Placed (Placement sName (Pose placementOffset defaultOrientation)) $ + 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 pos $ Just <$> mkGrid g) + mempty + mempty + mempty + +renderGridResult :: Either a (PositionedGrid (Maybe Int)) -> IO () +renderGridResult eitherResult = case eitherResult of + Right pg -> do + print pg + print $ getRows $ gridContent pg + Left _ -> return ()