From b96c3fab80391c83382f78ff7b3efe87a40843fc Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sun, 17 Nov 2024 14:50:14 -0800 Subject: [PATCH] initial placement ensure non-overlapping recognition --- .../1575-structure-recognizer/00-ORDER.txt | 1 + .../2201-initial-recognition-overlap.yaml | 52 ++++++++++++++++ .../Swarm/Game/State/Initialize.hs | 2 +- src/swarm-engine/Swarm/Game/Step/Const.hs | 4 +- .../Swarm/Game/State/Landscape.hs | 2 +- .../Swarm/Game/Scenario/Topography/Area.hs | 11 ++++ .../Swarm/Game/Scenario/Topography/Grid.hs | 48 +++++++++------ .../Game/Scenario/Topography/Placement.hs | 13 +++- .../Game/Scenario/Topography/Structure.hs | 4 +- .../Topography/Structure/Recognition/Log.hs | 2 +- .../Structure/Recognition/Precompute.hs | 52 ++++++++++------ .../Topography/Structure/Recognition/Prep.hs | 16 +++-- .../Structure/Recognition/Registry.hs | 60 ++++++++++++++++--- .../Structure/Recognition/Tracking.hs | 6 +- .../Topography/Structure/Recognition/Type.hs | 50 ++++++++++------ test/integration/Main.hs | 1 + 16 files changed, 243 insertions(+), 81 deletions(-) create mode 100644 data/scenarios/Testing/1575-structure-recognizer/2201-initial-recognition-overlap.yaml diff --git a/data/scenarios/Testing/1575-structure-recognizer/00-ORDER.txt b/data/scenarios/Testing/1575-structure-recognizer/00-ORDER.txt index 2993b8268..4c442db6e 100644 --- a/data/scenarios/Testing/1575-structure-recognizer/00-ORDER.txt +++ b/data/scenarios/Testing/1575-structure-recognizer/00-ORDER.txt @@ -18,3 +18,4 @@ 2115-encroaching-upon-interior-transparent-cells.yaml 2201-piecewise-lines.yaml 2201-preclude-overlapping-recognition.yaml +2201-initial-recognition-overlap.yaml diff --git a/data/scenarios/Testing/1575-structure-recognizer/2201-initial-recognition-overlap.yaml b/data/scenarios/Testing/1575-structure-recognizer/2201-initial-recognition-overlap.yaml new file mode 100644 index 000000000..940733f90 --- /dev/null +++ b/data/scenarios/Testing/1575-structure-recognizer/2201-initial-recognition-overlap.yaml @@ -0,0 +1,52 @@ +version: 1 +name: Structure recognition - precluding overlaps +description: | + A cell may be a member of at most one structure. +creative: false +objectives: + - teaser: Recognize exactly one structure + goal: + - | + `square`{=structure} structure should be recognized upon scenario start. + - | + Although two of these structures were initially placed, only one should be recognized. + condition: | + foundStructure <- structure "square" 0; + return $ case foundStructure (\_. false) (\pair. fst pair == 1); +robots: + - name: base + dir: north + devices: + - ADT calculator + - blueprint + - fast grabber + - logger + - treads +solution: | + noop; +structures: + - name: square + recognize: [north] + structure: + palette: + 'x': [stone, rock] + mask: '.' + map: | + xx + xx +known: [rock] +world: + dsl: | + {blank} + palette: + '.': [grass, erase] + 'B': [grass, erase, base] + 's': + structure: + name: square + cell: [grass] + upperleft: [0, 0] + map: | + ...s... + ....s.. + .B..... diff --git a/src/swarm-engine/Swarm/Game/State/Initialize.hs b/src/swarm-engine/Swarm/Game/State/Initialize.hs index 9df64270e..afa1f195e 100644 --- a/src/swarm-engine/Swarm/Game/State/Initialize.hs +++ b/src/swarm-engine/Swarm/Game/State/Initialize.hs @@ -200,7 +200,7 @@ mkRecognizer structInfo@(StaticStructureInfo structDefs _) = do mkLogEntry (x, intact) = IntactPlacementLog intact - ((getName . originalDefinition . structureWithGrid) x) + ((distillLabel . structureWithGrid) x) (upperLeftCorner x) buildTagMap :: EntityMap -> Map Text (NonEmpty EntityName) diff --git a/src/swarm-engine/Swarm/Game/Step/Const.hs b/src/swarm-engine/Swarm/Game/Step/Const.hs index 3d76b870c..2f628a92c 100644 --- a/src/swarm-engine/Swarm/Game/Step/Const.hs +++ b/src/swarm-engine/Swarm/Game/Step/Const.hs @@ -59,7 +59,7 @@ import Swarm.Game.Robot import Swarm.Game.Robot.Activity import Swarm.Game.Robot.Concrete import Swarm.Game.Robot.Walk (emptyExceptions) -import Swarm.Game.Scenario.Topography.Area (getAreaDimensions) +import Swarm.Game.Scenario.Topography.Area (getAreaDimensions, getNEGridDimensions, rectHeight) import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) import Swarm.Game.Scenario.Topography.Navigation.Util import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointName (..)) @@ -555,7 +555,7 @@ execConst runChildProg c vs s k = do xs = NEM.toList mapNE (pos, struc) = indexWrapNonEmpty xs idx topLeftCorner = pos ^. planar - offsetHeight = V2 0 $ -fromIntegral (length (entityGrid struc) - 1) + offsetHeight = V2 0 $ negate (rectHeight (getNEGridDimensions $ entityGrid struc) - 1) bottomLeftCorner :: Location bottomLeftCorner = topLeftCorner .+^ offsetHeight return $ mkReturn $ mkOutput <$> maybeFoundStructures diff --git a/src/swarm-scenario/Swarm/Game/State/Landscape.hs b/src/swarm-scenario/Swarm/Game/State/Landscape.hs index 3ab7dad22..bb1b46e77 100644 --- a/src/swarm-scenario/Swarm/Game/State/Landscape.hs +++ b/src/swarm-scenario/Swarm/Game/State/Landscape.hs @@ -166,7 +166,7 @@ buildWorld tem WorldDescription {..} = -- Get all the robots described in cells and set their locations appropriately robots :: SubworldName -> [IndexedTRobot] robots swName = - concat $ mapIndexedMembers extractRobots g + concat $ mapWithCoords extractRobots g where extractRobots (Coords coordsTuple) maybeCell = let robotWithLoc = trobotLocation ?~ Cosmic swName (coordsToLoc (coords `addTuple` coordsTuple)) diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs index d6cd81ee5..c72cc5b2a 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs @@ -4,8 +4,10 @@ -- SPDX-License-Identifier: BSD-3-Clause module Swarm.Game.Scenario.Topography.Area where +import Data.Function (on) import Data.Int (Int32) import Data.List qualified as L +import Data.List.NonEmpty qualified as NE import Data.Maybe (listToMaybe) import Data.Semigroup import Linear (V2 (..)) @@ -23,6 +25,14 @@ data AreaDimensions = AreaDimensions getGridDimensions :: Grid a -> AreaDimensions getGridDimensions g = getAreaDimensions $ getRows g +getNEGridDimensions :: NonEmptyGrid a -> AreaDimensions +getNEGridDimensions (NonEmptyGrid xs) = + (AreaDimensions `on` fromIntegral) + (NE.length firstRow) + (NE.length xs) + where + firstRow = NE.head xs + asTuple :: AreaDimensions -> (Int32, Int32) asTuple (AreaDimensions x y) = (x, y) @@ -76,6 +86,7 @@ fillGrid (AreaDimensions 0 _) _ = EmptyGrid fillGrid (AreaDimensions _ 0) _ = EmptyGrid fillGrid (AreaDimensions w h) x = Grid + . NonEmptyGrid . stimes h . pure . stimes w diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Grid.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Grid.hs index 96dbd1131..5ecda00c8 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Grid.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Grid.hs @@ -2,63 +2,77 @@ -- SPDX-License-Identifier: BSD-3-Clause module Swarm.Game.Scenario.Topography.Grid ( Grid (..), + NonEmptyGrid (..), gridToVec, - mapIndexedMembers, + nonemptyCount, + mapWithCoordsNE, + mapWithCoords, allMembers, - mapRows, + mapRowsNE, getRows, mkGrid, ) where import Data.Aeson (ToJSON (..)) +import Data.Foldable qualified as F import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe) import Data.Semigroup import Data.Vector qualified as V +import GHC.Generics (Generic) import Swarm.Game.World.Coords import Prelude hiding (zipWith) +newtype NonEmptyGrid c = NonEmptyGrid (NonEmpty (NonEmpty c)) + deriving (Generic, Show, Eq, Functor, Foldable, Traversable, ToJSON) + data Grid c = EmptyGrid - | Grid (NonEmpty (NonEmpty c)) + | Grid (NonEmptyGrid c) deriving (Show, Eq, Functor, Foldable, Traversable) mkGrid :: [[a]] -> Grid a mkGrid rows = fromMaybe EmptyGrid $ do rowsNE <- NE.nonEmpty =<< mapM NE.nonEmpty rows - return $ Grid rowsNE + return $ Grid $ NonEmptyGrid rowsNE getRows :: Grid a -> [[a]] getRows EmptyGrid = [] -getRows (Grid g) = NE.toList . NE.map NE.toList $ g +getRows (Grid (NonEmptyGrid g)) = NE.toList . NE.map NE.toList $ g -- | 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 :: (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty b)) -> Grid a -> Grid b -mapRows _ EmptyGrid = EmptyGrid -mapRows f (Grid rows) = Grid $ f rows +mapRowsNE :: + (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty b)) -> + NonEmptyGrid a -> + NonEmptyGrid b +mapRowsNE f (NonEmptyGrid rows) = NonEmptyGrid $ f rows allMembers :: Grid a -> [a] allMembers EmptyGrid = [] -allMembers g = concat . getRows $ g +allMembers g = F.toList g + +nonemptyCount :: (Integral i) => NonEmpty i +nonemptyCount = NE.iterate succ 0 -mapIndexedMembers :: (Coords -> a -> b) -> Grid a -> [b] -mapIndexedMembers _ EmptyGrid = [] -mapIndexedMembers f (Grid g) = - NE.toList $ - sconcat $ - NE.zipWith (\i -> NE.zipWith (\j -> f (Coords (i, j))) nonemptyCount) nonemptyCount g +mapWithCoordsNE :: (Coords -> a -> b) -> NonEmptyGrid a -> NonEmpty b +mapWithCoordsNE f (NonEmptyGrid g) = + sconcat $ NE.zipWith outer nonemptyCount g where - nonemptyCount = NE.iterate succ 0 + outer i = NE.zipWith (\j -> f (Coords (i, j))) nonemptyCount + +mapWithCoords :: (Coords -> a -> b) -> Grid a -> [b] +mapWithCoords _ EmptyGrid = [] +mapWithCoords f (Grid g) = NE.toList $ mapWithCoordsNE f g -- | Converts linked lists to vectors to facilitate -- random access when assembling the image gridToVec :: Grid a -> V.Vector (V.Vector a) gridToVec EmptyGrid = V.empty -gridToVec (Grid g) = V.fromList . map (V.fromList . NE.toList) $ NE.toList g +gridToVec (Grid (NonEmptyGrid g)) = V.fromList . map (V.fromList . NE.toList) $ NE.toList g instance (ToJSON a) => ToJSON (Grid a) where toJSON EmptyGrid = toJSON ([] :: [a]) diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Placement.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Placement.hs index 0026a1ac6..7072f9cec 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Placement.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Placement.hs @@ -57,10 +57,17 @@ reorientLandmark (Orientation upDir shouldFlip) (AreaDimensions width height) = DEast -> transposeLoc . flipV DWest -> transposeLoc . flipH +applyOrientationTransform :: + Orientation -> + Grid a -> + Grid a +applyOrientationTransform _ EmptyGrid = EmptyGrid +applyOrientationTransform f (Grid g) = Grid $ applyOrientationTransformNE f g + -- | affine transformation -applyOrientationTransform :: Orientation -> Grid a -> Grid a -applyOrientationTransform (Orientation upDir shouldFlip) = - mapRows f +applyOrientationTransformNE :: Orientation -> NonEmptyGrid a -> NonEmptyGrid a +applyOrientationTransformNE (Orientation upDir shouldFlip) = + mapRowsNE f where f = rotational . flipping flipV = NE.reverse diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs index 4d8b3dfaf..f19373318 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs @@ -118,10 +118,10 @@ paintMap maskChar pal g = do ] let cells = fmap standardCell <$> nestedLists - wps = catMaybes $ mapIndexedMembers getWp nestedLists + wps = catMaybes $ mapWithCoords getWp nestedLists let extraPlacements = - catMaybes $ mapIndexedMembers getStructureMarker nestedLists + catMaybes $ mapWithCoords getStructureMarker nestedLists return (cells, wps, extraPlacements) where diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs index a596bb264..a9ca86e41 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs @@ -30,7 +30,7 @@ data ParticipatingEntity e = ParticipatingEntity data IntactPlacementLog e = IntactPlacementLog { intactnessFailure :: Maybe (StructureIntactnessFailure e) - , sName :: OriginalName + , sName :: OrientedStructure , locUpperLeft :: Cosmic Location } deriving (Functor, Generic, ToJSON) diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs index ba1a49e1c..4e879a7ed 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs @@ -48,14 +48,15 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (except, runExceptT) import Data.Either.Combinators (leftToMaybe) import Data.Hashable (Hashable) +import Data.List.NonEmpty qualified as NE import Data.Map qualified as M import Data.Maybe (catMaybes, mapMaybe) import Data.Set qualified as Set import Data.Tuple (swap) import Swarm.Game.Location (Location, asVector) -import Swarm.Game.Scenario.Topography.Area (getGridDimensions, rectWidth) -import Swarm.Game.Scenario.Topography.Grid (getRows, mapIndexedMembers, mkGrid) -import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransform, getStructureName) +import Swarm.Game.Scenario.Topography.Area (computeArea, getNEGridDimensions, rectWidth) +import Swarm.Game.Scenario.Topography.Grid +import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransformNE, getStructureName) import Swarm.Game.Scenario.Topography.Structure.Named import Swarm.Game.Scenario.Topography.Structure.Recognition.Prep ( mkEntityLookup, @@ -106,17 +107,22 @@ mkAutomatons extractor xs = M.fromList $ map (getStructureName . name . namedGrid &&& process) xs +-- | Returns 'Nothing' if the grid is empty. extractOrientedGrid :: (Maybe b -> Maybe a) -> NamedGrid (Maybe b) -> AbsoluteDir -> - StructureWithGrid (Maybe b) a + Maybe (StructureWithGrid (Maybe b) a) extractOrientedGrid extractor x d = - StructureWithGrid wrapped d w $ getEntityGrid extractor g + case extractor <$> structure x of + EmptyGrid -> Nothing + Grid neGrid -> + let w = RowWidth . rectWidth . getNEGridDimensions $ neGrid + in Just $ + StructureWithGrid wrapped d w $ + applyOrientationTransformNE (Orientation d False) neGrid where - w = RowWidth . rectWidth . getGridDimensions $ structure g wrapped = NamedOriginal (getStructureName $ name x) x - g = applyOrientationTransform (Orientation d False) <$> x -- | At this point, we have already ensured that orientations -- redundant by rotational symmetry have been excluded @@ -126,7 +132,9 @@ extractGrids :: NamedGrid (Maybe b) -> [StructureWithGrid (Maybe b) a] extractGrids extractor x = - map (extractOrientedGrid extractor x) $ Set.toList $ recognize x + mapMaybe (extractOrientedGrid extractor x) orientations + where + orientations = Set.toList $ recognize x -- | The output list of 'FoundStructure' records is not yet -- vetted; the 'ensureStructureIntact' function will subsequently @@ -144,7 +152,8 @@ lookupStaticPlacements extractor (StaticStructureInfo structDefs thePlacements) where g (LocatedStructure theName d loc) = do sGrid <- M.lookup theName definitionMap - return $ FoundStructure (extractOrientedGrid extractor sGrid d) $ Cosmic subworldName loc + x <- extractOrientedGrid extractor sGrid d + return $ FoundStructure (Cosmic subworldName loc) x -- | Matches definitions against the placements. -- Fails fast (short-circuits) if a non-matching @@ -158,24 +167,29 @@ ensureStructureIntact :: GenericEntLocator s a -> FoundStructure b a -> s (Maybe (StructureIntactnessFailure a)) -ensureStructureIntact registry entLoader (FoundStructure (StructureWithGrid _ _ (RowWidth w) grid) upperLeft) = do - fmap leftToMaybe . runExceptT . mapM checkLoc $ zip [0 ..] allLocPairs +ensureStructureIntact registry entLoader (FoundStructure upperLeft (StructureWithGrid _ _ _ grid)) = do + fmap leftToMaybe . runExceptT . mapM checkLoc $ NE.zip nonemptyCount allLocPairs where + gridArea = computeArea $ getNEGridDimensions grid checkLoc (idx, (maybeTemplateEntity, loc)) = forM_ maybeTemplateEntity $ \x -> do e <- lift $ entLoader loc forM_ (M.lookup loc $ foundByLocation registry) $ \s -> - except - . Left - . StructureIntactnessFailure (AlreadyUsedBy $ distillLabel $ structureWithGrid s) idx - $ fromIntegral w * length grid + errorPrefix + . AlreadyUsedBy + . distillLabel + $ structureWithGrid s unless (e == Just x) - . except + . errorPrefix + $ DiscrepantEntity + $ EntityDiscrepancy x e + where + errorPrefix = + except . Left - . StructureIntactnessFailure (DiscrepantEntity $ EntityDiscrepancy x e) idx - $ fromIntegral w * length grid + . StructureIntactnessFailure idx gridArea f = fmap ((upperLeft `offsetBy`) . asVector . coordsToLoc) . swap - allLocPairs = mapIndexedMembers (curry f) $ mkGrid grid + allLocPairs = mapWithCoordsNE (curry f) grid diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Prep.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Prep.hs index 3e6becb2b..a7866c1a1 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Prep.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Prep.hs @@ -16,6 +16,7 @@ import Data.List.Split (wordsBy) import Data.Maybe (catMaybes, mapMaybe) import Data.Semigroup (sconcat) import Data.Tuple (swap) +import Swarm.Game.Scenario.Topography.Grid import Swarm.Game.Scenario.Topography.Structure.Recognition.Type import Text.AhoCorasick (makeStateMachine) @@ -28,9 +29,11 @@ import Text.AhoCorasick (makeStateMachine) -- in multiple rows within the same structure, or occur across structures. allStructureRows :: [StructureWithGrid b a] -> [StructureRow b a] allStructureRows = - concatMap transformRows + concatMap $ NE.toList . transformRows where - transformRows g = zipWith (StructureRow g) [0 ..] $ entityGrid g + transformRows g = NE.zipWith (StructureRow g) nonemptyCount rows + where + NonEmptyGrid rows = entityGrid g -- | If this entity is encountered in the world, -- how far left of it and how far right of it do we need to @@ -133,7 +136,7 @@ explodeRowEntities :: explodeRowEntities annotatedRow@(ConsolidatedRowReferences rowMembers _ width) = map f $ HM.toList $ binTuplesHM unconsolidatedEntityOccurrences where - chunks = getContiguousChunks rowMembers + chunks = getContiguousChunks $ NE.toList rowMembers f (e, occurrences) = SingleRowEntityOccurrences annotatedRow e chunks $ @@ -144,9 +147,10 @@ explodeRowEntities annotatedRow@(ConsolidatedRowReferences rowMembers _ width) = -- Only row members for which an entity exists (is not Nothing) -- are retained here. unconsolidatedEntityOccurrences = - map swap $ - catMaybes $ - zipWith (\idx -> fmap (PositionWithinRow idx annotatedRow,)) [0 ..] rowMembers + map swap + . catMaybes + . NE.toList + $ NE.zipWith (\idx -> fmap (PositionWithinRow idx annotatedRow,)) nonemptyCount rowMembers deriveEntityOffsets :: PositionWithinRow b a -> InspectionOffsets deriveEntityOffsets (PositionWithinRow pos _) = mkOffsets pos width diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs index 1cdc14df6..3f1f05483 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs @@ -6,6 +6,7 @@ -- Uses smart constructors to maintain this invariant. module Swarm.Game.Scenario.Topography.Structure.Recognition.Registry ( FoundRegistry, + StaticStructureOverlap (..), -- * Instantiation emptyFoundStructures, @@ -22,14 +23,18 @@ module Swarm.Game.Scenario.Topography.Structure.Recognition.Registry ( where import Control.Arrow ((&&&)) +import Data.List (partition, sortOn) import Data.List.NonEmpty qualified as NE import Data.Map (Map) import Data.Map qualified as M import Data.Map.NonEmpty (NEMap) import Data.Map.NonEmpty qualified as NEM -import Swarm.Game.Location (Location) +import Data.Maybe (listToMaybe, maybeToList) +import Data.Ord (Down (Down)) +import Data.Set qualified as Set +import Swarm.Game.Location import Swarm.Game.Scenario.Topography.Structure.Recognition.Type -import Swarm.Game.Universe (Cosmic) +import Swarm.Game.Universe (Cosmic (..)) import Swarm.Util (binTuples, deleteKeys) -- | The authoritative source of which built structures currently exist. @@ -73,7 +78,7 @@ removeStructure fs (FoundRegistry byName byLoc) = tidyDelete = NEM.nonEmptyMap . NEM.delete upperLeft addFound :: FoundStructure b a -> FoundRegistry b a -> FoundRegistry b a -addFound fs@(FoundStructure swg loc) (FoundRegistry byName byLoc) = +addFound fs@(FoundStructure loc swg) (FoundRegistry byName byLoc) = FoundRegistry (M.insertWith (<>) k (NEM.singleton loc swg) byName) (M.union occupationMap byLoc) @@ -81,18 +86,57 @@ addFound fs@(FoundStructure swg loc) (FoundRegistry byName byLoc) = k = getName $ originalDefinition swg occupationMap = M.fromList $ map (,fs) $ genOccupiedCoords fs +data StaticStructureOverlap = StaticStructureOverlap + { overlapLocs :: NE.NonEmpty (Cosmic Location) + , overlapStructures :: [OriginalName] + } + deriving (Show) + -- | Bulk insertion of found structures. -- --- Each of these shall have been re-checked in case --- a subsequent placement occludes them. -populateStaticFoundStructures :: [FoundStructure b a] -> FoundRegistry b a +-- If any of these overlap, we can't be sure of the author's +-- intent as to which member of the overlap should take precedence, +-- so perhaps it would be ideal to throw an error at scenario parse time. +-- +-- However, determining whether a structure is all three of: +-- 1. placed +-- 2. still recognizable +-- 3. overlapping with another recognized structure +-- occurs at a later phase than scenario parse; it requires access to the 'GameState'. +-- +-- So we just use the same sorting criteria as the one used to resolve recognition +-- conflicts at entity placement time. +populateStaticFoundStructures :: + (Eq a, Eq b) => + [FoundStructure b a] -> + FoundRegistry b a populateStaticFoundStructures allFound = FoundRegistry byName byLocation where mkOccupationMap fs = M.fromList $ map (,fs) $ genOccupiedCoords fs - byLocation = M.unions $ map mkOccupationMap allFound + + resolvedCollisions = resolvePreplacementCollisions allFound + + byLocation = M.unions $ map mkOccupationMap resolvedCollisions byName = M.map (NEM.fromList . NE.map (upperLeftCorner &&& structureWithGrid)) $ binTuples $ - map (getName . originalDefinition . structureWithGrid &&& id) allFound + map (getName . originalDefinition . structureWithGrid &&& id) resolvedCollisions + + resolvePreplacementCollisions foundList = + nonOverlappingFound <> maybeToList (listToMaybe overlapsByDecreasingPreference) + where + overlapsByDecreasingPreference = sortOn Down overlappingFound + + (overlappingFound, nonOverlappingFound) = + partition ((`Set.member` overlappingPlacements) . fmap distillLabel) foundList + + overlappingPlacements = + Set.fromList + . map (fmap distillLabel) + . concatMap NE.toList + . M.elems + . M.filter ((> 1) . NE.length) + . M.unionsWith (<>) + $ map (M.map pure . mkOccupationMap) foundList diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs index 3212a5993..45804244f 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs @@ -174,8 +174,8 @@ checkChunksCombination where mkFoundStructure r = FoundStructure - (wholeStructure r) (cLoc `offsetBy` theOffset) + (wholeStructure r) where theOffset = V2 (horizontalStructPos $ foundChunkRow x) (rowIndex r) @@ -277,14 +277,14 @@ registerRowMatches entLoader cLoc (AutomatonInfo horizontalOffsets pwMatcher) rS registry = rState ^. foundStructures PiecewiseRecognition pwSM rowChunkReferences = pwMatcher - getStructInfo (FoundStructure swg loc) = (distillLabel swg, loc) + getStructInfo (FoundStructure loc swg) = (distillLabel swg, loc) validateIntactness2d fs = do maybeIntactnessFailure <- lift $ ensureStructureIntact (rState ^. foundStructures) entLoader fs tell . pure . ChunkIntactnessVerification $ IntactPlacementLog maybeIntactnessFailure - (getName . originalDefinition . structureWithGrid $ fs) + (distillLabel . structureWithGrid $ fs) (upperLeftCorner fs) return $ null maybeIntactnessFailure diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs index 9d3869e79..d5214a54b 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs @@ -26,18 +26,20 @@ import Data.HashMap.Strict (HashMap) import Data.Int (Int32) import Data.IntSet.NonEmpty (NEIntSet) import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE import Data.Map (Map) import Data.Maybe (catMaybes) import Data.Ord (Down (Down)) import Data.Semigroup (Max, Min) import Data.Text (Text) import GHC.Generics (Generic) -import Linear (V2 (..)) -import Swarm.Game.Location (Location) +import Swarm.Game.Location (Location, asVector) import Swarm.Game.Scenario.Topography.Area +import Swarm.Game.Scenario.Topography.Grid import Swarm.Game.Scenario.Topography.Structure.Named (NamedGrid) import Swarm.Game.Scenario.Topography.Structure.Recognition.Static import Swarm.Game.Universe (Cosmic, offsetBy) +import Swarm.Game.World.Coords (coordsToLoc) import Swarm.Language.Syntax.Direction (AbsoluteDir) import Text.AhoCorasick (StateMachine) @@ -147,13 +149,13 @@ data StructureRow b a = StructureRow { wholeStructure :: StructureWithGrid b a , rowIndex :: Int32 -- ^ vertical index of the row within the structure - , rowContent :: SymbolSequence a + , rowContent :: NonEmpty (AtomicKeySymbol a) } -- | Represents all rows across all structures that share -- a particular row content data ConsolidatedRowReferences b a = ConsolidatedRowReferences - { sharedRowContent :: SymbolSequence a + { sharedRowContent :: NonEmpty (AtomicKeySymbol a) , referencingRows :: NonEmpty (StructureRow b a) , theRowWidth :: RowWidth } @@ -177,7 +179,7 @@ data StructureWithGrid b a = StructureWithGrid { originalDefinition :: NamedOriginal b , rotatedTo :: AbsoluteDir , gridWidth :: RowWidth - , entityGrid :: [SymbolSequence a] + , entityGrid :: NonEmptyGrid (AtomicKeySymbol a) } deriving (Eq) @@ -240,11 +242,24 @@ makeLenses ''RecognizerAutomatons -- -- The two type parameters, `b` and `a`, correspond -- to 'Cell' and 'Entity', respectively. -data FoundStructure b a = FoundStructure - { structureWithGrid :: StructureWithGrid b a - , upperLeftCorner :: Cosmic Location +type FoundStructure b a = PositionedStructure (StructureWithGrid b a) + +-- | NOTE: A structures name + orientation + position will uniquely +-- identify it in the world. Note that position alone is not sufficient; +-- due to transparency, a completely intact smaller structure can co-exist +-- within a larger structure, both sharing the same upper-left coordinate. +-- However, two identical structures (with identical orientation) cannot +-- occupy the same space. +-- +-- Compare "PositionedStructure OrientedStructure" to: +-- "Swarm.Game.Scenario.Topography.Structure.Recognition.Static.LocatedStructure" +data PositionedStructure s = FoundStructure + { upperLeftCorner :: Cosmic Location + , structureWithGrid :: s } - deriving (Eq) + deriving (Eq, Functor) + +deriving instance (Ord (PositionedStructure OrientedStructure)) data FoundRowFromChunk a = FoundRowFromChunk { chunkOffsetFromSearchBorder :: Int @@ -281,7 +296,7 @@ data OrientedStructure = OrientedStructure { oName :: OriginalName , oDir :: AbsoluteDir } - deriving (Generic, ToJSON) + deriving (Eq, Ord, Generic, ToJSON) distillLabel :: StructureWithGrid b a -> OrientedStructure distillLabel swg = OrientedStructure (getName $ originalDefinition swg) (rotatedTo swg) @@ -292,9 +307,9 @@ data IntactnessFailureReason e deriving (Functor, Generic, ToJSON) data StructureIntactnessFailure e = StructureIntactnessFailure - { reason :: IntactnessFailureReason e - , failedOnIndex :: Int - , totalSize :: Int + { failedOnIndex :: Int32 + , totalSize :: Int32 + , reason :: IntactnessFailureReason e } deriving (Functor, Generic, ToJSON) @@ -311,15 +326,14 @@ data StructureIntactnessFailure e = StructureIntactnessFailure instance (Eq b, Eq a) => Ord (FoundStructure b a) where compare = compare `on` (f1 &&& f2) where - f1 = computeArea . getAreaDimensions . entityGrid . structureWithGrid + f1 = computeArea . getNEGridDimensions . entityGrid . structureWithGrid f2 = Down . upperLeftCorner -- | Yields coordinates that are occupied by an entity of a placed structure. -- Cells within the rectangular bounds of the structure that are unoccupied -- are not included. genOccupiedCoords :: FoundStructure b a -> [Cosmic Location] -genOccupiedCoords (FoundStructure swg loc) = - concatMap catMaybes . zipWith mkRow [0 ..] $ entityGrid swg +genOccupiedCoords (FoundStructure loc swg) = + catMaybes . NE.toList . mapWithCoordsNE f $ entityGrid swg where - mkCol y x ent = loc `offsetBy` V2 x (negate y) <$ ent - mkRow rowIdx = zipWith (mkCol rowIdx) [0 ..] + f cellLoc maybeEnt = ((loc `offsetBy`) . asVector . coordsToLoc $ cellLoc) <$ maybeEnt diff --git a/test/integration/Main.hs b/test/integration/Main.hs index 95f9827be..b325af842 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -476,6 +476,7 @@ testScenarioSolutions rs ui key = , testSolution Default "Testing/1575-structure-recognizer/2115-encroaching-upon-exterior-transparent-cells" , testSolution Default "Testing/1575-structure-recognizer/2201-piecewise-lines" , testSolution Default "Testing/1575-structure-recognizer/2201-preclude-overlapping-recognition" + , testSolution Default "Testing/1575-structure-recognizer/2201-initial-recognition-overlap" ] ] , testSolution' Default "Testing/1430-built-robot-ownership" CheckForBadErrors $ \g -> do