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/1575-structure-recognizer/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-scenario/Swarm/Game/State/Landscape.hs

@@ -166,7 +166,7 @@ buildWorld tem WorldDescription {..} =
   -- Get all the robots described in cells and set their locations appropriately
   robots :: SubworldName -> [IndexedTRobot]
   robots swName =
-    concat $ mapIndexedMembers extractRobots g
+    concat $ mapWithCoords extractRobots g
    where
     extractRobots (Coords coordsTuple) maybeCell =
       let robotWithLoc = trobotLocation ?~ Cosmic swName (coordsToLoc (coords `addTuple` coordsTuple))

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

@@ -4,8 +4,10 @@
 -- SPDX-License-Identifier: BSD-3-Clause
 module Swarm.Game.Scenario.Topography.Area where
 
+import Data.Function (on)
 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 +25,14 @@ data AreaDimensions = AreaDimensions
 getGridDimensions :: Grid a -> AreaDimensions
 getGridDimensions g = getAreaDimensions $ getRows g
 
+getNEGridDimensions :: NonEmptyGrid a -> AreaDimensions
+getNEGridDimensions (NonEmptyGrid xs) =
+  (AreaDimensions `on` fromIntegral)
+    (NE.length firstRow)
+    (NE.length xs)
+ where
+  firstRow = NE.head xs
+
 asTuple :: AreaDimensions -> (Int32, Int32)
 asTuple (AreaDimensions x y) = (x, y)
 
@@ -76,6 +86,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,
-  mapIndexedMembers,
+  nonemptyCount,
+  mapWithCoordsNE,
+  mapWithCoords,
   allMembers,
-  mapRows,
+  mapRowsNE,
   getRows,
   mkGrid,
 )
 where
 
 import Data.Aeson (ToJSON (..))
+import Data.Foldable qualified as F
 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
+allMembers g = F.toList g
+
+nonemptyCount :: (Integral i) => NonEmpty i
+nonemptyCount = NE.iterate succ 0
 
-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
+mapWithCoordsNE :: (Coords -> a -> b) -> NonEmptyGrid a -> NonEmpty b
+mapWithCoordsNE f (NonEmptyGrid g) =
+  sconcat $ NE.zipWith outer nonemptyCount g
  where
-  nonemptyCount = NE.iterate succ 0
+  outer i = NE.zipWith (\j -> f (Coords (i, j))) nonemptyCount
+
+mapWithCoords :: (Coords -> a -> b) -> Grid a -> [b]
+mapWithCoords _ EmptyGrid = []
+mapWithCoords f (Grid g) = NE.toList $ mapWithCoordsNE 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.hs

@@ -118,10 +118,10 @@ paintMap maskChar pal g = do
         ]
 
   let cells = fmap standardCell <$> nestedLists
-      wps = catMaybes $ mapIndexedMembers getWp nestedLists
+      wps = catMaybes $ mapWithCoords getWp nestedLists
 
   let extraPlacements =
-        catMaybes $ mapIndexedMembers getStructureMarker nestedLists
+        catMaybes $ mapWithCoords getStructureMarker nestedLists
 
   return (cells, wps, extraPlacements)
  where

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