refactor

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,12 @@ 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.Grid
 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 +342,7 @@ data Discovery = Discovery
   , _availableCommands :: Notifications Const
   , _knownEntities :: S.Set EntityName
   , _gameAchievements :: Map GameplayAchievement Attainment
-  , _structureRecognition :: StructureRecognizer (Maybe Cell) Entity
+  , _structureRecognition :: RecognitionState (NonEmptyGrid (Maybe Cell)) Entity
   , _tagMembers :: Map Text (NonEmpty EntityName)
   }
 
@@ -365,7 +365,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 +446,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