support structure intrusion

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

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,14 +76,22 @@ 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
   | FoundRowCandidates [FoundRowCandidate 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)
 

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

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,43 +149,40 @@ 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 ->
   Cosmic Location ->
   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,