Support a generic "original" payload in structure recognizer (#2216)

The recognizer algorithm operates on a `NonEmptyGrid` of `Maybe` elements.  However, there may exist some progenitor object with auxiliary metadata payload that is independent of the algorithm but should be presented along with the final recognized structure.

So long as an "extraction" function is provided that derives the nonempty grid of `a`s from the original object `b`, we can send `b` along for the ride through the algorithm without concern to `b`'s internals.

# Changes

Overall this refactoring makes the code more generic and simpler.

* Build the recognizer automata at scenario parse time
* Enforce grid no emptiness earlier in recognizer construction
* Subsume redundant `_structureDefs` member of `StaticStructureInfo` record with `_staticAutomatons` field
* Make some type signatures in the UI more generic
* Push the conversion from `Cell` to `Entity `further up the pipeline
* Remove some derived `Show` instances (`show`-ing a Scenario is not likely to be useful due to sheer volume of content)

src/swarm-engine/Swarm/Game/ScenarioInfo.hs

@@ -73,7 +73,6 @@ import Witch (into)
 -- | A scenario item is either a specific scenario, or a collection of
 --   scenarios (/e.g./ the scenarios contained in a subdirectory).
 data ScenarioItem = SISingle ScenarioInfoPair | SICollection Text ScenarioCollection
-  deriving (Show)
 
 -- | Retrieve the name of a scenario item.
 scenarioItemName :: ScenarioItem -> Text
@@ -89,7 +88,6 @@ data ScenarioCollection = SC
   { scOrder :: Maybe [FilePath]
   , scMap :: Map FilePath ScenarioItem
   }
-  deriving (Show)
 
 -- | Access and modify 'ScenarioItem's in collection based on their path.
 scenarioItemByPath :: FilePath -> Traversal' ScenarioCollection ScenarioItem
@@ -114,7 +112,7 @@ tutorialsDirname = "Tutorials"
 getTutorials :: ScenarioCollection -> ScenarioCollection
 getTutorials sc = case M.lookup tutorialsDirname (scMap sc) of
   Just (SICollection _ c) -> c
-  _ -> error $ "No tutorials exist: " ++ show sc
+  _ -> error "No tutorials exist"
 
 -- | Canonicalize a scenario path, making it usable as a unique key.
 normalizeScenarioPath ::

src/swarm-engine/Swarm/Game/State/Initialize.hs

@@ -12,9 +12,8 @@ module Swarm.Game.State.Initialize (
 import Control.Arrow (Arrow ((&&&)))
 import Control.Carrier.State.Lazy qualified as Fused
 import Control.Effect.Lens (view)
-import Control.Effect.Lift (Has)
-import Control.Effect.State (State)
-import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=))
+import Control.Lens hiding (view)
+import Data.Hashable (Hashable)
 import Data.IntMap qualified as IM
 import Data.List (partition)
 import Data.List.NonEmpty (NonEmpty)
@@ -24,6 +23,7 @@ import Data.Map qualified as M
 import Data.Maybe (isNothing)
 import Data.Set qualified as S
 import Data.Text (Text)
+import Data.Tuple.Extra (dupe)
 import Swarm.Game.CESK (finalValue, initMachine)
 import Swarm.Game.Device (getCapabilitySet, getMap)
 import Swarm.Game.Entity
@@ -38,12 +38,10 @@ import Swarm.Game.Robot.Concrete
 import Swarm.Game.Scenario
 import Swarm.Game.Scenario.Objective (initCompletion)
 import Swarm.Game.Scenario.Status
-import Swarm.Game.Scenario.Topography.Cell (Cell, cellToEntity)
 import Swarm.Game.Scenario.Topography.Structure.Recognition
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Log
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (emptyFoundStructures)
-import Swarm.Game.Scenario.Topography.Structure.Recognition.Static
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
 import Swarm.Game.State
 import Swarm.Game.State.Landscape (mkLandscape)
@@ -78,14 +76,19 @@ pureScenarioToGameState ::
   GameState
 pureScenarioToGameState scenario theSeed now toRun gsc =
   preliminaryGameState
-    & discovery . structureRecognition .~ recognizer
+    & discovery . structureRecognition .~ recognition
  where
   sLandscape = scenario ^. scenarioLandscape
 
-  recognizer =
-    runIdentity $
-      Fused.evalState preliminaryGameState $
-        mkRecognizer (sLandscape ^. scenarioStructures)
+  -- It may be possible at some point for the game seed to affect whether
+  -- initially-placed structures remain intact, by way of random placements.
+  -- Therefore we run this at 'GameState' initialization time, rather than
+  -- 'Scenario' parse time.
+  recognition =
+    runIdentity
+      . Fused.evalState preliminaryGameState
+      . adaptGameState
+      $ initializeRecognition mtlEntityAt (sLandscape ^. scenarioStructures)
 
   gs = initGameState gsc
   preliminaryGameState =
@@ -184,24 +187,23 @@ pureScenarioToGameState scenario theSeed now toRun gsc =
 -- we don't actually have to "search" for these structures since we are
 -- explicitly given their location; we only need to validate that each
 -- structure remains intact given other, potentially overlapping static placements.
-mkRecognizer ::
-  (Has (State GameState) sig m) =>
-  StaticStructureInfo Cell ->
-  m (StructureRecognizer (Maybe Cell) Entity)
-mkRecognizer structInfo@(StaticStructureInfo structDefs _) = do
+initializeRecognition ::
+  (Monad s, Hashable a, Eq b) =>
+  GenericEntLocator s a ->
+  StaticStructureInfo b a ->
+  s (RecognitionState b a)
+initializeRecognition entLoader structInfo = do
   foundIntact <- mapM checkIntactness allPlaced
 
   let fs = populateStaticFoundStructures . map fst . filter (null . snd) $ foundIntact
-  return
-    $ StructureRecognizer
-      (mkAutomatons cellToEntity structDefs)
-    $ RecognitionState
+  return $
+    RecognitionState
       fs
       [IntactStaticPlacement $ map mkLogEntry foundIntact]
  where
-  checkIntactness = sequenceA . (id &&& adaptGameState . ensureStructureIntact emptyFoundStructures mtlEntityAt)
+  checkIntactness = traverse (ensureStructureIntact emptyFoundStructures entLoader) . dupe
 
-  allPlaced = lookupStaticPlacements cellToEntity structInfo
+  allPlaced = lookupStaticPlacements structInfo
   mkLogEntry (x, intact) =
     IntactPlacementLog
       intact

src/swarm-engine/Swarm/Game/State/Substate.hs

@@ -104,12 +104,10 @@ import Swarm.Game.Recipe (
   outRecipeMap,
  )
 import Swarm.Game.Robot
-import Swarm.Game.Scenario (GameStateInputs (..))
+import Swarm.Game.Scenario (GameStateInputs (..), RecognizableStructureContent)
 import Swarm.Game.Scenario.Objective
-import Swarm.Game.Scenario.Topography.Cell (Cell)
 import Swarm.Game.Scenario.Topography.Structure.Recognition
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (emptyFoundStructures)
-import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (RecognizerAutomatons (..))
 import Swarm.Game.State.Config
 import Swarm.Game.Tick (TickNumber (..))
 import Swarm.Game.World.Gen (Seed)
@@ -342,7 +340,7 @@ data Discovery = Discovery
   , _availableCommands :: Notifications Const
   , _knownEntities :: S.Set EntityName
   , _gameAchievements :: Map GameplayAchievement Attainment
-  , _structureRecognition :: StructureRecognizer (Maybe Cell) Entity
+  , _structureRecognition :: RecognitionState RecognizableStructureContent Entity
   , _tagMembers :: Map Text (NonEmpty EntityName)
   }
 
@@ -365,7 +363,7 @@ knownEntities :: Lens' Discovery (S.Set EntityName)
 gameAchievements :: Lens' Discovery (Map GameplayAchievement Attainment)
 
 -- | Recognizer for robot-constructed structures
-structureRecognition :: Lens' Discovery (StructureRecognizer (Maybe Cell) Entity)
+structureRecognition :: Lens' Discovery (RecognitionState RecognizableStructureContent Entity)
 
 -- | Map from tags to entities that possess that tag
 tagMembers :: Lens' Discovery (Map Text (NonEmpty EntityName))
@@ -446,10 +444,7 @@ initDiscovery =
     , -- This does not need to be initialized with anything,
       -- since the master list of achievements is stored in UIState
       _gameAchievements = mempty
-    , _structureRecognition =
-        StructureRecognizer
-          (RecognizerAutomatons mempty mempty)
-          (RecognitionState emptyFoundStructures [])
+    , _structureRecognition = RecognitionState emptyFoundStructures []
     , _tagMembers = mempty
     }
 

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

@@ -59,12 +59,12 @@ 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, getNEGridDimensions, rectHeight)
+import Swarm.Game.Scenario.Topography.Area (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 (foundStructures)
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (foundByName)
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
 import Swarm.Game.State
@@ -549,26 +549,26 @@ execConst runChildProg c vs s k = do
       _ -> badConst
     Structure -> case vs of
       [VText name, VInt idx] -> do
-        registry <- use $ discovery . structureRecognition . recognitionState . foundStructures
+        registry <- use $ discovery . structureRecognition . foundStructures
         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 $ negate (rectHeight (getNEGridDimensions $ entityGrid struc) - 1)
+              offsetHeight = V2 0 $ negate (rectHeight (getNEGridDimensions $ extractedGrid $ 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
+        structureTemplates <- use $ landscape . recognizerAutomatons . originalStructureDefinitions
         let maybeStructure = M.lookup (StructureName name) structureTemplates
         structureDef <-
           maybeStructure
             `isJustOr` cmdExn Floorplan (pure $ T.unwords ["Unknown structure", quote name])
-        return . mkReturn . getAreaDimensions $ entityProcessedGrid structureDef
+        return . mkReturn . getNEGridDimensions $ entityProcessedGrid structureDef
       _ -> badConst
     HasTag -> case vs of
       [VText eName, VText tName] -> do

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

@@ -30,6 +30,7 @@ import Swarm.Game.Location
 import Swarm.Game.Robot
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking qualified as SRT
 import Swarm.Game.State
+import Swarm.Game.State.Landscape (recognizerAutomatons)
 import Swarm.Game.State.Robot
 import Swarm.Game.State.Substate
 import Swarm.Game.Step.Path.Cache
@@ -87,9 +88,10 @@ updateEntityAt cLoc@(Cosmic subworldName loc) upd = do
     myID <- use robotID
     zoomRobots $ wakeWatchingRobots myID currentTick cLoc
 
-    oldRecognizer <- use $ discovery . structureRecognition
-    newRecognizer <- adaptGameState $ SRT.entityModified mtlEntityAt modType cLoc oldRecognizer
-    discovery . structureRecognition .= newRecognizer
+    structureRecognizer <- use $ landscape . recognizerAutomatons
+    oldRecognition <- use $ discovery . structureRecognition
+    newRecognition <- adaptGameState $ SRT.entityModified mtlEntityAt modType cLoc structureRecognizer oldRecognition
+    discovery . structureRecognition .= newRecognition
 
     pcr <- use $ pathCaching . pathCachingRobots
     mapM_ (revalidatePathCache cLoc modType) $ IM.toList pcr

src/swarm-scenario/Swarm/Game/Scenario.hs

@@ -17,8 +17,8 @@ module Swarm.Game.Scenario (
   Scenario (..),
   ScenarioLandscape (..),
   ScenarioMetadata (ScenarioMetadata),
+  RecognizableStructureContent,
   staticPlacements,
-  structureDefs,
 
   -- ** Fields
   scenarioMetadata,
@@ -86,14 +86,16 @@ import Swarm.Game.Scenario.Objective.Validation
 import Swarm.Game.Scenario.RobotLookup
 import Swarm.Game.Scenario.Style
 import Swarm.Game.Scenario.Topography.Cell
+import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Scenario.Topography.Navigation.Portal
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint (Parentage (..))
 import Swarm.Game.Scenario.Topography.Structure qualified as Structure
 import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly
 import Swarm.Game.Scenario.Topography.Structure.Named qualified as Structure
 import Swarm.Game.Scenario.Topography.Structure.Overlay
-import Swarm.Game.Scenario.Topography.Structure.Recognition.Static
-import Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry
+import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute
+import Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry (renderRedundancy)
+import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
 import Swarm.Game.Scenario.Topography.WorldDescription
 import Swarm.Game.Terrain
 import Swarm.Game.Universe
@@ -181,6 +183,8 @@ scenarioSolution :: Lens' ScenarioOperation (Maybe TSyntax)
 --   take during a single tick.
 scenarioStepsPerTick :: Lens' ScenarioOperation (Maybe Int)
 
+type RecognizableStructureContent = NonEmptyGrid (Maybe Cell)
+
 -- | All cosmetic and structural content of the scenario.
 data ScenarioLandscape = ScenarioLandscape
   { _scenarioSeed :: Maybe Int
@@ -190,10 +194,9 @@ data ScenarioLandscape = ScenarioLandscape
   , _scenarioKnown :: Set EntityName
   , _scenarioWorlds :: NonEmpty WorldDescription
   , _scenarioNavigation :: Navigation (M.Map SubworldName) Location
-  , _scenarioStructures :: StaticStructureInfo Cell
+  , _scenarioStructures :: StaticStructureInfo RecognizableStructureContent Entity
   , _scenarioRobots :: [TRobot]
   }
-  deriving (Show)
 
 makeLensesNoSigs ''ScenarioLandscape
 
@@ -220,7 +223,7 @@ scenarioKnown :: Lens' ScenarioLandscape (Set EntityName)
 scenarioWorlds :: Lens' ScenarioLandscape (NonEmpty WorldDescription)
 
 -- | Information required for structure recognition
-scenarioStructures :: Lens' ScenarioLandscape (StaticStructureInfo Cell)
+scenarioStructures :: Lens' ScenarioLandscape (StaticStructureInfo RecognizableStructureContent Entity)
 
 -- | Waypoints and inter-world portals
 scenarioNavigation :: Lens' ScenarioLandscape (Navigation (M.Map SubworldName) Location)
@@ -236,7 +239,6 @@ data Scenario = Scenario
   , _scenarioOperation :: ScenarioOperation
   , _scenarioLandscape :: ScenarioLandscape
   }
-  deriving (Show)
 
 makeLensesNoSigs ''Scenario
 
@@ -355,10 +357,15 @@ instance FromJSONE ScenarioInputs Scenario where
           namedGrids = map stuffGrid mergedStructures
           recognizableGrids = filter Structure.isRecognizable namedGrids
 
-      symmetryAnnotatedGrids <- mapM checkSymmetry recognizableGrids
+          -- We exclude empty grids from the recognition engine.
+          nonEmptyRecognizableGrids = mapMaybe (traverse getNonEmptyGrid) recognizableGrids
+
+      myAutomatons <-
+        either (fail . T.unpack . renderRedundancy) return $
+          mkAutomatons (fmap cellToEntity) nonEmptyRecognizableGrids
 
       let structureInfo =
-            StaticStructureInfo symmetryAnnotatedGrids
+            StaticStructureInfo myAutomatons
               . M.fromList
               . NE.toList
               $ NE.map (worldName &&& placedStructures) allWorlds

src/swarm-scenario/Swarm/Game/State/Landscape.hs

@@ -13,6 +13,7 @@ module Swarm.Game.State.Landscape (
   multiWorld,
   worldScrollable,
   terrainAndEntities,
+  recognizerAutomatons,
 
   -- ** Utilities
   initLandscape,
@@ -45,6 +46,7 @@ import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..))
 import Swarm.Game.Scenario.Topography.Structure.Overlay
+import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
 import Swarm.Game.Scenario.Topography.WorldDescription
 import Swarm.Game.State.Config
 import Swarm.Game.Terrain (TerrainType (..), terrainIndexByName)
@@ -63,6 +65,7 @@ data Landscape = Landscape
   { _worldNavigation :: Navigation (M.Map SubworldName) Location
   , _multiWorld :: MultiWorld Int Entity
   , _terrainAndEntities :: TerrainEntityMaps
+  , _recognizerAutomatons :: RecognizerAutomatons RecognizableStructureContent Entity
   , _worldScrollable :: Bool
   }
 
@@ -81,6 +84,9 @@ multiWorld :: Lens' Landscape (MultiWorld Int Entity)
 -- | The catalogs of all terrain and entities that the game knows about.
 terrainAndEntities :: Lens' Landscape TerrainEntityMaps
 
+-- | Recognition engine for predefined structures
+recognizerAutomatons :: Lens' Landscape (RecognizerAutomatons RecognizableStructureContent Entity)
+
 -- | Whether the world map is supposed to be scrollable or not.
 worldScrollable :: Lens' Landscape Bool
 
@@ -92,6 +98,7 @@ initLandscape gsc =
     { _worldNavigation = Navigation mempty mempty
     , _multiWorld = mempty
     , _terrainAndEntities = initEntityTerrain $ gsiScenarioInputs $ initState gsc
+    , _recognizerAutomatons = RecognizerAutomatons mempty mempty
     , _worldScrollable = True
     }
 
@@ -101,6 +108,7 @@ mkLandscape sLandscape worldTuples theSeed =
     { _worldNavigation = sLandscape ^. scenarioNavigation
     , _multiWorld = genMultiWorld worldTuples theSeed
     , _terrainAndEntities = sLandscape ^. scenarioTerrainAndEntities
+    , _recognizerAutomatons = sLandscape ^. scenarioStructures . staticAutomatons
     , -- TODO (#1370): Should we allow subworlds to have their own scrollability?
       -- Leaning toward no, but for now just adopt the root world scrollability
       -- as being universal.

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

@@ -4,12 +4,14 @@ module Swarm.Game.Scenario.Topography.Grid (
   Grid (..),
   NonEmptyGrid (..),
   gridToVec,
-  mapWithCoordsNE,
   mapWithCoords,
+  mapWithCoordsNE,
   allMembers,
+  allMembersNE,
   mapRowsNE,
   getRows,
   mkGrid,
+  getNonEmptyGrid,
 )
 where
 
@@ -44,6 +46,11 @@ mkGrid rows = fromMaybe EmptyGrid $ do
   rowsNE <- NE.nonEmpty =<< mapM NE.nonEmpty rows
   return $ Grid $ NonEmptyGrid rowsNE
 
+getNonEmptyGrid :: Grid a -> Maybe (NonEmptyGrid a)
+getNonEmptyGrid = \case
+  EmptyGrid -> Nothing
+  Grid x -> Just x
+
 getRows :: Grid a -> [[a]]
 getRows EmptyGrid = []
 getRows (Grid (NonEmptyGrid g)) = NE.toList . NE.map NE.toList $ g