initial placement ensure non-overlapping recognition

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

data/scenarios/Testing/_Validation/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.....

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)

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

src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs

@@ -6,6 +6,7 @@ module Swarm.Game.Scenario.Topography.Area where
 
 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 +24,14 @@ data AreaDimensions = AreaDimensions
 getGridDimensions :: Grid a -> AreaDimensions
 getGridDimensions g = getAreaDimensions $ getRows g
 
+getNEGridDimensions :: NonEmptyGrid a -> AreaDimensions
+getNEGridDimensions (NonEmptyGrid xs) =
+  AreaDimensions
+    (fromIntegral $ length firstRow)
+    (fromIntegral $ NE.length xs)
+ where
+  firstRow = NE.head xs
+
 asTuple :: AreaDimensions -> (Int32, Int32)
 asTuple (AreaDimensions x y) = (x, y)
 
@@ -76,6 +85,7 @@ fillGrid (AreaDimensions 0 _) _ = EmptyGrid
 fillGrid (AreaDimensions _ 0) _ = EmptyGrid
 fillGrid (AreaDimensions w h) x =
   Grid
+    . NonEmptyGrid
     . stimes h
     . pure
     . stimes w

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,
+  nonemptyCount,
+  mapIndexedMembersNE,
   mapIndexedMembers,
   allMembers,
-  mapRows,
+  mapRowsNE,
   getRows,
   mkGrid,
 )
 where
 
 import Data.Aeson (ToJSON (..))
+import Data.Int (Int32)
 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
 
+nonemptyCount :: NonEmpty Int32
+nonemptyCount = NE.iterate succ 0
+
+mapIndexedMembersNE :: (Coords -> a -> b) -> NonEmptyGrid a -> NonEmpty b
+mapIndexedMembersNE f (NonEmptyGrid g) =
+  sconcat $ NE.zipWith outer nonemptyCount g
+ where
+  outer i = NE.zipWith (\j -> f (Coords (i, j))) nonemptyCount
+
 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
- where
-  nonemptyCount = NE.iterate succ 0
+mapIndexedMembers f (Grid g) = NE.toList $ mapIndexedMembersNE 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])

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

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)

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 x $ Cosmic subworldName loc
 
 -- | 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 (StructureWithGrid _ _ _ grid) upperLeft) = 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 = mapIndexedMembersNE (curry f) grid

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
@@ -107,7 +110,7 @@ mkEntityLookup grids =
     map (\(x, y) -> ConsolidatedRowReferences x y . gridWidth . wholeStructure $ NE.head y)
       . HM.toList
       . binTuplesHM
-      . map (rowContent &&& id)
+      . map (NE.toList . rowContent &&& id)
       $ allStructureRows grids
 
 -- | Utilizes the convenient 'wordsBy' function