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,8 +200,7 @@ mkRecognizer structInfo@(StaticStructureInfo structDefs _) = do
   mkLogEntry (x, intact) =
     IntactPlacementLog
       intact
-      ((getName . originalDefinition . structureWithGrid) x)
-      (upperLeftCorner x)
+      $ FoundStructure (upperLeftCorner x) ((distillLabel . structureWithGrid) x)
 
 buildTagMap :: EntityMap -> Map Text (NonEmpty EntityName)
 buildTagMap em =

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

@@ -59,10 +59,11 @@ 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 (..))
+import Swarm.Game.Scenario.Topography.Structure.Named (StructureName (..))
 import Swarm.Game.Scenario.Topography.Structure.Recognition (automatons, foundStructures, recognitionState)
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (foundByName)
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
@@ -549,21 +550,21 @@ execConst runChildProg c vs s k = do
     Structure -> case vs of
       [VText name, VInt idx] -> do
         registry <- use $ discovery . structureRecognition . recognitionState . foundStructures
-        let maybeFoundStructures = M.lookup name $ foundByName registry
+        let maybeFoundStructures = M.lookup (StructureName name) $ foundByName registry
             mkOutput mapNE = (NE.length xs, bottomLeftCorner)
              where
               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
       _ -> badConst
     Floorplan -> case vs of
       [VText name] -> do
         structureTemplates <- use $ discovery . structureRecognition . automatons . originalStructureDefinitions
-        let maybeStructure = M.lookup name structureTemplates
+        let maybeStructure = M.lookup (StructureName name) structureTemplates
         structureDef <-
           maybeStructure
             `isJustOr` cmdExn Floorplan (pure $ T.unwords ["Unknown structure", quote name])

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,10 +4,14 @@
 -- SPDX-License-Identifier: BSD-3-Clause
 module Swarm.Game.Scenario.Topography.Area where
 
+import Data.Aeson (ToJSON)
+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 GHC.Generics (Generic)
 import Linear (V2 (..))
 import Swarm.Game.Location
 import Swarm.Game.Scenario.Topography.Grid
@@ -18,11 +22,19 @@ data AreaDimensions = AreaDimensions
   { rectWidth :: Int32
   , rectHeight :: Int32
   }
-  deriving (Show, Eq)
+  deriving (Show, Eq, Generic, ToJSON)
 
 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 +88,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,84 @@
 -- SPDX-License-Identifier: BSD-3-Clause
 module Swarm.Game.Scenario.Topography.Grid (
   Grid (..),
+  NonEmptyGrid (..),
   gridToVec,
-  mapIndexedMembers,
+  zipNumberedNE,
+  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
+zipNumberedNE ::
+  Integral i =>
+  (i -> a -> b) ->
+  NonEmpty a ->
+  NonEmpty b
+zipNumberedNE f = NE.zipWith f nonemptyCount
+
+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 = zipNumberedNE $ \j -> f (Coords (i, j))
+
+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

@@ -9,21 +9,18 @@
 module Swarm.Game.Scenario.Topography.Placement where
 
 import Data.List.NonEmpty qualified as NE
-import Data.Text (Text)
 import Data.Yaml as Y
-import GHC.Generics (Generic)
 import Swarm.Game.Location
-import Swarm.Game.Scenario.Topography.Area
+import Swarm.Game.Scenario.Topography.Area (
+  AreaDimensions (..),
+ )
 import Swarm.Game.Scenario.Topography.Grid
+import Swarm.Game.Scenario.Topography.Structure.Named (
+  StructureName,
+ )
 import Swarm.Language.Syntax.Direction (AbsoluteDir (..))
 import Swarm.Util (applyWhen)
 
-newtype StructureName = StructureName Text
-  deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)
-
-getStructureName :: StructureName -> Text
-getStructureName (StructureName sn) = sn
-
 -- | Orientation transformations are applied before translation.
 data Orientation = Orientation
   { up :: AbsoluteDir
@@ -57,10 +54,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/ProtoCell.hs

@@ -19,6 +19,7 @@ import Data.Yaml as Y
 import GHC.Generics (Generic)
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointConfig)
 import Swarm.Game.Scenario.Topography.Placement
+import Swarm.Game.Scenario.Topography.Structure.Named (StructureName)
 import Swarm.Util (quote)
 import Swarm.Util.Yaml
 

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/Assembly.hs

@@ -117,8 +117,7 @@ foldLayer structureMap origArea overlays originatedWaypoints =
 
   wrapPlacement (Placed z ns) =
     LocatedStructure
-      (name ns)
-      (up $ orient structPose)
+      (OrientedStructure (name ns) (up $ orient structPose))
       (offset structPose)
    where
     structPose = structurePose z

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

@@ -4,10 +4,17 @@ module Swarm.Game.Scenario.Topography.Structure.Named where
 
 import Data.Set (Set)
 import Data.Text (Text)
+import Data.Yaml
+import GHC.Generics (Generic)
 import Swarm.Game.Scenario.Topography.Grid (Grid)
-import Swarm.Game.Scenario.Topography.Placement (StructureName)
 import Swarm.Language.Syntax.Direction (AbsoluteDir)
 
+newtype StructureName = StructureName Text
+  deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)
+
+getStructureName :: StructureName -> Text
+getStructureName (StructureName sn) = sn
+
 data NamedArea a = NamedArea
   { name :: StructureName
   , recognize :: Set AbsoluteDir