refactor in preparation for new structure recognizer (#2209)

* Create a util function `adaptGameState` to simplify code in `updateEntityAt`
* Relocate and modify the `ensureStructureIntact` function to return the position of the first non-matching cell
* Supply width in the `StructureWithGrid` record

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

@@ -15,7 +15,6 @@ import Control.Effect.Lens (view)
 import Control.Effect.Lift (Has)
 import Control.Effect.State (State)
 import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=))
-import Data.Foldable.Extra (allM)
 import Data.IntMap qualified as IM
 import Data.List (partition)
 import Data.List.NonEmpty (NonEmpty)
@@ -25,7 +24,6 @@ import Data.Map qualified as M
 import Data.Maybe (isNothing)
 import Data.Set qualified as S
 import Data.Text (Text)
-import Linear (V2 (..))
 import Swarm.Game.CESK (finalValue, initMachine)
 import Swarm.Game.Device (getCapabilitySet, getMap)
 import Swarm.Game.Entity
@@ -50,7 +48,7 @@ import Swarm.Game.State
 import Swarm.Game.State.Landscape (mkLandscape)
 import Swarm.Game.State.Robot (setRobotInfo)
 import Swarm.Game.State.Substate
-import Swarm.Game.Universe as U (offsetBy)
+import Swarm.Game.Step.Util (adaptGameState)
 import Swarm.Game.World.Gen (Seed)
 import Swarm.Language.Capability (constCaps)
 import Swarm.Language.Syntax (allConst, erase)
@@ -183,8 +181,9 @@ mkRecognizer ::
   StaticStructureInfo Cell ->
   m (StructureRecognizer (Maybe Cell) Entity)
 mkRecognizer structInfo@(StaticStructureInfo structDefs _) = do
-  foundIntact <- mapM (sequenceA . (id &&& ensureStructureIntact)) allPlaced
-  let fs = populateStaticFoundStructures . map fst . filter snd $ foundIntact
+  foundIntact <- mapM (sequenceA . (id &&& adaptGameState . ensureStructureIntact mtlEntityAt)) allPlaced
+
+  let fs = populateStaticFoundStructures . map fst . filter (null . snd) $ foundIntact
   return
     $ StructureRecognizer
       (mkAutomatons cellToEntity structDefs)
@@ -199,24 +198,6 @@ mkRecognizer structInfo@(StaticStructureInfo structDefs _) = do
       ((getName . originalDefinition . structureWithGrid) x)
       (upperLeftCorner x)
 
--- | Matches definitions against the placements.
--- Fails fast (short-circuits) if a non-matching
--- cell is encountered.
-ensureStructureIntact ::
-  (Has (State GameState) sig m) =>
-  FoundStructure (Maybe Cell) Entity ->
-  m Bool
-ensureStructureIntact (FoundStructure (StructureWithGrid _ _ grid) upperLeft) =
-  allM outer $ zip [0 ..] grid
- where
-  outer (y, row) = allM (inner y) $ zip [0 ..] row
-  inner y (x, maybeTemplateEntity) = case maybeTemplateEntity of
-    Nothing -> return True
-    Just _ ->
-      fmap (== maybeTemplateEntity) $
-        entityAt $
-          upperLeft `offsetBy` V2 x (negate y)
-
 buildTagMap :: EntityMap -> Map Text (NonEmpty EntityName)
 buildTagMap em =
   binTuples expanded

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

@@ -62,6 +62,15 @@ lookInDirection d = do
   let nextLoc = loc `offsetBy` newHeading
   (nextLoc,) <$> entityAt nextLoc
 
+adaptGameState ::
+  Has (State GameState) sig m =>
+  TS.State GameState b ->
+  m b
+adaptGameState f = do
+  (newRecognizer, newGS) <- TS.runState f <$> get
+  put newGS
+  return newRecognizer
+
 -- | Modify the entity (if any) at a given location.
 updateEntityAt ::
   (Has (State Robot) sig m, Has (State GameState) sig m) =>
@@ -77,14 +86,9 @@ updateEntityAt cLoc@(Cosmic subworldName loc) upd = do
     currentTick <- use $ temporal . ticks
     myID <- use robotID
     zoomRobots $ wakeWatchingRobots myID currentTick cLoc
-    oldRecognizer <- use $ discovery . structureRecognition
-
-    oldGS <- get @GameState
-    let (newRecognizer, newGS) =
-          flip TS.runState oldGS $
-            SRT.entityModified mtlEntityAt modType cLoc oldRecognizer
-    put newGS
 
+    oldRecognizer <- use $ discovery . structureRecognition
+    newRecognizer <- adaptGameState $ SRT.entityModified mtlEntityAt modType cLoc oldRecognizer
     discovery . structureRecognition .= newRecognizer
 
     pcr <- use $ pathCaching . pathCachingRobots

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

@@ -70,7 +70,7 @@ data ParticipatingEntity e = ParticipatingEntity
   deriving (Functor, Generic, ToJSON)
 
 data IntactPlacementLog = IntactPlacementLog
-  { isIntact :: Bool
+  { intactnessFailure :: Maybe StructureIntactnessFailure
   , sName :: OriginalName
   , locUpperLeft :: Cosmic Location
   }

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

@@ -34,18 +34,29 @@ module Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute (
   -- * Main external interface
   mkAutomatons,
 
+  -- * Types
+  GenericEntLocator,
+
   -- * Helper functions
   populateStaticFoundStructures,
   getEntityGrid,
   lookupStaticPlacements,
+  ensureStructureIntact,
 ) where
 
 import Control.Arrow ((&&&))
+import Control.Monad (forM_, unless)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Except (except, runExceptT)
+import Data.Either.Combinators (leftToMaybe)
 import Data.Hashable (Hashable)
 import Data.Map qualified as M
 import Data.Maybe (catMaybes, mapMaybe)
 import Data.Set qualified as Set
-import Swarm.Game.Scenario.Topography.Grid (getRows)
+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.Structure.Named
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Prep (
@@ -56,10 +67,19 @@ import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (
  )
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Static
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
-import Swarm.Game.Universe (Cosmic (..))
+import Swarm.Game.Universe (Cosmic (..), offsetBy)
+import Swarm.Game.World.Coords (coordsToLoc)
 import Swarm.Language.Syntax.Direction (AbsoluteDir)
 import Swarm.Util (histogram)
 
+-- | Interface that provides monadic access to
+-- querying entities at locations.
+-- The provider may be a 'State' monad or just
+-- a 'Reader'.
+--
+-- 's' is the state variable, 'a' is the return type.
+type GenericEntLocator s a = Cosmic Location -> s (Maybe a)
+
 getEntityGrid :: (Maybe b -> Maybe a) -> NamedGrid (Maybe b) -> [[Maybe a]]
 getEntityGrid extractor = getRows . fmap extractor . structure
 
@@ -92,8 +112,9 @@ extractOrientedGrid ::
   AbsoluteDir ->
   StructureWithGrid (Maybe b) a
 extractOrientedGrid extractor x d =
-  StructureWithGrid wrapped d $ getEntityGrid extractor g
+  StructureWithGrid wrapped d w $ getEntityGrid extractor g
  where
+  w = RowWidth . rectWidth . getGridDimensions $ structure g
   wrapped = NamedOriginal (getStructureName $ name x) x
   g = applyOrientationTransform (Orientation d False) <$> x
 
@@ -124,3 +145,29 @@ lookupStaticPlacements extractor (StaticStructureInfo structDefs thePlacements)
     g (LocatedStructure theName d loc) = do
       sGrid <- M.lookup theName definitionMap
       return $ FoundStructure (extractOrientedGrid extractor sGrid d) $ Cosmic subworldName loc
+
+-- | Matches definitions against the placements.
+-- Fails fast (short-circuits) if a non-matching
+-- cell is encountered.
+--
+-- Returns 'Nothing' if there is no discrepancy between the match subject and world content.
+-- Returns the first observed mismatch cell otherwise.
+ensureStructureIntact ::
+  (Monad s, Hashable a) =>
+  GenericEntLocator s a ->
+  FoundStructure b a ->
+  s (Maybe StructureIntactnessFailure)
+ensureStructureIntact entLoader (FoundStructure (StructureWithGrid _ _ (RowWidth w) grid) upperLeft) = do
+  fmap leftToMaybe . runExceptT . mapM checkLoc $ zip [0 ..] allLocPairs
+ where
+  checkLoc (idx, (maybeTemplateEntity, loc)) =
+    forM_ maybeTemplateEntity $ \x -> do
+      e <- lift $ entLoader loc
+      unless (e == Just x)
+        . except
+        . Left
+        . StructureIntactnessFailure idx
+        $ fromIntegral w * length grid
+
+  f = fmap ((upperLeft `offsetBy`) . asVector . coordsToLoc) . swap
+  allLocPairs = mapIndexedMembers (curry f) $ mkGrid grid

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

@@ -47,7 +47,7 @@ mkRowLookup neList =
       concatMap (concatMap catMaybes . fst) tuples
 
   deriveRowOffsets :: StructureRow b a -> InspectionOffsets
-  deriveRowOffsets (StructureRow (StructureWithGrid _ _ g) rwIdx _) =
+  deriveRowOffsets (StructureRow (StructureWithGrid _ _ _ g) rwIdx _) =
     mkOffsets rwIdx g
 
   bounds = sconcat $ NE.map deriveRowOffsets neList

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

@@ -28,20 +28,13 @@ import Linear (V2 (..))
 import Swarm.Game.Location (Location)
 import Swarm.Game.Scenario.Topography.Structure.Recognition
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Log
+import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute (GenericEntLocator)
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
 import Swarm.Game.Scenario.Topography.Terraform
 import Swarm.Game.Universe
 import Text.AhoCorasick
 
--- | Interface that provides monadic access to
--- querying entities at locations.
--- The provider may be a 'State' monad or just
--- a 'Reader'.
---
--- 's' is the state variable, 'a' is the return type.
-type GenericEntLocator s a = Cosmic Location -> s (Maybe a)
-
 -- | A hook called from the centralized entity update function,
 -- 'Swarm.Game.Step.Util.updateEntityAt'.
 --

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

@@ -112,6 +112,9 @@ data SingleRowEntityOccurrences b a = SingleRowEntityOccurrences
   , expandedOffsets :: InspectionOffsets
   }
 
+newtype RowWidth = RowWidth Int32
+  deriving (Eq)
+
 -- | A a specific row within a particular structure.
 --
 -- === Example
@@ -152,6 +155,7 @@ data NamedOriginal b = NamedOriginal
 data StructureWithGrid b a = StructureWithGrid
   { originalDefinition :: NamedOriginal b
   , rotatedTo :: AbsoluteDir
+  , gridWidth :: RowWidth
   , entityGrid :: [SymbolSequence a]
   }
   deriving (Eq)
@@ -228,6 +232,12 @@ data FoundStructure b a = FoundStructure
   }
   deriving (Eq)
 
+data StructureIntactnessFailure = StructureIntactnessFailure
+  { failedOnIndex :: Int
+  , totalSize :: Int
+  }
+  deriving (Generic, ToJSON)
+
 -- | Ordering is by increasing preference between simultaneously
 -- completed structures.
 -- The preference heuristic is for:

swarm.cabal

@@ -497,6 +497,7 @@ library swarm-topography
     JuicyPixels,
     aeson,
     array,
+    either,
     base,
     containers,
     extra,