From d7ec853ff073c1984314278a5a14a1cb4497d173 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sat, 4 May 2024 18:15:02 -0700 Subject: [PATCH 1/2] Implement non-truncating structure overlays --- data/scenarios/Testing/00-ORDER.txt | 3 +- .../00-ORDER.txt | 3 + .../nonoverlapping-structure-merge.yaml | 61 +++++++ .../root-map-expansion.yaml | 34 ++++ .../structure-composition.yaml | 111 ++++++++++++ scripts/test/run-tests.sh | 5 +- src/swarm-scenario/Swarm/Game/Scenario.hs | 3 +- .../Swarm/Game/Scenario/Topography/Area.hs | 28 ++- .../Game/Scenario/Topography/Structure.hs | 7 +- .../Scenario/Topography/Structure/Assembly.hs | 42 +++-- .../Scenario/Topography/Structure/Overlay.hs | 161 ++++++++++++++++++ .../Scenario/Topography/WorldDescription.hs | 12 +- .../Game/Scenario/Topography/WorldPalette.hs | 52 ++++-- .../Swarm/Game/State/Landscape.hs | 56 ++++-- src/swarm-scenario/Swarm/Game/World/Coords.hs | 4 + src/swarm-scenario/Swarm/Game/World/Render.hs | 7 +- src/swarm-tui/Swarm/TUI/Editor/Controller.hs | 5 +- src/swarm-tui/Swarm/TUI/Editor/Palette.hs | 19 ++- src/swarm-tui/Swarm/TUI/Editor/Util.hs | 5 +- swarm.cabal | 2 + test/unit/Main.hs | 2 + test/unit/TestOverlay.hs | 42 +++++ 22 files changed, 589 insertions(+), 75 deletions(-) create mode 100644 data/scenarios/Testing/1780-structure-merge-expansion/00-ORDER.txt create mode 100644 data/scenarios/Testing/1780-structure-merge-expansion/nonoverlapping-structure-merge.yaml create mode 100644 data/scenarios/Testing/1780-structure-merge-expansion/root-map-expansion.yaml create mode 100644 data/scenarios/Testing/1780-structure-merge-expansion/structure-composition.yaml create mode 100644 src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Overlay.hs create mode 100644 test/unit/TestOverlay.hs diff --git a/data/scenarios/Testing/00-ORDER.txt b/data/scenarios/Testing/00-ORDER.txt index d9488f88ac..e72c025de7 100644 --- a/data/scenarios/Testing/00-ORDER.txt +++ b/data/scenarios/Testing/00-ORDER.txt @@ -62,4 +62,5 @@ Achievements 1747-volume-command.yaml 1777-capability-cost.yaml 1775-custom-terrain.yaml -1642-biomes.yaml \ No newline at end of file +1642-biomes.yaml +1780-structure-merge-expansion \ No newline at end of file diff --git a/data/scenarios/Testing/1780-structure-merge-expansion/00-ORDER.txt b/data/scenarios/Testing/1780-structure-merge-expansion/00-ORDER.txt new file mode 100644 index 0000000000..8580fa46ef --- /dev/null +++ b/data/scenarios/Testing/1780-structure-merge-expansion/00-ORDER.txt @@ -0,0 +1,3 @@ +nonoverlapping-structure-merge.yaml +root-map-expansion.yaml +structure-composition.yaml \ No newline at end of file diff --git a/data/scenarios/Testing/1780-structure-merge-expansion/nonoverlapping-structure-merge.yaml b/data/scenarios/Testing/1780-structure-merge-expansion/nonoverlapping-structure-merge.yaml new file mode 100644 index 0000000000..3a9dac3d8b --- /dev/null +++ b/data/scenarios/Testing/1780-structure-merge-expansion/nonoverlapping-structure-merge.yaml @@ -0,0 +1,61 @@ +version: 1 +name: Expansion of a substructure to fit its placements +description: | + Define two structures and place them on the map. +robots: + - name: base + loc: [4, -4] + dir: east +known: [water, sand, tree] +world: + palette: + '.': [grass] + upperleft: [-1, 1] + structures: + - name: vertical rectangle + structure: + palette: + 'x': [blank, tree] + map: | + xx + xx + xx + xx + - name: horizontal rectangle + structure: + palette: + 'x': [blank, sand] + map: | + xxxx + xxxx + - name: disjoint rectangles + structure: + palette: + 'x': [blank, water] + map: | + xx + xx + placements: + - src: vertical rectangle + truncate: false + offset: [-7, 7] + - src: horizontal rectangle + truncate: false + offset: [7, -7] + placements: + - src: disjoint rectangles + offset: [2, -2] + map: | + ............... + ............... + ............... + ............... + ............... + ............... + ............... + ............... + ............... + ............... + ............... + ............... + ............... diff --git a/data/scenarios/Testing/1780-structure-merge-expansion/root-map-expansion.yaml b/data/scenarios/Testing/1780-structure-merge-expansion/root-map-expansion.yaml new file mode 100644 index 0000000000..ef1f8b49ab --- /dev/null +++ b/data/scenarios/Testing/1780-structure-merge-expansion/root-map-expansion.yaml @@ -0,0 +1,34 @@ +version: 1 +name: Non-overlapping merging with expansion +description: | + Define two structures and place them on the map. + + Demonstrates automatic expansion of the root map grid. +robots: + - name: base + loc: [8, 0] + dir: east +known: [tree, sand, water] +world: + palette: + '.': [grass] + 'i': [ice] + 'j': [dirt] + 'k': [stone] + 'l': [stone, sand] + 'm': [stone, water] + upperleft: [3, 3] + structures: + - name: single tree + structure: + palette: + 'x': [blank, tree] + map: | + x + placements: + - src: single tree + truncate: false + offset: [-2, -4] + map: | + i. + .j diff --git a/data/scenarios/Testing/1780-structure-merge-expansion/structure-composition.yaml b/data/scenarios/Testing/1780-structure-merge-expansion/structure-composition.yaml new file mode 100644 index 0000000000..f49cabddac --- /dev/null +++ b/data/scenarios/Testing/1780-structure-merge-expansion/structure-composition.yaml @@ -0,0 +1,111 @@ +version: 1 +name: Various structure merging arrangements +description: | + Define two structures and place them on the map. +robots: + - name: base + loc: [11, 0] + dir: east +known: [water, sand] +world: + palette: + '.': [grass] + upperleft: [-1, 1] + structures: + - name: vertical rectangle + structure: + palette: + 'x': [blank, water] + map: | + xx + xx + xx + xx + - name: horizontal rectangle + structure: + palette: + 'x': [blank, sand] + map: | + xxxx + xxxx + - name: combined rectangles blank base + structure: + palette: + 'x': [blank] + map: | + xxxx + xxxx + xxxx + xxxx + placements: + - src: vertical rectangle + - src: horizontal rectangle + - name: combined rectangles empty base + structure: + palette: + 'x': [blank] + map: "" + placements: + - src: vertical rectangle + truncate: false + - src: horizontal rectangle + truncate: false + - name: combined rectangles single cell base + structure: + palette: + 'x': [blank] + map: | + x + placements: + - src: vertical rectangle + truncate: false + - src: horizontal rectangle + truncate: false + - name: multi overlap + structure: + palette: + 'x': [blank] + map: | + xxxx + placements: + - src: vertical rectangle + offset: [1, 0] + truncate: false + - src: horizontal rectangle + truncate: false + offset: [0, -2] + - src: vertical rectangle + offset: [3, -2] + truncate: false + - src: horizontal rectangle + truncate: false + offset: [3, -4] + - src: vertical rectangle + offset: [5, -4] + truncate: false + placements: + - src: vertical rectangle + offset: [1, -1] + - src: horizontal rectangle + offset: [1, -1] + - src: multi overlap + offset: [1, -6] + truncate: false + - src: combined rectangles blank base + offset: [6, -1] + - src: combined rectangles empty base + offset: [11, -1] + - src: combined rectangles single cell base + offset: [11, -6] + map: | + ................ + ................ + ................ + ................ + ................ + ................ + ................ + ................ + ................ + ................ + ................ diff --git a/scripts/test/run-tests.sh b/scripts/test/run-tests.sh index 24e86dd58c..9d7d7d4c72 100755 --- a/scripts/test/run-tests.sh +++ b/scripts/test/run-tests.sh @@ -1,7 +1,6 @@ #!/bin/bash -ex -SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) -cd $SCRIPT_DIR/.. +cd $(git rev-parse --show-toplevel) # See https://github.com/swarm-game/swarm/issues/936 -STACK_WORK=.stack-work-test stack test --fast "$@" +cabal test -O0 -j "$@" diff --git a/src/swarm-scenario/Swarm/Game/Scenario.hs b/src/swarm-scenario/Swarm/Game/Scenario.hs index 99c55aec07..c836beb9af 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario.hs @@ -99,6 +99,7 @@ import Swarm.Game.Scenario.Topography.Navigation.Portal import Swarm.Game.Scenario.Topography.Navigation.Waypoint (Parentage (..)) import Swarm.Game.Scenario.Topography.Structure qualified as Structure import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly +import Swarm.Game.Scenario.Topography.Structure.Overlay import Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (SymmetryAnnotatedGrid (..)) import Swarm.Game.Scenario.Topography.WorldDescription @@ -336,7 +337,7 @@ instance FromJSONE ScenarioInputs Scenario where (sequenceA . (id &&& (Assembly.mergeStructures mempty Root . Structure.structure))) rootLevelSharedStructures - let namedGrids = map (\(ns, Structure.MergedStructure s _ _) -> s <$ ns) mergedStructures + let namedGrids = map (\(ns, Structure.MergedStructure (PositionedGrid _ s) _ _) -> s <$ ns) mergedStructures allWorlds <- localE (WorldParseDependencies worldMap rootLevelSharedStructures rsMap) $ do rootWorld <- v ..: "world" diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Area.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Area.hs index e1ddfa58a7..dd0fcf1167 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Area.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Area.hs @@ -16,6 +16,12 @@ newtype Grid c = Grid } deriving (Show, Eq, Functor, Foldable, Traversable) +-- | Since the derived 'Functor' instance applies to the +-- type parameter that is nested within lists, we define +-- an explicit function for mapping over the enclosing lists. +mapRows :: ([[a]] -> [[b]]) -> Grid a -> Grid b +mapRows f (Grid rows) = Grid $ f rows + instance (ToJSON a) => ToJSON (Grid a) where toJSON (Grid g) = toJSON g @@ -41,21 +47,25 @@ invertY (V2 x y) = V2 x (-y) -- | Incorporates an offset by @-1@, since the area is -- "inclusive" of the lower-right coordinate. -- Inverse of 'cornersToArea'. -upperLeftToBottomRight :: AreaDimensions -> Location -> Location -upperLeftToBottomRight (AreaDimensions w h) upperLeft = +computeBottomRightFromUpperLeft :: AreaDimensions -> Location -> Location +computeBottomRightFromUpperLeft a upperLeft = upperLeft .+^ displacement where - displacement = invertY $ subtract 1 <$> V2 w h + displacement = invertY $ computeAbsoluteCornerDisplacement a + +computeAbsoluteCornerDisplacement :: AreaDimensions -> V2 Int32 +computeAbsoluteCornerDisplacement (AreaDimensions w h) = + subtract 1 <$> V2 w h -- | Converts the displacement vector between the two -- diagonal corners of the rectangle into an 'AreaDimensions' record. -- Adds one to both dimensions since the corner coordinates are "inclusive". --- Inverse of 'upperLeftToBottomRight'. +-- Inverse of 'computeBottomRightFromUpperLeft'. cornersToArea :: Location -> Location -> AreaDimensions -cornersToArea upperLeft lowerRight = +cornersToArea upperLeft bottomRight = AreaDimensions x y where - V2 x y = (+ 1) <$> invertY (lowerRight .-. upperLeft) + V2 x y = (+ 1) <$> invertY (bottomRight .-. upperLeft) -- | Has zero width or height. isEmpty :: AreaDimensions -> Bool @@ -71,3 +81,9 @@ getAreaDimensions cellGrid = computeArea :: AreaDimensions -> Int32 computeArea (AreaDimensions w h) = w * h + +fillGrid :: AreaDimensions -> a -> Grid a +fillGrid (AreaDimensions w h) = + Grid + . replicate (fromIntegral h) + . replicate (fromIntegral w) diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs index 8c2222c78d..66d2bb1ffa 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs @@ -21,6 +21,7 @@ import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.Navigation.Waypoint import Swarm.Game.Scenario.Topography.Placement +import Swarm.Game.Scenario.Topography.Structure.Overlay import Swarm.Game.Scenario.Topography.WorldPalette import Swarm.Language.Direction (AbsoluteDir) import Swarm.Util (failT, showT) @@ -60,7 +61,7 @@ instance FromJSONE (TerrainEntityMaps, RobotMap) (NamedArea (PStructure (Maybe C ..: "structure" data PStructure c = Structure - { area :: Grid c + { area :: PositionedGrid c , structures :: [NamedStructure c] -- ^ structure definitions from parents shall be accessible by children , placements :: [Placement] @@ -84,7 +85,7 @@ instance HasLocation LocatedStructure where modifyLoc f (LocatedStructure x y originalLoc) = LocatedStructure x y $ f originalLoc -data MergedStructure c = MergedStructure (Grid c) [LocatedStructure] [Originated Waypoint] +data MergedStructure c = MergedStructure (PositionedGrid c) [LocatedStructure] [Originated Waypoint] instance FromJSONE (TerrainEntityMaps, RobotMap) (PStructure (Maybe Cell)) where parseJSONE = withObjectE "structure definition" $ \v -> do @@ -98,7 +99,7 @@ instance FromJSONE (TerrainEntityMaps, RobotMap) (PStructure (Maybe Cell)) where (maskedArea, mapWaypoints) <- (v .:? "map" .!= "") >>= paintMap maybeMaskChar pal return $ Structure - (Grid maskedArea) + (PositionedGrid origin $ Grid maskedArea) localStructureDefs placementDefs (waypointDefs <> mapWaypoints) diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Assembly.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Assembly.hs index 14c7004865..d2e09320a2 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Assembly.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Assembly.hs @@ -20,11 +20,13 @@ import Data.Map qualified as M import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T +import Linear.Affine import Swarm.Game.Location import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.Navigation.Waypoint import Swarm.Game.Scenario.Topography.Placement import Swarm.Game.Scenario.Topography.Structure +import Swarm.Game.Scenario.Topography.Structure.Overlay import Swarm.Language.Direction (directionJsonModifier) import Swarm.Util (commaList, quote, showT) @@ -38,18 +40,22 @@ overlaySingleStructure :: Either Text (MergedStructure (Maybe a)) overlaySingleStructure inheritedStrucDefs - (Placed p@(Placement _ _shouldTruncate pose@(Pose loc orientation)) ns) + (Placed p@(Placement _ shouldTruncate pose@(Pose loc orientation)) ns) (MergedStructure inputArea inputPlacements inputWaypoints) = do MergedStructure overlayArea overlayPlacements overlayWaypoints <- mergeStructures inheritedStrucDefs (WithParent p) $ structure ns let mergedWaypoints = inputWaypoints <> map (fmap $ placeOnArea overlayArea) overlayWaypoints mergedPlacements = inputPlacements <> map (placeOnArea overlayArea) overlayPlacements - mergedArea = overlayGrid inputArea pose overlayArea + mergedArea = mergeFunc (gridContent inputArea) pose overlayArea return $ MergedStructure mergedArea mergedPlacements mergedWaypoints where - placeOnArea overArea = + mergeFunc = if shouldTruncate + then overlayGridTruncated + else overlayGridExpanded + + placeOnArea (PositionedGrid _ overArea) = offsetLoc (coerce loc) . modifyLoc (reorientLandmark orientation $ getGridDimensions overArea) @@ -92,18 +98,34 @@ mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStruct -- * Grid manipulation -overlayGrid :: +overlayGridExpanded :: Grid (Maybe a) -> Pose -> + PositionedGrid (Maybe a) -> + PositionedGrid (Maybe a) +overlayGridExpanded + inputGrid + (Pose loc orientation) + (PositionedGrid _ (Grid overlayArea)) = + PositionedGrid origin inputGrid <> positionedOverlay + where + reorientedOverlayCells = Grid $ applyOrientationTransform orientation overlayArea + positionedOverlay = PositionedGrid loc reorientedOverlayCells + +-- | NOTE: This ignores the 'loc' parameter of 'PositionedGrid'. +overlayGridTruncated :: Grid (Maybe a) -> - Grid (Maybe a) -overlayGrid + Pose -> + PositionedGrid (Maybe a) -> + PositionedGrid (Maybe a) +overlayGridTruncated (Grid inputArea) (Pose (Location colOffset rowOffset) orientation) - (Grid overlayArea) = - Grid $ - zipWithPad mergeSingleRow inputArea $ - paddedOverlayRows overlayArea + (PositionedGrid _ (Grid overlayArea)) = + PositionedGrid origin + . Grid + . zipWithPad mergeSingleRow inputArea + $ paddedOverlayRows overlayArea where zipWithPad f a b = zipWith f a $ b <> repeat Nothing diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Overlay.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Overlay.hs new file mode 100644 index 0000000000..deb7bb0cd7 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Overlay.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Generic overlay operations on grids +module Swarm.Game.Scenario.Topography.Structure.Overlay ( + PositionedGrid (..), +) where + +import Control.Applicative +import Data.Function (on) +import Data.Int (Int32) +import Data.Tuple (swap) +import Linear +import Swarm.Game.Location +import Swarm.Game.Scenario.Topography.Area +import Swarm.Util (applyWhen) + +data PositionedGrid a = PositionedGrid + { gridPosition :: Location + , gridContent :: Grid a + } + deriving (Eq) + +instance Show (PositionedGrid a) where + show (PositionedGrid p g) = + unwords + [ "Grid with dimension" + , renderRectDimensions $ getGridDimensions g + , "located at" + , show p + ] + +data OverlayPair a = OverlayPair + { _base :: a + , _overlay :: a + } + +getBottomRightCorner :: PositionedGrid a -> Location +getBottomRightCorner (PositionedGrid loc g) = + computeBottomRightFromUpperLeft (getGridDimensions g) loc + +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 + +computeMergedArea :: OverlayPair (PositionedGrid a) -> AreaDimensions +computeMergedArea (OverlayPair pg1 pg2) = + cornersToArea ul br + where + ul = (getNorthwesternExtent `on` gridPosition) pg1 pg2 + br = (getSoutheasternExtent `on` getBottomRightCorner) pg1 pg2 + +zipGridRows :: + Alternative f => + AreaDimensions -> + OverlayPair (Grid (f a)) -> + Grid (f a) +zipGridRows dims (OverlayPair (Grid paddedBaseRows) (Grid paddedOverlayRows)) = + mapRows (pad2D paddedBaseRows . pad2D paddedOverlayRows) emptyGrid + where + -- Right-bias; that is, take the last non-empty value + pad2D = zipPadded $ zipPadded $ flip (<|>) + emptyGrid = fillGrid dims empty + +-- | +-- First arg: base layer +-- Second arg: overlay layer +-- +-- The upper-left corner of the base layer is the original "origin". +-- +-- If the overlay is to the west or north of the base layer, +-- then we must pad the base layer on the left or top. +-- And since the area expands relative to the "origin" of the +-- base layer, we must shift the combined grid's "origin" location +-- to the new position of the base layer's upper-left corner. +-- +-- If the overlay is to the east/south, we do not have to +-- modify the origin, since no padding is added to the left/top +-- of the base layer. +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 + combinedGrid = zipGridRows mergedSize paddedOverlayPair + + -- We subtract the base origin 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) = overlayLoc .-. baseLoc + -- 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 + + paddedOverlayPair = + padSouthwest originDelta $ + OverlayPair baseGrid overlayGrid + +-- | 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. +padSouthwest :: + Alternative f => + V2 Int32 -> + OverlayPair (Grid (f a)) -> + OverlayPair (Grid (f a)) +padSouthwest (V2 deltaX deltaY) (OverlayPair baseGrid overlayGrid) = + OverlayPair paddedBaseGrid paddedOverlayGrid + where + prefixPadRows = mapRows (padRows <>) + where + padRows = replicate (abs $ fromIntegral deltaY) [] + + prefixPadColumns = mapRows $ map (padding <>) + where + padding = replicate (abs $ fromIntegral deltaX) empty + + -- Assume only the *overlay* requires vertical (top-)padding. + -- However, if the conditional is true, then + -- the *base* needs vertical padding instead. + (baseVerticalPadFunc, overlayVerticalPadFunc) = + applyWhen (deltaY > 0) swap (id, prefixPadRows) + + -- Assume only the *overlay* requires horizontal (left-)padding. + -- However, if the conditional is true, then + -- the *base* needs horizontal padding instead. + (baseHorizontalPadFunc, overlayHorizontalPadFunc) = + applyWhen (deltaX < 0) swap (id, prefixPadColumns) + + paddedBaseGrid = baseVerticalPadFunc $ baseHorizontalPadFunc baseGrid + paddedOverlayGrid = overlayVerticalPadFunc $ overlayHorizontalPadFunc overlayGrid + +-- * Utils + +-- | Apply a function to combine elements from two lists +-- of potentially different lengths. +-- Produces a result with length equal to the longer list. +-- Elements from the longer list are placed directly in the +-- resulting list when the shorter list runs out of elements. +zipPadded :: (a -> a -> a) -> [a] -> [a] -> [a] +zipPadded _ [] ys = ys +zipPadded _ xs [] = xs +zipPadded f (x : xs) (y : ys) = f x y : zipPadded f xs ys diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs index 7de6c40bf8..9f033dda11 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs @@ -11,7 +11,6 @@ import Control.Carrier.Throw.Either import Control.Monad (forM) import Data.Coerce import Data.Functor.Identity -import Data.Maybe (catMaybes) import Data.Text qualified as T import Data.Yaml as Y import Swarm.Game.Entity @@ -34,6 +33,7 @@ import Swarm.Game.Scenario.Topography.Structure ( ) import Swarm.Game.Scenario.Topography.Structure qualified as Structure import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly +import Swarm.Game.Scenario.Topography.Structure.Overlay import Swarm.Game.Scenario.Topography.WorldPalette import Swarm.Game.Universe import Swarm.Game.World.Parse () @@ -54,7 +54,7 @@ data PWorldDescription e = WorldDescription , scrollable :: Bool , palette :: WorldPalette e , ul :: Location - , area :: [[PCell e]] + , area :: PositionedGrid (Maybe (PCell e)) , navigation :: Navigation Identity WaypointName , placedStructures :: [LocatedStructure] , worldName :: SubworldName @@ -91,7 +91,7 @@ instance FromJSONE WorldParseDependencies WorldDescription where let initialStructureDefs = scenarioLevelStructureDefs <> rootWorldStructureDefs struc = Structure - (Grid initialArea) + (PositionedGrid origin $ Grid initialArea) initialStructureDefs placementDefs (waypointDefs <> mapWaypoints) @@ -121,7 +121,7 @@ instance FromJSONE WorldParseDependencies WorldDescription where <*> liftE (v .:? "scrollable" .!= True) <*> pure pal <*> pure upperLeft - <*> pure (map catMaybes $ unGrid mergedArea) -- Root-level map has no transparent cells. + <*> pure mergedArea <*> pure validatedNavigation <*> pure absoluteStructurePlacements <*> pure subWorldName @@ -144,6 +144,6 @@ instance ToJSON WorldDescriptionPaint where , "map" .= Y.toJSON mapText ] where - cellGrid = area w - suggestedPalette = palette w + cellGrid = gridContent $ area w + suggestedPalette = PaletteAndMaskChar (palette w) Nothing (mapText, paletteKeymap) = prepForJson suggestedPalette cellGrid diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs index a0373b4302..704a445b82 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs @@ -9,6 +9,7 @@ import Control.Lens hiding (from, (.=), (<.>)) import Data.Aeson.KeyMap (KeyMap) import Data.Aeson.KeyMap qualified as KM import Data.Map qualified as M +import Data.Maybe (catMaybes) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T @@ -16,6 +17,7 @@ import Data.Tuple (swap) import Swarm.Game.Entity import Swarm.Game.Land import Swarm.Game.Scenario.RobotLookup +import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Terrain (TerrainType) @@ -28,7 +30,9 @@ newtype WorldPalette e = WorldPalette deriving (Eq, Show) instance FromJSONE (TerrainEntityMaps, RobotMap) (WorldPalette Entity) where - parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE + parseJSONE = + withObjectE "palette" $ + fmap WorldPalette . mapM parseJSONE type TerrainWith a = (TerrainType, Erasable a) @@ -70,19 +74,23 @@ constructPalette mappedPairs = constructWorldMap :: [(Char, TerrainWith EntityFacade)] -> - [[CellPaintDisplay]] -> + -- | Mask char + Char -> + Grid (Maybe CellPaintDisplay) -> Text -constructWorldMap mappedPairs = - T.unlines . map (T.pack . map renderMapCell) +constructWorldMap mappedPairs maskChar = + T.unlines . map (T.pack . map renderMapCell) . unGrid where invertedMappedPairs = map (swap . fmap toKey) mappedPairs - renderMapCell c = - -- NOTE: This lookup should never fail - M.findWithDefault (error "Palette lookup failed!") k $ - M.fromList invertedMappedPairs - where - k = toKey $ cellToTerrainPair c + renderMapCell maybeC = case maybeC of + Nothing -> maskChar + Just c -> + -- NOTE: This lookup should never fail + M.findWithDefault (error "Palette lookup failed!") k $ + M.fromList invertedMappedPairs + where + k = toKey $ cellToTerrainPair c -- | All alphanumeric characters. These are used as supplemental -- map placeholders in case a pre-existing display character is @@ -90,15 +98,21 @@ constructWorldMap mappedPairs = genericCharacterPool :: Set.Set Char genericCharacterPool = Set.fromList $ ['A' .. 'Z'] <> ['a' .. 'z'] <> ['0' .. '9'] +data PaletteAndMaskChar = PaletteAndMaskChar + { paletteEntries :: WorldPalette EntityFacade + , reservedMaskChar :: Maybe Char + -- ^ represents a transparent cell + } + -- | Note that display characters are not unique -- across different entities! However, the palette KeyMap -- as a conveyance serves to dedupe them. prepForJson :: - WorldPalette EntityFacade -> - [[CellPaintDisplay]] -> + PaletteAndMaskChar -> + Grid (Maybe CellPaintDisplay) -> (Text, KM.KeyMap CellPaintDisplay) -prepForJson (WorldPalette suggestedPalette) cellGrid = - (constructWorldMap mappedPairs cellGrid, constructPalette mappedPairs) +prepForJson (PaletteAndMaskChar (WorldPalette suggestedPalette) maybeMaskChar) cellGrid = + (constructWorldMap mappedPairs maskCharacter cellGrid, constructPalette mappedPairs) where preassignments :: [(Char, TerrainWith EntityFacade)] preassignments = @@ -107,7 +121,7 @@ prepForJson (WorldPalette suggestedPalette) cellGrid = KM.toMapText suggestedPalette entityCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade) - entityCells = getUniqueTerrainFacadePairs cellGrid + entityCells = getUniqueTerrainFacadePairs $ map catMaybes $ unGrid cellGrid unassignedCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade) unassignedCells = @@ -115,11 +129,17 @@ prepForJson (WorldPalette suggestedPalette) cellGrid = Set.fromList $ map (toKey . snd) preassignments + (maskCharacter, availableCharacterPool) = case maybeMaskChar of + Just c -> (c, genericCharacterPool) + Nothing -> Set.deleteFindMin genericCharacterPool + unassignedCharacters :: Set.Set Char unassignedCharacters = -- TODO (#1149): How can we efficiently use the Unicode categories (in "Data.Char") -- to generate this pool? - Set.difference genericCharacterPool $ + Set.difference availableCharacterPool usedCharacters + where + usedCharacters = Set.fromList $ map fst preassignments diff --git a/src/swarm-scenario/Swarm/Game/State/Landscape.hs b/src/swarm-scenario/Swarm/Game/State/Landscape.hs index 5db9aa3bba..7d41547faf 100644 --- a/src/swarm-scenario/Swarm/Game/State/Landscape.hs +++ b/src/swarm-scenario/Swarm/Game/State/Landscape.hs @@ -24,7 +24,7 @@ module Swarm.Game.State.Landscape ( ) where import Control.Arrow (Arrow ((&&&))) -import Control.Lens hiding (Const, use, uses, (%=), (+=), (.=), (<+=), (<<.=)) +import Control.Lens hiding (Const, both, use, uses, (%=), (+=), (.=), (<+=), (<<.=)) import Data.Array (Array, listArray) import Data.Bifunctor (first) import Data.Int (Int32) @@ -32,17 +32,21 @@ import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Map qualified as M -import Data.Maybe (isJust, listToMaybe) +import Data.Maybe (isJust) +import Data.Tuple.Extra (both, swap) import Swarm.Game.Entity import Swarm.Game.Land import Swarm.Game.Location import Swarm.Game.Robot (TRobot, trobotLocation) import Swarm.Game.Scenario +import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) +import Swarm.Game.Scenario.Topography.Structure.Overlay import Swarm.Game.State.Config import Swarm.Game.Terrain (TerrainType (..), terrainIndexByName) import Swarm.Game.Universe as U import Swarm.Game.World +import Swarm.Game.World.Coords (addTuple) import Swarm.Game.World.Eval (runWorld) import Swarm.Game.World.Gen (Seed, findGoodOrigin) import Swarm.Util (applyWhen) @@ -115,37 +119,59 @@ genMultiWorld worldTuples s = -- | Take a world description, parsed from a scenario file, and turn -- it into a list of located robots and a world function. -buildWorld :: TerrainEntityMaps -> WorldDescription -> ([IndexedTRobot], Seed -> WorldFun Int Entity) +buildWorld :: + TerrainEntityMaps -> + WorldDescription -> + ([IndexedTRobot], Seed -> WorldFun Int Entity) buildWorld tem WorldDescription {..} = (robots worldName, first getTerrainIndex . wf) where - getTerrainIndex t = M.findWithDefault 0 t $ terrainIndexByName $ tem ^. terrainMap - rs = fromIntegral $ length area - cs = fromIntegral $ maybe 0 length $ listToMaybe area - Coords (ulr, ulc) = locToCoords ul + getTerrainIndex t = + M.findWithDefault 0 t $ + terrainIndexByName $ + tem ^. terrainMap - worldGrid :: [[(TerrainType, Erasable Entity)]] - worldGrid = (map . map) (cellTerrain &&& cellEntity) area + g = gridContent area + + ulOffset = origin .-. gridPosition area + ulModified = ul .+^ ulOffset + + worldGrid :: Grid (TerrainType, Erasable Entity) + worldGrid = maybe (BlankT, ENothing) (cellTerrain &&& cellEntity) <$> g + + offsetCoordsByArea :: Coords -> AreaDimensions -> Coords + offsetCoordsByArea x a = + x `addTuple` swap (asTuple a) + + coords = locToCoords ulModified + + arrayMaxBound = + both (subtract 1) + . unCoords + . offsetCoordsByArea coords + $ getGridDimensions g + + arrayBoundsTuple = (unCoords coords, arrayMaxBound) worldArray :: Array (Int32, Int32) (TerrainType, Erasable Entity) - worldArray = listArray ((ulr, ulc), (ulr + rs - 1, ulc + cs - 1)) (concat worldGrid) + worldArray = listArray arrayBoundsTuple $ concat $ unGrid worldGrid dslWF, arrayWF :: Seed -> WorldFun TerrainType Entity dslWF = maybe mempty ((applyWhen offsetOrigin findGoodOrigin .) . runWorld) worldProg - arrayWF = const (worldFunFromArray worldArray) + arrayWF = const $ worldFunFromArray worldArray wf = dslWF <> arrayWF -- Get all the robots described in cells and set their locations appropriately robots :: SubworldName -> [IndexedTRobot] robots swName = - area + unGrid g & traversed Control.Lens.<.> traversed %@~ (,) -- add (r,c) indices & concat & concatMap - ( \((fromIntegral -> r, fromIntegral -> c), Cell _ _ robotList) -> - let robotWithLoc = trobotLocation ?~ Cosmic swName (coordsToLoc (Coords (ulr + r, ulc + c))) - in map (fmap robotWithLoc) robotList + ( \((fromIntegral -> r, fromIntegral -> c), maybeCell) -> + let robotWithLoc = trobotLocation ?~ Cosmic swName (coordsToLoc (coords `addTuple` (r, c))) + in map (fmap robotWithLoc) (maybe [] cellRobots maybeCell) ) -- | diff --git a/src/swarm-scenario/Swarm/Game/World/Coords.hs b/src/swarm-scenario/Swarm/Game/World/Coords.hs index c373c0ab2f..6fb6d0b55e 100644 --- a/src/swarm-scenario/Swarm/Game/World/Coords.hs +++ b/src/swarm-scenario/Swarm/Game/World/Coords.hs @@ -8,6 +8,7 @@ module Swarm.Game.World.Coords ( Coords (..), locToCoords, coordsToLoc, + addTuple, BoundsRectangle, ) where @@ -43,6 +44,9 @@ locToCoords (Location x y) = Coords (-y, x) coordsToLoc :: Coords -> Location coordsToLoc (Coords (r, c)) = Location c (-r) +addTuple :: Coords -> (Int32, Int32) -> Coords +addTuple (Coords (r, c)) (addR, addC) = Coords (r + addR, c + addC) + -- | Represents the top-left and bottom-right coordinates -- of a bounding rectangle of cells in the world map type BoundsRectangle = (Coords, Coords) diff --git a/src/swarm-scenario/Swarm/Game/World/Render.hs b/src/swarm-scenario/Swarm/Game/World/Render.hs index eb67b03cec..da3aa0bd26 100644 --- a/src/swarm-scenario/Swarm/Game/World/Render.hs +++ b/src/swarm-scenario/Swarm/Game/World/Render.hs @@ -27,6 +27,7 @@ import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.Center import Swarm.Game.Scenario.Topography.EntityFacade (EntityFacade (..), mkFacade) +import Swarm.Game.Scenario.Topography.Structure.Overlay import Swarm.Game.State.Landscape import Swarm.Game.Universe import Swarm.Game.World qualified as W @@ -111,11 +112,11 @@ getBoundingBox vc scenarioWorld maybeSize = mkBoundingBox areaDimens upperLeftLoc = both W.locToCoords locationBounds where - lowerRightLocation = upperLeftToBottomRight areaDimens upperLeftLoc + lowerRightLocation = computeBottomRightFromUpperLeft areaDimens upperLeftLoc locationBounds = (upperLeftLoc, lowerRightLocation) - worldArea = area scenarioWorld - mapAreaDims = getAreaDimensions worldArea + worldArea = gridContent $ area scenarioWorld + mapAreaDims = getGridDimensions worldArea areaDims@(AreaDimensions w h) = fromMaybe (AreaDimensions 20 10) $ maybeSize <|> surfaceEmpty isEmpty mapAreaDims diff --git a/src/swarm-tui/Swarm/TUI/Editor/Controller.hs b/src/swarm-tui/Swarm/TUI/Editor/Controller.hs index 19d20c9e88..4d544b0c21 100644 --- a/src/swarm-tui/Swarm/TUI/Editor/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Editor/Controller.hs @@ -17,6 +17,7 @@ import Data.Map qualified as M import Data.Yaml qualified as Y import Graphics.Vty qualified as V import Swarm.Game.Land +import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.State import Swarm.Game.State.Landscape @@ -146,7 +147,9 @@ saveMapFile = do maybeBounds <- use $ uiState . uiGameplay . uiWorldEditor . editingBounds . boundsRect w <- use $ gameState . landscape . multiWorld tm <- use $ gameState . landscape . terrainAndEntities . terrainMap - let mapCellGrid = EU.getEditedMapRectangle tm (worldEditor ^. worldOverdraw) maybeBounds w + let mapCellGrid = + mapRows (map (map Just)) $ + EU.getEditedMapRectangle tm (worldEditor ^. worldOverdraw) maybeBounds w let fp = worldEditor ^. outputFilePath maybeScenarioPair <- use $ uiState . uiGameplay . scenarioRef diff --git a/src/swarm-tui/Swarm/TUI/Editor/Palette.hs b/src/swarm-tui/Swarm/TUI/Editor/Palette.hs index c8d3c92187..194aec860e 100644 --- a/src/swarm-tui/Swarm/TUI/Editor/Palette.hs +++ b/src/swarm-tui/Swarm/TUI/Editor/Palette.hs @@ -12,7 +12,7 @@ import Data.List (sortOn) import Data.List.NonEmpty qualified as NE import Data.Map (Map) import Data.Map qualified as M -import Data.Maybe (mapMaybe) +import Data.Maybe (catMaybes, mapMaybe) import Data.Ord (Down (..)) import Data.Set (Set) import Data.Set qualified as Set @@ -27,6 +27,7 @@ import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.EntityFacade import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) +import Swarm.Game.Scenario.Topography.Structure.Overlay import Swarm.Game.Scenario.Topography.WorldPalette import Swarm.Game.Terrain (TerrainMap, TerrainType, getTerrainDefaultPaletteChar, terrainByName) import Swarm.Game.Universe @@ -38,7 +39,7 @@ import Swarm.Util.Erasable makeSuggestedPalette :: TerrainMap -> KM.KeyMap (AugmentedCell Entity) -> - [[CellPaintDisplay]] -> + Grid (Maybe CellPaintDisplay) -> KM.KeyMap (AugmentedCell EntityFacade) makeSuggestedPalette tm originalScenarioPalette cellGrid = KM.fromMapText @@ -48,6 +49,8 @@ makeSuggestedPalette tm originalScenarioPalette cellGrid = -- NOTE: the left-most maps take precedence! $ paletteCellsByKey <> pairsWithDisplays <> terrainOnlyPalette where + cellList = concatMap catMaybes $ unGrid cellGrid + getMaybeEntityDisplay :: PCell EntityFacade -> Maybe (EntityName, Display) getMaybeEntityDisplay (Cell _terrain (erasableToMaybe -> maybeEntity) _) = do EntityFacade eName d <- maybeEntity @@ -60,11 +63,11 @@ makeSuggestedPalette tm originalScenarioPalette cellGrid = getEntityTerrainMultiplicity :: Map EntityName (Map TerrainType Int) getEntityTerrainMultiplicity = - M.map histogram $ binTuples $ concatMap (mapMaybe getMaybeEntityNameTerrainPair) cellGrid + M.map histogram $ binTuples $ mapMaybe getMaybeEntityNameTerrainPair cellList usedEntityDisplays :: Map EntityName Display usedEntityDisplays = - M.fromList $ concatMap (mapMaybe getMaybeEntityDisplay) cellGrid + M.fromList $ mapMaybe getMaybeEntityDisplay cellList -- Finds the most-used terrain type (the "mode" in the statistical sense) -- paired with each entity @@ -115,8 +118,8 @@ makeSuggestedPalette tm originalScenarioPalette cellGrid = f x = ((x, ENothing), (T.singleton $ getTerrainDefaultPaletteChar x, Cell x ENothing [])) -- | Generate a \"skeleton\" scenario with placeholders for certain required fields -constructScenario :: Maybe Scenario -> Grid CellPaintDisplay -> SkeletonScenario -constructScenario maybeOriginalScenario (Grid cellGrid) = +constructScenario :: Maybe Scenario -> Grid (Maybe CellPaintDisplay) -> SkeletonScenario +constructScenario maybeOriginalScenario cellGrid = SkeletonScenario (maybe 1 (^. scenarioMetadata . scenarioVersion) maybeOriginalScenario) (maybe "My Scenario" (^. scenarioMetadata . scenarioName) maybeOriginalScenario) @@ -135,7 +138,7 @@ constructScenario maybeOriginalScenario (Grid cellGrid) = , scrollable = True , palette = WorldPalette suggestedPalette , ul = upperLeftCoord - , area = cellGrid + , area = PositionedGrid upperLeftCoord cellGrid , navigation = Navigation mempty mempty , placedStructures = mempty , worldName = DefaultRootSubworld @@ -151,4 +154,4 @@ constructScenario maybeOriginalScenario (Grid cellGrid) = (negate $ w `div` 2) (h `div` 2) where - AreaDimensions w h = getAreaDimensions cellGrid + AreaDimensions w h = getGridDimensions cellGrid diff --git a/src/swarm-tui/Swarm/TUI/Editor/Util.hs b/src/swarm-tui/Swarm/TUI/Editor/Util.hs index 9b2b2c45c5..76c71037a0 100644 --- a/src/swarm-tui/Swarm/TUI/Editor/Util.hs +++ b/src/swarm-tui/Swarm/TUI/Editor/Util.hs @@ -13,6 +13,7 @@ import Swarm.Game.Entity import Swarm.Game.Scenario.Topography.Area qualified as EA import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.EntityFacade +import Swarm.Game.Scenario.Topography.Structure.Overlay import Swarm.Game.Scenario.Topography.WorldDescription import Swarm.Game.Terrain (TerrainMap, TerrainType) import Swarm.Game.Universe @@ -33,8 +34,8 @@ getEditingBounds myWorld = where newBounds = Cosmic DefaultRootSubworld (W.locToCoords upperLeftLoc, W.locToCoords lowerRightLoc) upperLeftLoc = ul myWorld - a = EA.getAreaDimensions $ area myWorld - lowerRightLoc = EA.upperLeftToBottomRight a upperLeftLoc + a = EA.getGridDimensions $ gridContent $ area myWorld + lowerRightLoc = EA.computeBottomRightFromUpperLeft a upperLeftLoc getEditorContentAt :: TerrainMap -> diff --git a/swarm.cabal b/swarm.cabal index f72eacb466..edad864b20 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -222,6 +222,7 @@ library swarm-scenario Swarm.Game.Scenario.Topography.Placement Swarm.Game.Scenario.Topography.Structure Swarm.Game.Scenario.Topography.Structure.Assembly + Swarm.Game.Scenario.Topography.Structure.Overlay Swarm.Game.Scenario.Topography.Structure.Recognition Swarm.Game.Scenario.Topography.Structure.Recognition.Log Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute @@ -782,6 +783,7 @@ test-suite swarm-unit TestLanguagePipeline TestNotification TestOrdering + TestOverlay TestParse TestPedagogy TestPretty diff --git a/test/unit/Main.hs b/test/unit/Main.hs index 53f19ee2a9..f331190421 100644 --- a/test/unit/Main.hs +++ b/test/unit/Main.hs @@ -36,6 +36,7 @@ import TestLSP (testLSP) import TestLanguagePipeline (testLanguagePipeline) import TestNotification (testNotification) import TestOrdering (testOrdering) +import TestOverlay (testOverlay) import TestParse (testParse) import TestPedagogy (testPedagogy) import TestPretty (testPrettyConst) @@ -68,6 +69,7 @@ tests s = , testInventory , testNotification (s ^. gameState) , testOrdering + , testOverlay , testMisc , testLSP ] diff --git a/test/unit/TestOverlay.hs b/test/unit/TestOverlay.hs new file mode 100644 index 0000000000..ee3f14151b --- /dev/null +++ b/test/unit/TestOverlay.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Unit tests for generic grid overlay logic +module TestOverlay where + +import Swarm.Game.Location +import Swarm.Game.Scenario.Topography.Area +import Swarm.Game.Scenario.Topography.Structure.Overlay +import Test.Tasty +import Test.Tasty.HUnit + +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) + ] + +mkOriginTestCase :: + String -> + Location -> + Location -> + TestTree +mkOriginTestCase adjustmentDescription overlayLocation expectedBaseLoc = + testCase (unwords [adjustmentDescription, "origin adjustment"]) $ do + assertEqual "Base loc wrong" expectedBaseLoc actualBaseLoc + where + baseLayer = PositionedGrid (Location 0 0) $ Grid [[] :: [Maybe Int]] + overlayLayer = PositionedGrid overlayLocation $ Grid [[]] + PositionedGrid actualBaseLoc _ = baseLayer <> overlayLayer From 718fddcd69261c54c8f25515b9880e43f9401b85 Mon Sep 17 00:00:00 2001 From: "Restyled.io" Date: Sun, 12 May 2024 03:32:38 +0000 Subject: [PATCH 2/2] Restyled by fourmolu --- .../Swarm/Game/Scenario/Topography/Structure/Assembly.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Assembly.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Assembly.hs index d2e09320a2..fd19c70263 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Assembly.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Assembly.hs @@ -51,9 +51,10 @@ overlaySingleStructure return $ MergedStructure mergedArea mergedPlacements mergedWaypoints where - mergeFunc = if shouldTruncate - then overlayGridTruncated - else overlayGridExpanded + mergeFunc = + if shouldTruncate + then overlayGridTruncated + else overlayGridExpanded placeOnArea (PositionedGrid _ overArea) = offsetLoc (coerce loc)