Fix shape recognition orientation edge case (#2229)

This PR augments the inner map key (from `Cosmic Location` to `(Cosmic Location, AbsoluteDir)`) for the `foundByName` field in the recognition registry to account for a shape that may have two non-overlapping orientations placed at the same coordinate.

## Testing
```
scripts/test/run-tests.sh --test-options '--pattern "structure"'
```
## Other changes and refactoring

* Enhanced logging: add a new constructor for logging that indicates which shape (if any) was recognized
* Extract the inner logic from `entityModified` into a function `entityModifiedLoggable` that does not dictate the logging structure
* Introduce a new `RecognitionActiveStatus` parameter that allows API users to temporarily disable recognition of "contained" structures while constructing larger structures
* Inline the `registerBestStructureMatch` function

data/scenarios/Testing/1575-structure-recognizer/00-ORDER.txt

@@ -19,3 +19,4 @@
 2201-piecewise-lines.yaml
 2201-preclude-overlapping-recognition.yaml
 2201-initial-recognition-overlap.yaml
+2229-position-uniqueness-multiple-orientations.yaml

data/scenarios/Testing/1575-structure-recognizer/2229-position-uniqueness-multiple-orientations.yaml

@@ -0,0 +1,60 @@
+version: 1
+name: Structure recognition - rotated structures at same position
+description: |
+  A map keyed by (position, structure name) would not be sufficient to
+  account for multiple orientations of the same structure, sharing the
+  same top-left corner position.
+
+  This is why the found structure registry must include orientation
+  in its key.
+creative: false
+objectives:
+  - teaser: Recognize both structures
+    goal:
+      - |
+        Two `thingy`{=structure} structures should be recognized immediately.
+        Without distinguishing them by orientation in the registry, only
+        one would be recognized.
+    condition: |
+      foundStructure <- structure "thingy" 0;
+      return $ case foundStructure
+        (\_. false)
+        (\result. fst result == 2);
+robots:
+  - name: base
+    dir: north
+    devices:
+      - logger
+solution: |
+  noop;
+structures:
+  - name: thingy
+    recognize: [north, east]
+    structure:
+      palette:
+        'x': [stone, rock]
+        'y': [dirt]
+      mask: '.'
+      map: |
+        y.y
+        yxx
+known: [rock]
+world:
+  dsl: |
+    {blank}
+  placements:
+    - src: thingy
+    - src: thingy
+      offset: [0, 0]
+      orient:
+        up: east
+  palette:
+    '.': [grass, erase]
+    'B': [grass, erase, base]
+  upperleft: [-3, 3]
+  map: |
+    .........B.
+    ...........
+    ...........
+    ...........
+    ...........

src/swarm-engine/Swarm/Game/Step/Const.hs

@@ -554,7 +554,7 @@ execConst runChildProg c vs s k = do
             mkOutput mapNE = (NE.length xs, bottomLeftCorner)
              where
               xs = NEM.toList mapNE
-              (pos, struc) = indexWrapNonEmpty xs idx
+              ((pos, _), struc) = indexWrapNonEmpty xs idx
               topLeftCorner = pos ^. planar
               offsetHeight = V2 0 $ negate (rectHeight (getNEGridDimensions $ extractedGrid $ entityGrid struc) - 1)
               bottomLeftCorner :: Location

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs

@@ -17,6 +17,7 @@ import Swarm.Game.Scenario.Topography.Structure.Recognition.Static (
  )
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
 import Swarm.Game.Universe (Cosmic)
+import Swarm.Language.Syntax.Direction (AbsoluteDir)
 
 renderSharedNames :: ConsolidatedRowReferences b a -> NonEmpty StructureName
 renderSharedNames =
@@ -57,6 +58,7 @@ data SearchLog e
   | StartSearchAt (Cosmic Location) InspectionOffsets
   | FoundParticipatingEntity (ParticipatingEntity e)
   | FoundCompleteStructureCandidates [(OrientedStructure, Cosmic Location)]
+  | RecognizedSingleStructure (OrientedStructure, Cosmic Location)
   | -- | this is actually internally used as a (Map (NonEmpty e) (NonEmpty Int)),
     -- but the requirements of Functor force us to invert the mapping
     FoundPiecewiseChunks [(NonEmpty Int, NonEmpty e)]
@@ -80,7 +82,7 @@ searchLogOptions =
 instance ToSample (SearchLog e) where
   toSamples _ = SD.noSamples
 
-data StructureLocation = StructureLocation StructureName (Cosmic Location)
+data StructureLocation = StructureLocation StructureName (Cosmic Location, AbsoluteDir)
   deriving (Generic, ToJSON)
 
 instance ToSample StructureLocation where

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs

@@ -35,14 +35,15 @@ import Swarm.Game.Location
 import Swarm.Game.Scenario.Topography.Structure.Named (StructureName, name)
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
 import Swarm.Game.Universe (Cosmic (..))
+import Swarm.Language.Syntax.Direction (AbsoluteDir (..))
 import Swarm.Util (binTuples, deleteKeys)
 
 -- | The authoritative source of which built structures currently exist.
 --
 -- The two type parameters, `b` and `a`, correspond
 -- to 'Cell' and 'Entity', respectively.
 data FoundRegistry b a = FoundRegistry
-  { _foundByName :: Map StructureName (NEMap (Cosmic Location) (StructureWithGrid b a))
+  { _foundByName :: Map StructureName (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
   , _foundByLocation :: Map (Cosmic Location) (FoundStructure b a)
   }
 
@@ -52,7 +53,7 @@ emptyFoundStructures = FoundRegistry mempty mempty
 -- | We use a 'NEMap' here so that we can use the
 -- safe-indexing function 'indexWrapNonEmpty' in the implementation
 -- of the @structure@ command.
-foundByName :: FoundRegistry b a -> Map StructureName (NEMap (Cosmic Location) (StructureWithGrid b a))
+foundByName :: FoundRegistry b a -> Map StructureName (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
 foundByName = _foundByName
 
 -- | This is a worldwide "mask" that prevents members of placed
@@ -72,15 +73,16 @@ removeStructure fs (FoundRegistry byName byLoc) =
   allOccupiedCoords = genOccupiedCoords fs
   structureName = name . originalItem . entityGrid $ structureWithGrid fs
   upperLeft = upperLeftCorner fs
+  rotation = rotatedTo $ structureWithGrid fs
 
   -- NOTE: Observe similarities to
   -- Swarm.Game.State.removeRobotFromLocationMap
-  tidyDelete = NEM.nonEmptyMap . NEM.delete upperLeft
+  tidyDelete = NEM.nonEmptyMap . NEM.delete (upperLeft, rotation)
 
 addFound :: FoundStructure b a -> FoundRegistry b a -> FoundRegistry b a
 addFound fs@(PositionedStructure loc swg) (FoundRegistry byName byLoc) =
   FoundRegistry
-    (M.insertWith (<>) k (NEM.singleton loc swg) byName)
+    (M.insertWith (<>) k (NEM.singleton (loc, rotatedTo swg) swg) byName)
     (M.union occupationMap byLoc)
  where
   k = name . originalItem $ entityGrid swg
@@ -115,7 +117,7 @@ populateStaticFoundStructures allFound =
   byLocation = M.unions $ map mkOccupationMap resolvedCollisions
 
   byName =
-    M.map (NEM.fromList . NE.map (upperLeftCorner &&& structureWithGrid)) $
+    M.map (NEM.fromList . NE.map ((upperLeftCorner &&& rotatedTo . structureWithGrid) &&& structureWithGrid)) $
       binTuples $
         map (name . originalItem . entityGrid . structureWithGrid &&& id) resolvedCollisions
 

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs

@@ -6,12 +6,14 @@
 -- See "Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute" for
 -- details of the structure recognition process.
 module Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking (
+  RecognitionActiveStatus (..),
   entityModified,
+  entityModifiedLoggable,
 ) where
 
 import Control.Arrow (left, (&&&))
-import Control.Lens ((%~), (&), (^.))
-import Control.Monad (foldM, guard, unless)
+import Control.Lens ((%~), (&), (.~), (^.))
+import Control.Monad (foldM, forM_, guard, unless)
 import Control.Monad.Extra (findM)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
@@ -44,12 +46,20 @@ import Swarm.Game.Scenario.Topography.Terraform
 import Swarm.Game.Universe
 import Text.AhoCorasick
 
+data RecognitionActiveStatus
+  = RecognizeNewStructures
+  | -- | Do not add new recognitions to the registry.
+    -- This is useful if one needs to construct a larger structure
+    -- for which other smaller structures contained within it
+    -- would otherwise be recognized first, precluding the larger
+    -- structure from ever being recognized.
+    -- Removing elements of a previously recognized structure
+    -- will still cause it to be removed from the registry.
+    DisableNewRecognition
+  deriving (Show, Eq, Ord, Enum, Bounded)
+
 -- | A hook called from the centralized entity update function,
 -- 'Swarm.Game.Step.Util.updateEntityAt'.
---
--- This handles structure detection upon addition of an entity,
--- and structure de-registration upon removal of an entity.
--- Also handles atomic entity swaps.
 entityModified ::
   (Monad s, Hashable a, Eq b) =>
   GenericEntLocator s a ->
@@ -59,39 +69,56 @@ entityModified ::
   RecognitionState b a ->
   s (RecognitionState b a)
 entityModified entLoader modification cLoc autoRecognizer oldRecognitionState = do
-  (val, accumulatedLogs) <- runWriterT $ case modification of
-    Add newEntity -> doAddition newEntity oldRecognitionState
-    Remove _ -> doRemoval
-    Swap _ newEntity -> doRemoval >>= doAddition newEntity
+  (val, accumulatedLogs) <-
+    runWriterT $
+      entityModifiedLoggable RecognizeNewStructures entLoader modification cLoc autoRecognizer oldRecognitionState
   return $
     val
       & recognitionLog %~ (reverse accumulatedLogs <>)
+
+-- | This handles structure detection upon addition of an entity,
+-- and structure de-registration upon removal of an entity.
+-- Also handles atomic entity swaps.
+entityModifiedLoggable ::
+  (Monoid (f (SearchLog a)), Monad m, Hashable a, Eq b, Applicative f) =>
+  RecognitionActiveStatus ->
+  (Cosmic Location -> m (AtomicKeySymbol a)) ->
+  CellModification a ->
+  Cosmic Location ->
+  RecognizerAutomatons b a ->
+  RecognitionState b a ->
+  WriterT (f (SearchLog a)) m (RecognitionState b a)
+entityModifiedLoggable activeStatus entLoader modification cLoc autoRecognizer oldRecognitionState = do
+  case modification of
+    Add newEntity -> doAddition newEntity oldRecognitionState
+    Remove _ -> doRemoval oldRecognitionState
+    Swap _ newEntity -> doRemoval oldRecognitionState >>= doAddition newEntity
  where
   entLookup = autoRecognizer ^. automatonsByEntity
 
-  doAddition newEntity =
-    maybe return logAndRegister $ HM.lookup newEntity entLookup
+  doAddition newEntity = case activeStatus of
+    RecognizeNewStructures -> maybe return logAndRegister $ HM.lookup newEntity entLookup
+    DisableNewRecognition -> return
    where
     logAndRegister finder s = do
       tell . pure . FoundParticipatingEntity $
         ParticipatingEntity
           newEntity
           (finder ^. inspectionOffsets)
-      registerRowMatches entLoader cLoc finder s
+      newFoundStructures <- registerRowMatches entLoader cLoc finder $ s ^. foundStructures
+      return $ s & foundStructures .~ newFoundStructures
 
-  doRemoval =
+  doRemoval sOld =
     -- Entity was removed; may need to remove registered structure.
-    f oldRecognitionState
+    maybe return logAndRemove structureAtLoc sOld
    where
-    f = maybe return logAndRemove $ M.lookup cLoc $ foundByLocation structureRegistry
+    structureAtLoc = M.lookup cLoc $ foundByLocation $ sOld ^. foundStructures
     logAndRemove fs s = do
       tell $ pure $ StructureRemoved structureName
       return $ s & foundStructures %~ removeStructure fs
      where
       structureName = name . originalItem . entityGrid $ structureWithGrid fs
 
-    structureRegistry = oldRecognitionState ^. foundStructures
-
 -- | In case this cell would match a candidate structure,
 -- ensures that the entity in this cell is not already
 -- participating in a registered structure.
@@ -232,9 +259,9 @@ registerRowMatches ::
   GenericEntLocator s a ->
   Cosmic Location ->
   AutomatonInfo b a ->
-  RecognitionState b a ->
-  WriterT (f (SearchLog a)) s (RecognitionState b a)
-registerRowMatches entLoader cLoc (AutomatonInfo horizontalOffsets pwMatcher) rState = do
+  FoundRegistry b a ->
+  WriterT (f (SearchLog a)) s (FoundRegistry b a)
+registerRowMatches entLoader cLoc (AutomatonInfo horizontalOffsets pwMatcher) registry = do
   tell $ pure $ StartSearchAt cLoc horizontalOffsets
 
   tell . pure . ExpectedChunks $
@@ -268,15 +295,17 @@ registerRowMatches entLoader cLoc (AutomatonInfo horizontalOffsets pwMatcher) rS
   -- and now choose the first one that is verified.
   maybeIntactStructure <- findM validateIntactness2d rankedCandidates
 
-  lift $ registerBestStructureMatch maybeIntactStructure rState
+  forM_ maybeIntactStructure $
+    tell . pure . RecognizedSingleStructure . getStructInfo
+
+  return $ maybe id addFound maybeIntactStructure registry
  where
-  registry = rState ^. foundStructures
   PiecewiseRecognition pwSM rowChunkReferences = pwMatcher
 
   getStructInfo (PositionedStructure loc swg) = (distillLabel swg, loc)
 
   validateIntactness2d fs = do
-    maybeIntactnessFailure <- lift $ ensureStructureIntact (rState ^. foundStructures) entLoader fs
+    maybeIntactnessFailure <- lift $ ensureStructureIntact registry entLoader fs
     tell . pure . ChunkIntactnessVerification
       $ IntactPlacementLog
         maybeIntactnessFailure
@@ -341,13 +370,3 @@ findCoveringOffsets possibleOffsets x =
 isCoveredWithOffset :: FoundAndExpectedChunkPositions -> Int -> Bool
 isCoveredWithOffset (FoundAndExpectedChunkPositions found expected) offset =
   NEIS.map (+ offset) expected `NEIS.isSubsetOf` found
-
-registerBestStructureMatch ::
-  (Monad s, Eq a, Eq b) =>
-  Maybe (FoundStructure b a) ->
-  RecognitionState b a ->
-  s (RecognitionState b a)
-registerBestStructureMatch maybeValidCandidate oldState =
-  return $
-    oldState
-      & foundStructures %~ maybe id addFound maybeValidCandidate

test/integration/Main.hs

@@ -477,6 +477,7 @@ testScenarioSolutions rs ui key =
             , 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/1575-structure-recognizer/2229-position-uniqueness-multiple-orientations"
             ]
         ]
     , testSolution' Default "Testing/1430-built-robot-ownership" CheckForBadErrors $ \g -> do