From ae756ce9861877e9629917dee5cec27da8a5bac5 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Tue, 13 Aug 2024 11:52:01 -0700 Subject: [PATCH] support structure intrusion --- .../1575-interior-entity-placement.yaml | 4 - .../Topography/Structure/Recognition/Log.hs | 35 ++++-- .../Topography/Structure/Recognition/Prep.hs | 31 +++-- .../Structure/Recognition/Tracking.hs | 111 +++++++++++------- .../Topography/Structure/Recognition/Type.hs | 11 +- src/swarm-util/Swarm/Util.hs | 11 ++ swarm.cabal | 1 + weeder.toml | 3 +- 8 files changed, 138 insertions(+), 69 deletions(-) diff --git a/data/scenarios/Testing/1575-structure-recognizer/1575-interior-entity-placement.yaml b/data/scenarios/Testing/1575-structure-recognizer/1575-interior-entity-placement.yaml index 9832ec7cc..7a6515706 100644 --- a/data/scenarios/Testing/1575-structure-recognizer/1575-interior-entity-placement.yaml +++ b/data/scenarios/Testing/1575-structure-recognizer/1575-interior-entity-placement.yaml @@ -9,10 +9,6 @@ description: | Additionally, recognition of statically-placed structures at scenario initialization is also unaffected by interior entities. - - However, any such "contaminating" entities - will prevent the recognition of a structure - when constructed by a robot. creative: false objectives: - teaser: Replace rock 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 d8753d3c4..31ff6d823 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 @@ -6,6 +6,7 @@ module Swarm.Game.Scenario.Topography.Structure.Recognition.Log where import Data.Aeson import Data.Int (Int32) +import Data.List.NonEmpty (NonEmpty) import GHC.Generics (Generic) import Servant.Docs (ToSample) import Servant.Docs qualified as SD @@ -14,8 +15,10 @@ import Swarm.Game.Scenario.Topography.Structure.Recognition.Type import Swarm.Game.Universe (Cosmic) import Swarm.Language.Syntax.Direction (AbsoluteDir) -type StructureRowContent e = [Maybe e] -type WorldRowContent e = [Maybe e] +-- | Type aliases for documentation +type StructureRowContent e = SymbolSequence e + +type WorldRowContent e = SymbolSequence e data OrientedStructure = OrientedStructure { oName :: OriginalName @@ -27,7 +30,8 @@ distillLabel :: StructureWithGrid b a -> OrientedStructure distillLabel swg = OrientedStructure (getName $ originalDefinition swg) (rotatedTo swg) data MatchingRowFrom = MatchingRowFrom - { rowIdx :: Int32 + { topDownRowIdx :: Int32 + -- ^ numbered from the top down , structure :: OrientedStructure } deriving (Generic, ToJSON) @@ -45,14 +49,23 @@ data HaystackContext e = HaystackContext data FoundRowCandidate e = FoundRowCandidate { haystackContext :: HaystackContext e - , structureContent :: StructureRowContent e - , rowCandidates :: [MatchingRowFrom] + , soughtContent :: StructureRowContent e + , matchedCandidates :: [MatchingRowFrom] + } + deriving (Functor, Generic, ToJSON) + +data EntityKeyedFinder e = EntityKeyedFinder + { searchOffsets :: InspectionOffsets + , candidateStructureRows :: [StructureRowContent e] + , entityMask :: [e] + -- ^ NOTE: HashSet has no Functor instance, + -- so we represent this as a list here. } deriving (Functor, Generic, ToJSON) data ParticipatingEntity e = ParticipatingEntity { entity :: e - , searchOffsets :: InspectionOffsets + , entityKeyedFinders :: NonEmpty (EntityKeyedFinder e) } deriving (Functor, Generic, ToJSON) @@ -63,6 +76,14 @@ data IntactPlacementLog = IntactPlacementLog } deriving (Generic, ToJSON) +data VerticalSearch e = VerticalSearch + { haystackVerticalExtents :: InspectionOffsets + -- ^ vertical offset of haystack relative to the found row + , soughtStructures :: [OrientedStructure] + , verticalHaystack :: [WorldRowContent e] + } + deriving (Functor, Generic, ToJSON) + data SearchLog e = FoundParticipatingEntity (ParticipatingEntity e) | StructureRemoved OriginalName @@ -70,7 +91,7 @@ data SearchLog e | FoundCompleteStructureCandidates [OrientedStructure] | -- | There may be multiple candidate structures that could be -- completed by the element that was just placed. This lists all of them. - VerticalSearchSpans [(InspectionOffsets, [OrientedStructure])] + VerticalSearchSpans [VerticalSearch e] | IntactStaticPlacement [IntactPlacementLog] deriving (Functor, Generic) 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 299f6c924..7e84c0804 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 @@ -7,6 +7,7 @@ import Data.HashMap.Strict qualified as HM import Data.HashSet qualified as HS import Data.Hashable (Hashable) import Data.Int (Int32) +import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Maybe (catMaybes) import Data.Semigroup (sconcat) @@ -32,10 +33,10 @@ mkOffsets pos xs = -- rows constitute a complete structure. mkRowLookup :: (Hashable a, Eq a) => - NE.NonEmpty (StructureRow b a) -> + NonEmpty (StructureRow b a) -> AutomatonInfo a (SymbolSequence a) (StructureWithGrid b a) mkRowLookup neList = - AutomatonInfo participatingEnts bounds sm + AutomatonInfo participatingEnts bounds sm tuples where mkSmTuple = entityGrid &&& id tuples = NE.toList $ NE.map (mkSmTuple . wholeStructure) neList @@ -61,7 +62,7 @@ mkRowLookup neList = mkEntityLookup :: (Hashable a, Eq a) => [StructureWithGrid b a] -> - HM.HashMap a (AutomatonInfo a (AtomicKeySymbol a) (StructureSearcher b a)) + HM.HashMap a (NonEmpty (AutomatonInfo a (AtomicKeySymbol a) (StructureSearcher b a))) mkEntityLookup grids = HM.map mkValues rowsByEntityParticipation where @@ -75,15 +76,26 @@ mkEntityLookup grids = structureRowsNE = NE.map myRow singleRows sm2D = mkRowLookup structureRowsNE - mkValues neList = AutomatonInfo participatingEnts bounds sm + mkValues neList = + NE.fromList $ + map (\(mask, tups) -> AutomatonInfo mask bounds sm $ NE.toList tups) tuplesByEntMask where - participatingEnts = - HS.fromList - (concatMap (catMaybes . fst) tuples) + -- If there are no transparent cells, + -- we don't need a mask. + getMaskSet row = + if Nothing `elem` row + then HS.fromList $ catMaybes row + else mempty + + tuplesByEntMask = HM.toList $ binTuplesHM $ map (getMaskSet . fst &&& id) tuples tuples = HM.toList $ HM.mapWithKey mkSmValue groupedByUniqueRow - groupedByUniqueRow = binTuplesHM $ NE.toList $ NE.map (rowContent . myRow &&& id) neList + groupedByUniqueRow = + binTuplesHM $ + NE.toList $ + NE.map (rowContent . myRow &&& id) neList + bounds = sconcat $ NE.map expandedOffsets neList sm = makeStateMachine tuples @@ -111,6 +123,7 @@ mkEntityLookup grids = SingleRowEntityOccurrences r e occurrences $ sconcat $ NE.map deriveEntityOffsets occurrences + unconsolidated = map swap $ catMaybes $ @@ -123,7 +136,7 @@ mkEntityLookup grids = binTuplesHM :: (Foldable t, Hashable a, Eq a) => t (a, b) -> - HM.HashMap a (NE.NonEmpty b) + HM.HashMap a (NonEmpty b) binTuplesHM = foldr f mempty where f = uncurry (HM.insertWith (<>)) . fmap pure 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 ee0076e98..182117141 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 @@ -12,13 +12,14 @@ module Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking ( import Control.Lens ((%~), (&), (.~), (^.)) import Control.Monad (forM, guard) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Data.Foldable (foldrM) import Data.HashMap.Strict qualified as HM import Data.HashSet (HashSet) import Data.HashSet qualified as HS import Data.Hashable (Hashable) import Data.Int (Int32) import Data.List (sortOn) -import Data.List.NonEmpty qualified as NE +import Data.List.NonEmpty.Extra qualified as NE import Data.Map qualified as M import Data.Maybe (listToMaybe) import Data.Ord (Down (..)) @@ -66,11 +67,19 @@ entityModified entLoader modification cLoc recognizer = let oldRecognitionState = r ^. recognitionState stateRevision <- case HM.lookup newEntity entLookup of Nothing -> return oldRecognitionState - Just finder -> do - let msg = FoundParticipatingEntity $ ParticipatingEntity newEntity (finder ^. inspectionOffsets) + Just finders -> do + let logFinder f = + EntityKeyedFinder + (f ^. inspectionOffsets) + (map fst $ f ^. searchPairs) + (HS.toList $ f ^. participatingEntities) + msg = + FoundParticipatingEntity $ + ParticipatingEntity newEntity $ + NE.map logFinder finders stateRevision' = oldRecognitionState & recognitionLog %~ (msg :) - registerRowMatches entLoader cLoc finder stateRevision' + foldrM (registerRowMatches entLoader cLoc) stateRevision' finders return $ r & recognitionState .~ stateRevision @@ -107,14 +116,15 @@ candidateEntityAt :: (Monad s, Hashable a) => GenericEntLocator s a -> FoundRegistry b a -> - -- | participating entities + -- | participating entities whitelist. If empty, all entities are included. + -- NOTE: This is only needed for structures that have transparent cells. HashSet a -> Cosmic Location -> s (Maybe a) candidateEntityAt entLoader registry participating cLoc = runMaybeT $ do guard $ M.notMember cLoc $ foundByLocation registry ent <- MaybeT $ entLoader cLoc - guard $ HS.member ent participating + guard $ null participating || HS.member ent participating return ent -- | Excludes entities that are already part of a @@ -123,13 +133,13 @@ getWorldRow :: (Monad s, Hashable a) => GenericEntLocator s a -> FoundRegistry b a -> - -- | participating entities - HashSet a -> Cosmic Location -> InspectionOffsets -> + -- | participating entities + HashSet a -> Int32 -> s [Maybe a] -getWorldRow entLoader registry participatingEnts cLoc (InspectionOffsets (Min offsetLeft) (Max offsetRight)) yOffset = do +getWorldRow entLoader registry cLoc (InspectionOffsets (Min offsetLeft) (Max offsetRight)) participatingEnts yOffset = do mapM getCandidate horizontalOffsets where getCandidate = candidateEntityAt entLoader registry participatingEnts @@ -139,8 +149,27 @@ getWorldRow entLoader registry participatingEnts cLoc (InspectionOffsets (Min of -- to bottom, but swarm world coordinates increase from bottom to top. mkLoc x = cLoc `offsetBy` V2 x (negate yOffset) +logRowCandidates :: [Maybe e] -> [Position (StructureSearcher b e)] -> SearchLog e +logRowCandidates entitiesRow candidates = + FoundRowCandidates $ map mkCandidateLogEntry candidates + where + mkCandidateLogEntry c = + FoundRowCandidate + (HaystackContext entitiesRow (HaystackPosition $ pIndex c)) + (needleContent $ pVal c) + rowMatchInfo + where + rowMatchInfo :: [MatchingRowFrom] + rowMatchInfo = NE.toList . NE.map (f . myRow) . singleRowItems $ pVal c + where + f x = + MatchingRowFrom (rowIndex x) $ distillLabel . wholeStructure $ x + -- | This is the first (one-dimensional) stage -- in a two-stage (two-dimensional) search. +-- +-- It searches for any structure row that happens to +-- contain the placed entity. registerRowMatches :: (Monad s, Hashable a, Eq b) => GenericEntLocator s a -> @@ -148,34 +177,12 @@ registerRowMatches :: AutomatonInfo a (AtomicKeySymbol a) (StructureSearcher b a) -> RecognitionState b a -> s (RecognitionState b a) -registerRowMatches entLoader cLoc (AutomatonInfo participatingEnts horizontalOffsets sm) rState = do - let registry = rState ^. foundStructures - - entitiesRow <- - getWorldRow - entLoader - registry - participatingEnts - cLoc - horizontalOffsets - 0 - - let candidates = findAll sm entitiesRow - - mkCandidateLogEntry c = - FoundRowCandidate - (HaystackContext entitiesRow (HaystackPosition $ pIndex c)) - (needleContent $ pVal c) - rowMatchInfo - where - rowMatchInfo :: [MatchingRowFrom] - rowMatchInfo = NE.toList . NE.map (f . myRow) . singleRowItems $ pVal c - where - f x = - MatchingRowFrom (rowIndex x) $ distillLabel . wholeStructure $ x +registerRowMatches entLoader cLoc (AutomatonInfo participatingEnts horizontalOffsets sm _) rState = do + maskChoices <- attemptSearchWithEntityMask participatingEnts - logEntry = FoundRowCandidates $ map mkCandidateLogEntry candidates + let logEntry = uncurry logRowCandidates maskChoices rState2 = rState & recognitionLog %~ (logEntry :) + candidates = snd maskChoices candidates2Dpairs <- forM candidates $ @@ -186,6 +193,22 @@ registerRowMatches entLoader cLoc (AutomatonInfo participatingEnts horizontalOff return $ registerStructureMatches (concat candidates2D) rState3 + where + registry = rState ^. foundStructures + + attemptSearchWithEntityMask entsMask = do + entitiesRow <- + getWorldRow + entLoader + registry + cLoc + horizontalOffsets + entsMask + 0 + + -- All of the eligible structure rows found + -- within this horizontal swath of world cells + return (entitiesRow, findAll sm entitiesRow) -- | Examines contiguous rows of entities, accounting -- for the offset of the initially found row. @@ -197,10 +220,10 @@ checkVerticalMatch :: -- | Horizontal search offsets InspectionOffsets -> Position (StructureSearcher b a) -> - s ((InspectionOffsets, [OrientedStructure]), [FoundStructure b a]) + s (VerticalSearch a, [FoundStructure b a]) checkVerticalMatch entLoader registry cLoc (InspectionOffsets (Min searchOffsetLeft) _) foundRow = do - (x, y) <- getMatches2D entLoader registry cLoc horizontalFoundOffsets $ automaton2D searcherVal - return ((x, rowStructureNames), y) + ((x, y), z) <- getMatches2D entLoader registry cLoc horizontalFoundOffsets $ automaton2D searcherVal + return (VerticalSearch x rowStructureNames y, z) where searcherVal = pVal foundRow rowStructureNames = NE.toList . NE.map (distillLabel . wholeStructure . myRow) . singleRowItems $ searcherVal @@ -234,18 +257,18 @@ getMatches2D :: -- | Horizontal found offsets (inclusive indices) InspectionOffsets -> AutomatonInfo a (SymbolSequence a) (StructureWithGrid b a) -> - s (InspectionOffsets, [FoundStructure b a]) + s ((InspectionOffsets, [[Maybe a]]), [FoundStructure b a]) getMatches2D entLoader registry cLoc horizontalFoundOffsets@(InspectionOffsets (Min offsetLeft) _) - (AutomatonInfo participatingEnts vRange@(InspectionOffsets (Min offsetTop) (Max offsetBottom)) sm) = do - entityRows <- mapM getRow verticalOffsets - return (vRange, getFoundStructures (offsetTop, offsetLeft) cLoc sm entityRows) + (AutomatonInfo participatingEnts vRange@(InspectionOffsets (Min offsetTop) (Max offsetBottom)) sm _) = do + entityRows <- mapM getRow vertOffsets + return ((vRange, entityRows), getFoundStructures (offsetTop, offsetLeft) cLoc sm entityRows) where - getRow = getWorldRow entLoader registry participatingEnts cLoc horizontalFoundOffsets - verticalOffsets = [offsetTop .. offsetBottom] + getRow = getWorldRow entLoader registry cLoc horizontalFoundOffsets participatingEnts + vertOffsets = [offsetTop .. offsetBottom] -- | -- We only allow an entity to participate in one structure at a time, 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 2d8f97934..8ce1d555e 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 @@ -25,7 +25,7 @@ import Data.Function (on) import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import Data.Int (Int32) -import Data.List.NonEmpty qualified as NE +import Data.List.NonEmpty (NonEmpty) import Data.Map (Map) import Data.Maybe (catMaybes) import Data.Ord (Down (Down)) @@ -74,7 +74,7 @@ type SymbolSequence a = [AtomicKeySymbol a] data StructureSearcher b a = StructureSearcher { automaton2D :: AutomatonInfo a (SymbolSequence a) (StructureWithGrid b a) , needleContent :: SymbolSequence a - , singleRowItems :: NE.NonEmpty (SingleRowEntityOccurrences b a) + , singleRowItems :: NonEmpty (SingleRowEntityOccurrences b a) } -- | @@ -108,7 +108,7 @@ data PositionWithinRow b a = PositionWithinRow data SingleRowEntityOccurrences b a = SingleRowEntityOccurrences { myRow :: StructureRow b a , myEntity :: a - , entityOccurrences :: NE.NonEmpty (PositionWithinRow b a) + , entityOccurrences :: NonEmpty (PositionWithinRow b a) , expandedOffsets :: InspectionOffsets } @@ -197,6 +197,9 @@ data AutomatonInfo en k v = AutomatonInfo { _participatingEntities :: HashSet en , _inspectionOffsets :: InspectionOffsets , _automaton :: StateMachine k v + , _searchPairs :: [([k], v)] + -- ^ these are the tuples input to the 'makeStateMachine' function, + -- for debugging purposes. } deriving (Generic) @@ -208,7 +211,7 @@ data RecognizerAutomatons b a = RecognizerAutomatons { _originalStructureDefinitions :: Map OriginalName (StructureInfo b a) -- ^ all of the structures that shall participate in automatic recognition. -- This list is used only by the UI and by the 'Floorplan' command. - , _automatonsByEntity :: HashMap a (AutomatonInfo a (AtomicKeySymbol a) (StructureSearcher b a)) + , _automatonsByEntity :: HashMap a (NonEmpty (AutomatonInfo a (AtomicKeySymbol a) (StructureSearcher b a))) } deriving (Generic) diff --git a/src/swarm-util/Swarm/Util.hs b/src/swarm-util/Swarm/Util.hs index 6f4ae556f..58bb7436d 100644 --- a/src/swarm-util/Swarm/Util.hs +++ b/src/swarm-util/Swarm/Util.hs @@ -20,6 +20,7 @@ module Swarm.Util ( indexWrapNonEmpty, uniq, binTuples, + binTuplesNE, histogram, findDup, both, @@ -100,6 +101,8 @@ import Data.List.NonEmpty (NonEmpty ((:|))) 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 Data.Maybe (fromMaybe) import Data.Ord (comparing) import Data.Set (Set) @@ -208,6 +211,14 @@ binTuples = foldr f mempty where f = uncurry (M.insertWith (<>)) . fmap pure +-- | Place the second element of the tuples into bins by +-- the value of the first element. +binTuplesNE :: + (Ord a) => + NonEmpty (a, b) -> + NEMap a (NE.NonEmpty b) +binTuplesNE = NEM.fromListWith (<>) . NE.map (fmap pure) + -- | Count occurrences of a value histogram :: (Foldable t, Ord a) => diff --git a/swarm.cabal b/swarm.cabal index 551a0fc94..e3eda8186 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -611,6 +611,7 @@ library swarm-util lens >=4.19 && <5.4, minimorph >=0.3 && <0.4, mtl >=2.2.2 && <2.4, + nonempty-containers >=0.3.4 && <0.3.5, servant-docs >=0.12 && <0.14, template-haskell >=2.16 && <2.22, text >=1.2.4 && <2.2, diff --git a/weeder.toml b/weeder.toml index b93e5806c..c43ef24f4 100644 --- a/weeder.toml +++ b/weeder.toml @@ -40,9 +40,10 @@ roots = [ "^Swarm.Language.Syntax.Pattern.UTerm$", "^Swarm.Language.Syntax.Util.asTree$", "^Swarm.Language.Syntax.Util.mapFreeS$", + "^Swarm.Util.binTuplesNE$", + "^Swarm.Util.isSuccessOr$", "^Swarm.Util.replaceLast$", "^Swarm.Util.reflow$", - "^Swarm.Util.isSuccessOr$", "^Swarm.Util._NonEmpty$", # True positives (unused lenses):