diff --git a/data/scenarios/Testing/1780-structure-merge-expansion/00-ORDER.txt b/data/scenarios/Testing/1780-structure-merge-expansion/00-ORDER.txt index ed9116ef..37cfa070 100644 --- a/data/scenarios/Testing/1780-structure-merge-expansion/00-ORDER.txt +++ b/data/scenarios/Testing/1780-structure-merge-expansion/00-ORDER.txt @@ -1,4 +1,6 @@ nonoverlapping-structure-merge.yaml root-map-expansion.yaml structure-composition.yaml -sequential-placement.yaml \ No newline at end of file +sequential-placement.yaml +coordinate-offset-propagation.yaml +simultaneous-north-and-west-offset.yaml diff --git a/data/scenarios/Testing/1780-structure-merge-expansion/coordinate-offset-propagation.yaml b/data/scenarios/Testing/1780-structure-merge-expansion/coordinate-offset-propagation.yaml new file mode 100644 index 00000000..70dc9370 --- /dev/null +++ b/data/scenarios/Testing/1780-structure-merge-expansion/coordinate-offset-propagation.yaml @@ -0,0 +1,77 @@ +version: 1 +name: Structure coordinate offset propagation +author: Karl Ostmo +description: | + If a structure incorporates subplacements + entailing negative offsets, its coordinate origin must be shifted. + + The updated coordinate origin should be propagated to parent structures + and utilized to offset placement. +robots: + - name: base + dir: north + loc: [0, 3] +objectives: + - goal: + - Enjoy the view. + condition: | + return true +solution: | + noop +known: [boulder, log, pixel (R), pixel (G), pixel (B), gold] +world: + structures: + - name: micro + structure: + mask: '.' + palette: + 'x': [stone, gold] + map: | + xx + - name: block + structure: + mask: '.' + palette: + 'x': [stone, pixel (R)] + map: | + xx + xx + - name: master + structure: + mask: '.' + palette: + 'x': [stone, pixel (B)] + placements: + - src: block + offset: [0, 1] + - src: micro + offset: [-2, 0] + map: | + ..x + ..x + ..x + - name: final + structure: + mask: '.' + palette: + 'x': [stone, pixel (G)] + placements: + - src: master + map: | + x + x + x + x + dsl: | + overlay + [ {grass} + , mask (y > -4 && y < 4 || x > -4 && x < 4) {stone} + , mask (y > -2 && y < 2 || x > -2 && x < 2) {ice} + , mask (y > -1 && y < 1 || x > -1 && x < 1) {dirt} + ] + mask: '.' + placements: + - src: final + offset: [0, 0] + upperleft: [0, 0] + map: "" diff --git a/data/scenarios/Testing/1780-structure-merge-expansion/sequential-placement.yaml b/data/scenarios/Testing/1780-structure-merge-expansion/sequential-placement.yaml index c007f7c9..206f9fff 100644 --- a/data/scenarios/Testing/1780-structure-merge-expansion/sequential-placement.yaml +++ b/data/scenarios/Testing/1780-structure-merge-expansion/sequential-placement.yaml @@ -13,7 +13,7 @@ objectives: - Must have 3 of each color visible condition: | def countColor = \e. - resonate e ((0, 0), (10, -5)); + resonate e ((-6, 0), (4, -4)); end; as base { @@ -87,7 +87,7 @@ world: mask: '.' placements: - src: block - offset: [0, -1] + offset: [0, -2] upperleft: [0, 0] dsl: | {grass} 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 new file mode 100644 index 00000000..7b52bdf5 --- /dev/null +++ b/data/scenarios/Testing/1780-structure-merge-expansion/simultaneous-north-and-west-offset.yaml @@ -0,0 +1,56 @@ +version: 1 +name: Northwest sibling structure coordinate offsets +author: Karl Ostmo +description: | + Make sure that the second sibling is displayed correctly when there + is a simultaneous negative-x and positive-y offset on the first sibling. +robots: + - name: base + dir: north + loc: [0, 2] +objectives: + - goal: + - Enjoy the view. + condition: | + return true +solution: | + noop +known: [pixel (R), gold] +world: + structures: + - name: micro + structure: + mask: '.' + palette: + 'x': [stone, gold] + map: | + x + - name: block + structure: + mask: '.' + palette: + 'x': [stone, pixel (R)] + map: | + xx + xx + - name: master + structure: + mask: '.' + placements: + - src: micro + offset: [-1, 1] + - src: block + map: "" + dsl: | + overlay + [ {grass} + , mask (y > -4 && y < 4 || x > -4 && x < 4) {stone} + , mask (y > -2 && y < 2 || x > -2 && x < 2) {ice} + , mask (y > -1 && y < 1 || x > -1 && x < 1) {dirt} + ] + mask: '.' + placements: + - src: master + offset: [0, 0] + upperleft: [0, 0] + map: "" diff --git a/data/test/standalone-topography/circle-and-crosses.yaml b/data/test/standalone-topography/circle-and-crosses.yaml index dada1adf..c6781655 100644 --- a/data/test/standalone-topography/circle-and-crosses.yaml +++ b/data/test/standalone-topography/circle-and-crosses.yaml @@ -55,5 +55,5 @@ placements: orient: up: west - src: disc - offset: [8, -8] + offset: [5, -8] map: "" diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs index 729d087f..a05d1680 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 88470573..03b48382 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 6f6c632e..d6cd81ee 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 3c620ef9..bf44ad64 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 cb95e82a..81bb9eb8 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 Control.Lens (view) import Data.Function (on) import Data.Int (Int32) import Data.Tuple (swap) -import Linear +import Linear.V2 (R1 (_x), R2 (_y), V2 (..)) import Swarm.Game.Location import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.Grid @@ -25,6 +30,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 +55,27 @@ data SubsumingRect = SubsumingRect , _southeastCorner :: Location } +getNorthwesternExtent :: Location -> Location -> Location +getNorthwesternExtent ul1 ul2 = + Location westernMostX northernMostY + where + westernMostX = (min `on` view _x) ul1 ul2 + northernMostY = (max `on` view _y) ul1 ul2 + +getSoutheasternExtent :: Location -> Location -> Location +getSoutheasternExtent br1 br2 = + Location easternMostX southernMostY + where + easternMostX = (max `on` view _x) br1 br2 + southernMostY = (min `on` view _y) br1 br2 + -- | @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 +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 @@ -96,7 +116,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,30 +125,36 @@ 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 +-- | +-- '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. +-- +-- 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 <>) diff --git a/test/integration/Main.hs b/test/integration/Main.hs index 61225f2c..c0b5a4d0 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -444,6 +444,8 @@ testScenarioSolutions rs ui key = , testGroup "Structure placement (#1780)" [ testSolution Default "Testing/1780-structure-merge-expansion/sequential-placement" + , testSolution Default "Testing/1780-structure-merge-expansion/coordinate-offset-propagation" + , testSolution Default "Testing/1780-structure-merge-expansion/simultaneous-north-and-west-offset" -- TODO(#2148) define goal conditions or convert to image fixtures -- , testSolution Default "Testing/1780-structure-merge-expansion/nonoverlapping-structure-merge" -- , testSolution Default "Testing/1780-structure-merge-expansion/root-map-expansion" diff --git a/test/unit/Main.hs b/test/unit/Main.hs index d67f9d69..a2566a17 100644 --- a/test/unit/Main.hs +++ b/test/unit/Main.hs @@ -54,18 +54,38 @@ 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 scenario loading 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 1b353ef0..a9aadafc 100644 --- a/test/unit/TestOverlay.hs +++ b/test/unit/TestOverlay.hs @@ -4,30 +4,128 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Unit tests for generic grid overlay logic -module TestOverlay where +module TestOverlay (testOverlay) where +import Control.Monad (when) +import Data.Function (on) +import Data.Text (Text) import Swarm.Game.Location +import Swarm.Game.Scenario.Topography.Area ( + AreaDimensions (AreaDimensions), + ) 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 ( + foldLayer, + ) +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 + mergedSize = + computeMergedArea $ + (OverlayPair `on` (area . structure)) ns1 ns2 + +-- | Base layer is at the origin (0, 0). mkOriginTestCase :: String -> Location -> @@ -40,3 +138,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 ()