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 :: NonEmpty (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,13 +33,13 @@ 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
+  tuples = NE.map (mkSmTuple . wholeStructure) neList
 
   -- All of the unique entities across all of the full candidate structures
   participatingEnts =
@@ -50,7 +51,7 @@ mkRowLookup neList =
     mkOffsets rwIdx g
 
   bounds = sconcat $ NE.map deriveRowOffsets neList
-  sm = makeStateMachine tuples
+  sm = makeStateMachine $ NE.toList tuples
 
 -- | Make the first-phase lookup map, keyed by 'Entity',
 -- along with automatons whose key symbols are "Maybe Entity".
@@ -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,17 +76,26 @@ mkEntityLookup grids =
     structureRowsNE = NE.map myRow singleRows
     sm2D = mkRowLookup structureRowsNE
 
-  mkValues neList = AutomatonInfo participatingEnts bounds sm
+  mkValues neList =
+    NE.map (\(mask, tups) -> AutomatonInfo mask bounds sm 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
 
-    tuples = HM.toList $ HM.mapWithKey mkSmValue groupedByUniqueRow
+    tuplesByEntMask = binTuplesHMasListNE $ NE.map (getMaskSet . fst &&& id) tuplesNE
+
+    tuplesNE = NE.map (\(a, b) -> (a, mkSmValue a b)) groupedByUniqueRow
+
+    groupedByUniqueRow =
+      binTuplesHMasListNE $
+        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
+    sm = makeStateMachine $ NE.toList tuplesNE
 
   -- The values of this map are guaranteed to contain only one
   -- entry per row of a given structure.
@@ -111,6 +121,7 @@ mkEntityLookup grids =
       SingleRowEntityOccurrences r e occurrences $
         sconcat $
           NE.map deriveEntityOffsets occurrences
+
     unconsolidated =
       map swap $
         catMaybes $
@@ -123,7 +134,19 @@ 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
+
+-- | We know that if the input to the binning function
+-- is a nonempty list, the output map must also have
+-- at least one element.
+-- Ideally we would use a NonEmptyMap to prove this,
+-- but unfortunately such a variant does not exist for 'HashMap'.
+-- So we just "force" the proof by using 'NE.fromList'.
+binTuplesHMasListNE ::
+  (Hashable a, Eq a) =>
+  NonEmpty (a, b) ->
+  NonEmpty (a, NonEmpty b)
+binTuplesHMasListNE = NE.fromList . HM.toList . binTuplesHM