mirror of
https://github.com/swarm-game/swarm.git
synced 2024-09-11 22:58:21 +03:00
structure grid expansion (#1826)
Closes #1780. This change allows "child" structures to be placed outside of the bounds of their "parent" map. Until now, any child structures that exceed the bounds of their parent were simply truncated. # Demo ``` scripts/play.sh -i data/scenarios/Testing/1780-structure-merge-expansion/structure-composition.yaml ```
This commit is contained in:
parent
b617501218
commit
d9b639a427
@ -62,4 +62,5 @@ Achievements
|
||||
1747-volume-command.yaml
|
||||
1777-capability-cost.yaml
|
||||
1775-custom-terrain.yaml
|
||||
1642-biomes.yaml
|
||||
1642-biomes.yaml
|
||||
1780-structure-merge-expansion
|
@ -0,0 +1,3 @@
|
||||
nonoverlapping-structure-merge.yaml
|
||||
root-map-expansion.yaml
|
||||
structure-composition.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: |
|
||||
...............
|
||||
...............
|
||||
...............
|
||||
...............
|
||||
...............
|
||||
...............
|
||||
...............
|
||||
...............
|
||||
...............
|
||||
...............
|
||||
...............
|
||||
...............
|
||||
...............
|
@ -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
|
@ -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: |
|
||||
................
|
||||
................
|
||||
................
|
||||
................
|
||||
................
|
||||
................
|
||||
................
|
||||
................
|
||||
................
|
||||
................
|
||||
................
|
@ -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"
|
||||
|
@ -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)
|
||||
|
@ -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.Syntax.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)
|
||||
|
@ -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.Syntax.Direction (directionJsonModifier)
|
||||
import Swarm.Util (commaList, quote, showT)
|
||||
|
||||
@ -38,18 +40,23 @@ 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 +99,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
|
||||
|
||||
|
@ -0,0 +1,163 @@
|
||||
{-# 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
|
||||
}
|
||||
|
||||
-- | Has a 'Semigroup' instance to determine the smallest
|
||||
-- bounds that enclose two rectangles
|
||||
data SubsumingRect = SubsumingRect
|
||||
{ _northwestCorner :: Location
|
||||
, _southeastCorner :: Location
|
||||
}
|
||||
|
||||
-- | @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
|
||||
|
||||
getSubsumingRect :: PositionedGrid a -> SubsumingRect
|
||||
getSubsumingRect (PositionedGrid loc g) =
|
||||
SubsumingRect loc $ computeBottomRightFromUpperLeft (getGridDimensions g) loc
|
||||
|
||||
computeMergedArea :: OverlayPair (PositionedGrid a) -> AreaDimensions
|
||||
computeMergedArea (OverlayPair pg1 pg2) =
|
||||
cornersToArea ul br
|
||||
where
|
||||
SubsumingRect ul br = ((<>) `on` getSubsumingRect) 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
|
||||
prefixPadDimension delta f = mapRows $ f (padding <>)
|
||||
where
|
||||
padding = replicate (abs $ fromIntegral delta) empty
|
||||
|
||||
prefixPadRows = prefixPadDimension deltaY id
|
||||
prefixPadColumns = prefixPadDimension deltaX map
|
||||
|
||||
-- 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
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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)
|
||||
)
|
||||
|
||||
-- |
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 ->
|
||||
|
@ -236,6 +236,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
|
||||
@ -799,6 +800,7 @@ test-suite swarm-unit
|
||||
TestLanguagePipeline
|
||||
TestNotification
|
||||
TestOrdering
|
||||
TestOverlay
|
||||
TestParse
|
||||
TestPedagogy
|
||||
TestPretty
|
||||
|
@ -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
|
||||
]
|
||||
|
42
test/unit/TestOverlay.hs
Normal file
42
test/unit/TestOverlay.hs
Normal file
@ -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
|
Loading…
Reference in New Issue
Block a user