More generic structure recognition

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

@@ -66,6 +66,7 @@ module Swarm.Game.State (
   genMultiWorld,
   genRobotTemplates,
   entityAt,
+  mtlEntityAt,
   contentAt,
   zoomWorld,
   zoomRobots,
@@ -78,6 +79,7 @@ import Control.Effect.State (State)
 import Control.Effect.Throw
 import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=))
 import Control.Monad (forM, join)
+import Control.Monad.Trans.State.Strict qualified as TS
 import Data.Aeson (ToJSON)
 import Data.Digest.Pure.SHA (sha1, showDigest)
 import Data.Foldable (toList)
@@ -94,6 +96,7 @@ import Data.Text qualified as T (drop, take)
 import Data.Text.IO qualified as TIO
 import Data.Text.Lazy qualified as TL
 import Data.Text.Lazy.Encoding qualified as TL
+import Data.Tuple (swap)
 import GHC.Generics (Generic)
 import Swarm.Game.CESK (Store, emptyStore, store, suspendedEnv)
 import Swarm.Game.Entity
@@ -473,6 +476,15 @@ initGameState gsc =
     , _messageInfo = initMessages
     }
 
+-- | Provide an entity accessor via the MTL transformer State API.
+-- This is useful for the structure recognizer.
+mtlEntityAt :: Cosmic Location -> TS.State GameState (Maybe Entity)
+mtlEntityAt = TS.state . runGetEntity
+ where
+  runGetEntity :: Cosmic Location -> GameState -> (Maybe Entity, GameState)
+  runGetEntity loc gs =
+    swap . run . Fused.runState gs $ entityAt loc
+
 -- | Get the entity (if any) at a given location.
 entityAt :: (Has (State GameState) sig m) => Cosmic Location -> m (Maybe Entity)
 entityAt (Cosmic subworldName loc) =

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

@@ -182,9 +182,10 @@ mkRecognizer ::
 mkRecognizer structInfo@(StaticStructureInfo structDefs _) = do
   foundIntact <- mapM (sequenceA . (id &&& ensureStructureIntact)) allPlaced
   let fs = populateStaticFoundStructures . map fst . filter snd $ foundIntact
-  return $
-    StructureRecognizer
+  return
+    $ StructureRecognizer
       (mkAutomatons structDefs)
+    $ RecognitionState
       fs
       [IntactStaticPlacement $ map mkLogEntry foundIntact]
  where

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

@@ -428,7 +428,10 @@ 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) emptyFoundStructures []
+    , _structureRecognition =
+        StructureRecognizer
+          (RecognizerAutomatons mempty mempty)
+          (RecognitionState emptyFoundStructures [])
     , _tagMembers = mempty
     }
 

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

@@ -64,7 +64,7 @@ import Swarm.Game.Scenario.Topography.Area (getAreaDimensions)
 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.Recognition (automatons, foundStructures)
+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
 import Swarm.Game.State
@@ -567,7 +567,7 @@ execConst runChildProg c vs s k = do
       _ -> badConst
     Structure -> case vs of
       [VText name, VInt idx] -> do
-        registry <- use $ discovery . structureRecognition . foundStructures
+        registry <- use $ discovery . structureRecognition . recognitionState . foundStructures
         let maybeFoundStructures = M.lookup name $ foundByName registry
             mkOutput mapNE = (NE.length xs, bottomLeftCorner)
              where

src/swarm-engine/Swarm/Game/Step/Path/Cache.hs

@@ -44,14 +44,14 @@ import Swarm.Game.Entity
 import Swarm.Game.Location
 import Swarm.Game.Robot
 import Swarm.Game.Robot.Walk
+import Swarm.Game.Scenario.Topography.Terraform
 import Swarm.Game.State
 import Swarm.Game.Step.Path.Cache.DistanceLimit
 import Swarm.Game.Step.Path.Type
 import Swarm.Game.Step.Path.Walkability (checkUnwalkable)
 import Swarm.Game.Step.RobotStepState
 import Swarm.Game.Step.Util.Inspect (robotWithID)
 import Swarm.Game.Universe (Cosmic (..), SubworldName)
-import Swarm.Game.World.Modify
 import Swarm.Util (prependList, tails1)
 import Swarm.Util.RingBuffer qualified as RB
 

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

@@ -16,6 +16,7 @@ import Control.Effect.Lens
 import Control.Monad (forM_, guard, when)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
+import Control.Monad.Trans.State.Strict qualified as TS
 import Data.Array (bounds, (!))
 import Data.IntMap qualified as IM
 import Data.Set qualified as S
@@ -76,7 +77,15 @@ updateEntityAt cLoc@(Cosmic subworldName loc) upd = do
     currentTick <- use $ temporal . ticks
     myID <- use robotID
     zoomRobots $ wakeWatchingRobots myID currentTick cLoc
-    SRT.entityModified modType cLoc
+    oldRecognizer <- use $ discovery . structureRecognition
+
+    oldGS <- get @GameState
+    let (newRecognizer, newGS) =
+          flip TS.runState oldGS $
+            SRT.entityModified mtlEntityAt modType cLoc oldRecognizer
+    put newGS
+
+    discovery . structureRecognition .= newRecognizer
 
     pcr <- use $ pathCaching . pathCachingRobots
     mapM_ (revalidatePathCache cLoc modType) $ IM.toList pcr

src/swarm-scenario/Swarm/Game/World/Modify.hs

@@ -9,6 +9,7 @@ module Swarm.Game.World.Modify where
 import Control.Lens (view)
 import Data.Function (on)
 import Swarm.Game.Entity (Entity, entityHash)
+import Swarm.Game.Scenario.Topography.Terraform
 
 -- | Compare to 'WorldUpdate' in "Swarm.Game.World"
 data CellUpdate e
@@ -19,13 +20,6 @@ getModification :: CellUpdate e -> Maybe (CellModification e)
 getModification (NoChange _) = Nothing
 getModification (Modified x) = Just x
 
-data CellModification e
-  = -- | Fields represent what existed in the cell "before" and "after", in that order.
-    -- The values are guaranteed to be different.
-    Swap e e
-  | Remove e
-  | Add e
-
 classifyModification ::
   -- | before
   Maybe Entity ->

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

@@ -12,14 +12,24 @@ import Swarm.Game.Scenario.Topography.Structure.Recognition.Log
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
 
+-- | State of the structure recognizer that is intended
+-- to be modifiable.
+data RecognitionState b a = RecognitionState
+  { _foundStructures :: FoundRegistry b a
+  -- ^ Records the top-left corner of the found structure
+  , _recognitionLog :: [SearchLog a]
+  }
+
+makeLenses ''RecognitionState
+
 -- |
 -- The type parameters, `b`, and `a`, correspond
 -- to 'StructureCells' and 'Entity', respectively.
 data StructureRecognizer b a = StructureRecognizer
   { _automatons :: RecognizerAutomatons b a
-  , _foundStructures :: FoundRegistry b a
-  -- ^ Records the top-left corner of the found structure
-  , _recognitionLog :: [SearchLog a]
+  -- ^ read-only
+  , _recognitionState :: RecognitionState b a
+  -- ^ mutatable
   }
   deriving (Generic)