From f409acade89256248ceff1f63a67494b1c2fcc1c Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Mon, 12 Aug 2024 15:10:27 -0500 Subject: [PATCH] More generic structure recognition (#2112) Builds upon #1836. Most importantly in this PR, the `Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking` module is made generic in its `Entity` parameter, and is now able to be moved from the `swarm-engine` sublibrary to the `swarm-topology` sublibrary. I've also introduced an intermediate `RecognitionState` record inside `StructureRecognizer` to distinguish between the stateful and read-only elements. The `AhoCorasick` dependency is now reduced to only one sublibrary. --- src/swarm-engine/Swarm/Game/State.hs | 12 ++ .../Swarm/Game/State/Initialize.hs | 5 +- src/swarm-engine/Swarm/Game/State/Substate.hs | 5 +- src/swarm-engine/Swarm/Game/Step/Const.hs | 4 +- .../Swarm/Game/Step/Path/Cache.hs | 2 +- src/swarm-engine/Swarm/Game/Step/Util.hs | 11 +- src/swarm-scenario/Swarm/Game/World/Modify.hs | 8 +- .../Topography/Structure/Recognition.hs | 16 +- .../Structure/Recognition/Tracking.hs | 184 +++++++++++------- .../Game/Scenario/Topography/Terraform.hs | 10 + src/swarm-tui/Swarm/TUI/View/CellDisplay.hs | 4 +- src/swarm-tui/Swarm/TUI/View/Structure.hs | 4 +- src/swarm-web/Swarm/Web.hs | 4 +- swarm.cabal | 6 +- 14 files changed, 176 insertions(+), 99 deletions(-) rename src/{swarm-engine => swarm-topography}/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs (53%) create mode 100644 src/swarm-topography/Swarm/Game/Scenario/Topography/Terraform.hs diff --git a/src/swarm-engine/Swarm/Game/State.hs b/src/swarm-engine/Swarm/Game/State.hs index c97d842ad..883ba8dd4 100644 --- a/src/swarm-engine/Swarm/Game/State.hs +++ b/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) = diff --git a/src/swarm-engine/Swarm/Game/State/Initialize.hs b/src/swarm-engine/Swarm/Game/State/Initialize.hs index 90ed84c27..ce968fe20 100644 --- a/src/swarm-engine/Swarm/Game/State/Initialize.hs +++ b/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 diff --git a/src/swarm-engine/Swarm/Game/State/Substate.hs b/src/swarm-engine/Swarm/Game/State/Substate.hs index 6374cb43d..4481fbd79 100644 --- a/src/swarm-engine/Swarm/Game/State/Substate.hs +++ b/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 } diff --git a/src/swarm-engine/Swarm/Game/Step/Const.hs b/src/swarm-engine/Swarm/Game/Step/Const.hs index 36dbb2f44..9c5377e97 100644 --- a/src/swarm-engine/Swarm/Game/Step/Const.hs +++ b/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 diff --git a/src/swarm-engine/Swarm/Game/Step/Path/Cache.hs b/src/swarm-engine/Swarm/Game/Step/Path/Cache.hs index 7ff3138f0..c1b8e8d2c 100644 --- a/src/swarm-engine/Swarm/Game/Step/Path/Cache.hs +++ b/src/swarm-engine/Swarm/Game/Step/Path/Cache.hs @@ -44,6 +44,7 @@ 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 @@ -51,7 +52,6 @@ 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 diff --git a/src/swarm-engine/Swarm/Game/Step/Util.hs b/src/swarm-engine/Swarm/Game/Step/Util.hs index b0382fa90..04f9fddc6 100644 --- a/src/swarm-engine/Swarm/Game/Step/Util.hs +++ b/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 diff --git a/src/swarm-scenario/Swarm/Game/World/Modify.hs b/src/swarm-scenario/Swarm/Game/World/Modify.hs index 99f6fcfb8..5a1167f92 100644 --- a/src/swarm-scenario/Swarm/Game/World/Modify.hs +++ b/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 -> diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs index 63c3aa352..c49906c95 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs +++ b/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) diff --git a/src/swarm-engine/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs similarity index 53% rename from src/swarm-engine/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs rename to src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs index 0a17523c6..18f40b3a1 100644 --- a/src/swarm-engine/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs @@ -9,10 +9,9 @@ module Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking ( entityModified, ) where -import Control.Carrier.State.Lazy -import Control.Effect.Lens -import Control.Lens ((^.)) -import Control.Monad (forM, forM_, guard) +import Control.Lens ((%~), (&), (.~), (^.)) +import Control.Monad (forM, guard) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.HashMap.Strict qualified as HM import Data.HashSet (HashSet) import Data.HashSet qualified as HS @@ -25,19 +24,23 @@ import Data.Maybe (listToMaybe) import Data.Ord (Down (..)) import Data.Semigroup (Max (..), Min (..)) import Linear (V2 (..)) -import Swarm.Game.Entity (Entity) import Swarm.Game.Location (Location) -import Swarm.Game.Scenario (StructureCells) import Swarm.Game.Scenario.Topography.Structure.Recognition import Swarm.Game.Scenario.Topography.Structure.Recognition.Log import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry import Swarm.Game.Scenario.Topography.Structure.Recognition.Type -import Swarm.Game.State -import Swarm.Game.State.Substate +import Swarm.Game.Scenario.Topography.Terraform import Swarm.Game.Universe -import Swarm.Game.World.Modify 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'. -- @@ -45,31 +48,47 @@ import Text.AhoCorasick -- and structure de-registration upon removal of an entity. -- Also handles atomic entity swaps. entityModified :: - (Has (State GameState) sig m) => - CellModification Entity -> + (Monad s, Hashable a, Eq b) => + GenericEntLocator s a -> + CellModification a -> Cosmic Location -> - m () -entityModified modification cLoc = do + StructureRecognizer b a -> + s (StructureRecognizer b a) +entityModified entLoader modification cLoc recognizer = case modification of - Add newEntity -> doAddition newEntity + Add newEntity -> doAddition newEntity recognizer Remove _ -> doRemoval - Swap _ newEntity -> doRemoval >> doAddition newEntity + Swap _ newEntity -> doRemoval >>= doAddition newEntity where - doAddition newEntity = do - entLookup <- use $ discovery . structureRecognition . automatons . automatonsByEntity - forM_ (HM.lookup newEntity entLookup) $ \finder -> do - let msg = FoundParticipatingEntity $ ParticipatingEntity newEntity (finder ^. inspectionOffsets) - discovery . structureRecognition . recognitionLog %= (msg :) - registerRowMatches cLoc finder + entLookup = recognizer ^. automatons . automatonsByEntity + + doAddition newEntity r = do + let oldRecognitionState = r ^. recognitionState + stateRevision <- case HM.lookup newEntity entLookup of + Nothing -> return oldRecognitionState + Just finder -> do + let msg = FoundParticipatingEntity $ ParticipatingEntity newEntity (finder ^. inspectionOffsets) + stateRevision' = oldRecognitionState & recognitionLog %~ (msg :) + + registerRowMatches entLoader cLoc finder stateRevision' + + return $ r & recognitionState .~ stateRevision doRemoval = do -- Entity was removed; may need to remove registered structure. - structureRegistry <- use $ discovery . structureRecognition . foundStructures - forM_ (M.lookup cLoc $ foundByLocation structureRegistry) $ \fs -> do - let structureName = getName $ originalDefinition $ structureWithGrid fs - in do - discovery . structureRecognition . recognitionLog %= (StructureRemoved structureName :) - discovery . structureRecognition . foundStructures %= removeStructure fs + let oldRecognitionState = recognizer ^. recognitionState + structureRegistry = oldRecognitionState ^. foundStructures + stateRevision <- case M.lookup cLoc $ foundByLocation structureRegistry of + Nothing -> return oldRecognitionState + Just fs -> + return $ + oldRecognitionState + & recognitionLog %~ (StructureRemoved structureName :) + & foundStructures %~ removeStructure fs + where + structureName = getName $ originalDefinition $ structureWithGrid fs + + return $ recognizer & recognitionState .~ stateRevision -- | In case this cell would match a candidate structure, -- ensures that the entity in this cell is not already @@ -85,35 +104,35 @@ entityModified modification cLoc = do -- to intrude into the candidate structure's bounding box -- where the candidate structure has empty cells. candidateEntityAt :: - (Has (State GameState) sig m) => + (Monad s, Hashable a) => + GenericEntLocator s a -> + FoundRegistry b a -> -- | participating entities - HashSet Entity -> + HashSet a -> Cosmic Location -> - m (Maybe Entity) -candidateEntityAt participating cLoc = do - registry <- use $ discovery . structureRecognition . foundStructures - if M.member cLoc $ foundByLocation registry - then return Nothing - else do - maybeEnt <- entityAt cLoc - return $ do - ent <- maybeEnt - guard $ HS.member ent participating - return ent + s (Maybe a) +candidateEntityAt entLoader registry participating cLoc = runMaybeT $ do + guard $ M.notMember cLoc $ foundByLocation registry + ent <- MaybeT $ entLoader cLoc + guard $ HS.member ent participating + return ent -- | Excludes entities that are already part of a -- registered found structure. getWorldRow :: - (Has (State GameState) sig m) => + (Monad s, Hashable a) => + GenericEntLocator s a -> + FoundRegistry b a -> -- | participating entities - HashSet Entity -> + HashSet a -> Cosmic Location -> InspectionOffsets -> Int32 -> - m [Maybe Entity] -getWorldRow participatingEnts cLoc (InspectionOffsets (Min offsetLeft) (Max offsetRight)) yOffset = - mapM (candidateEntityAt participatingEnts) horizontalOffsets + s [Maybe a] +getWorldRow entLoader registry participatingEnts cLoc (InspectionOffsets (Min offsetLeft) (Max offsetRight)) yOffset = do + mapM getCandidate horizontalOffsets where + getCandidate = candidateEntityAt entLoader registry participatingEnts horizontalOffsets = map mkLoc [offsetLeft .. offsetRight] -- NOTE: We negate the yOffset because structure rows are numbered increasing from top @@ -123,12 +142,16 @@ getWorldRow participatingEnts cLoc (InspectionOffsets (Min offsetLeft) (Max offs -- | This is the first (one-dimensional) stage -- in a two-stage (two-dimensional) search. registerRowMatches :: - (Has (State GameState) sig m) => + (Monad s, Hashable a, Eq b) => + GenericEntLocator s a -> Cosmic Location -> - AutomatonInfo Entity (AtomicKeySymbol Entity) (StructureSearcher StructureCells Entity) -> - m () -registerRowMatches cLoc (AutomatonInfo participatingEnts horizontalOffsets sm) = do - entitiesRow <- getWorldRow participatingEnts cLoc horizontalOffsets 0 + AutomatonInfo a (AtomicKeySymbol a) (StructureSearcher b a) -> + RecognitionState b a -> + s (RecognitionState b a) +registerRowMatches entLoader cLoc (AutomatonInfo participatingEnts horizontalOffsets sm) rState = do + let registry = rState ^. foundStructures + + entitiesRow <- getWorldRow entLoader registry participatingEnts cLoc horizontalOffsets 0 let candidates = findAll sm entitiesRow mkCandidateLogEntry c = FoundRowCandidate @@ -138,23 +161,34 @@ registerRowMatches cLoc (AutomatonInfo participatingEnts horizontalOffsets sm) = where rowMatchInfo = NE.toList . NE.map (f . myRow) . singleRowItems $ pVal c where - f x = MatchingRowFrom (rowIndex x) $ getName . originalDefinition . wholeStructure $ x + f x = + MatchingRowFrom (rowIndex x) $ + getName . originalDefinition . wholeStructure $ + x logEntry = FoundRowCandidates $ map mkCandidateLogEntry candidates - discovery . structureRecognition . recognitionLog %= (logEntry :) - candidates2D <- forM candidates $ checkVerticalMatch cLoc horizontalOffsets - registerStructureMatches $ concat candidates2D + candidates2D <- + forM candidates $ + checkVerticalMatch entLoader registry cLoc horizontalOffsets + + return $ + registerStructureMatches (concat candidates2D) $ + rState & recognitionLog %~ (logEntry :) +-- | Examines contiguous rows of entities, accounting +-- for the offset of the initially found row. checkVerticalMatch :: - (Has (State GameState) sig m) => + (Monad s, Hashable a) => + GenericEntLocator s a -> + FoundRegistry b a -> Cosmic Location -> -- | Horizontal search offsets InspectionOffsets -> - Position (StructureSearcher StructureCells Entity) -> - m [FoundStructure StructureCells Entity] -checkVerticalMatch cLoc (InspectionOffsets (Min searchOffsetLeft) _) foundRow = - getMatches2D cLoc horizontalFoundOffsets $ automaton2D $ pVal foundRow + Position (StructureSearcher b a) -> + s [FoundStructure b a] +checkVerticalMatch entLoader registry cLoc (InspectionOffsets (Min searchOffsetLeft) _) foundRow = + getMatches2D entLoader registry cLoc horizontalFoundOffsets $ automaton2D $ pVal foundRow where foundLeftOffset = searchOffsetLeft + fromIntegral (pIndex foundRow) foundRightInclusiveIndex = foundLeftOffset + fromIntegral (pLength foundRow) - 1 @@ -164,9 +198,9 @@ getFoundStructures :: Hashable keySymb => (Int32, Int32) -> Cosmic Location -> - StateMachine keySymb (StructureWithGrid StructureCells Entity) -> + StateMachine keySymb (StructureWithGrid b a) -> [keySymb] -> - [FoundStructure StructureCells Entity] + [FoundStructure b a] getFoundStructures (offsetTop, offsetLeft) cLoc sm entityRows = map mkFound candidates where @@ -178,20 +212,24 @@ getFoundStructures (offsetTop, offsetLeft) cLoc sm entityRows = loc = V2 offsetLeft $ negate $ offsetTop + fromIntegral (pIndex candidate) getMatches2D :: - (Has (State GameState) sig m) => + (Monad s, Hashable a) => + GenericEntLocator s a -> + FoundRegistry b a -> Cosmic Location -> -- | Horizontal found offsets (inclusive indices) InspectionOffsets -> - AutomatonInfo Entity (SymbolSequence Entity) (StructureWithGrid StructureCells Entity) -> - m [FoundStructure StructureCells Entity] + AutomatonInfo a (SymbolSequence a) (StructureWithGrid b a) -> + s [FoundStructure b a] getMatches2D + entLoader + registry cLoc horizontalFoundOffsets@(InspectionOffsets (Min offsetLeft) _) (AutomatonInfo participatingEnts (InspectionOffsets (Min offsetTop) (Max offsetBottom)) sm) = do entityRows <- mapM getRow verticalOffsets return $ getFoundStructures (offsetTop, offsetLeft) cLoc sm entityRows where - getRow = getWorldRow participatingEnts cLoc horizontalFoundOffsets + getRow = getWorldRow entLoader registry participatingEnts cLoc horizontalFoundOffsets verticalOffsets = [offsetTop .. offsetBottom] -- | @@ -199,14 +237,14 @@ getMatches2D -- so multiple matches require a tie-breaker. -- The largest structure (by area) shall win. registerStructureMatches :: - (Has (State GameState) sig m) => - [FoundStructure StructureCells Entity] -> - m () -registerStructureMatches unrankedCandidates = do - discovery . structureRecognition . recognitionLog %= (newMsg :) - - forM_ (listToMaybe rankedCandidates) $ \fs -> - discovery . structureRecognition . foundStructures %= addFound fs + (Eq a, Eq b) => + [FoundStructure a b] -> + RecognitionState a b -> + RecognitionState a b +registerStructureMatches unrankedCandidates oldState = + oldState + & (recognitionLog %~ (newMsg :)) + & foundStructures %~ maybe id addFound (listToMaybe rankedCandidates) where -- Sorted by decreasing order of preference. rankedCandidates = sortOn Down unrankedCandidates diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Terraform.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Terraform.hs new file mode 100644 index 000000000..85b3c0531 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Terraform.hs @@ -0,0 +1,10 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Scenario.Topography.Terraform where + +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 diff --git a/src/swarm-tui/Swarm/TUI/View/CellDisplay.hs b/src/swarm-tui/Swarm/TUI/View/CellDisplay.hs index 11caa6124..8d9320c0e 100644 --- a/src/swarm-tui/Swarm/TUI/View/CellDisplay.hs +++ b/src/swarm-tui/Swarm/TUI/View/CellDisplay.hs @@ -33,7 +33,7 @@ import Swarm.Game.Entity import Swarm.Game.Land import Swarm.Game.Robot import Swarm.Game.Scenario.Topography.EntityFacade -import Swarm.Game.Scenario.Topography.Structure.Recognition (foundStructures) +import Swarm.Game.Scenario.Topography.Structure.Recognition (foundStructures, recognitionState) import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (foundByLocation) import Swarm.Game.State import Swarm.Game.State.Landscape @@ -71,7 +71,7 @@ drawLoc ui g cCoords@(Cosmic _ coords) = boldStructure = applyWhen isStructure $ modifyDefAttr (`V.withStyle` V.bold) where - sMap = foundByLocation $ g ^. discovery . structureRecognition . foundStructures + sMap = foundByLocation $ g ^. discovery . structureRecognition . recognitionState . foundStructures isStructure = M.member (coordsToLoc <$> cCoords) sMap -- | Subset of the game state needed to render the world diff --git a/src/swarm-tui/Swarm/TUI/View/Structure.hs b/src/swarm-tui/Swarm/TUI/View/Structure.hs index a34fa374d..1a43a9139 100644 --- a/src/swarm-tui/Swarm/TUI/View/Structure.hs +++ b/src/swarm-tui/Swarm/TUI/View/Structure.hs @@ -24,7 +24,7 @@ import Swarm.Game.Scenario (StructureCells) import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.Placement (getStructureName) import Swarm.Game.Scenario.Topography.Structure qualified as Structure -import Swarm.Game.Scenario.Topography.Structure.Recognition (foundStructures) +import Swarm.Game.Scenario.Topography.Structure.Recognition (foundStructures, recognitionState) import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute (getEntityGrid) import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (foundByName) import Swarm.Game.Scenario.Topography.Structure.Recognition.Type @@ -92,7 +92,7 @@ structureWidget gs s = Structure.description . namedGrid . annotatedGrid $ s - registry = gs ^. discovery . structureRecognition . foundStructures + registry = gs ^. discovery . structureRecognition . recognitionState . foundStructures occurrenceCountSuffix = case M.lookup theName $ foundByName registry of Nothing -> emptyWidget Just inner -> padLeft (Pad 2) . headerItem "Count" . T.pack . show $ NEM.size inner diff --git a/src/swarm-web/Swarm/Web.hs b/src/swarm-web/Swarm/Web.hs index c350d2807..b6b4a577b 100644 --- a/src/swarm-web/Swarm/Web.hs +++ b/src/swarm-web/Swarm/Web.hs @@ -212,12 +212,12 @@ recogLogHandler appStateRef = do appState <- liftIO appStateRef return $ map (fmap (view entityName)) $ - appState ^. gameState . discovery . structureRecognition . recognitionLog + appState ^. gameState . discovery . structureRecognition . recognitionState . recognitionLog recogFoundHandler :: IO AppState -> Handler [StructureLocation] recogFoundHandler appStateRef = do appState <- liftIO appStateRef - let registry = appState ^. gameState . discovery . structureRecognition . foundStructures + let registry = appState ^. gameState . discovery . structureRecognition . recognitionState . foundStructures return . map (uncurry StructureLocation) . concatMap (\(x, ys) -> map (x,) $ NE.toList ys) diff --git a/swarm.cabal b/swarm.cabal index 8163eef35..7fa4bc3fb 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -227,7 +227,9 @@ library swarm-topography Swarm.Game.Scenario.Topography.Structure.Recognition.Prep Swarm.Game.Scenario.Topography.Structure.Recognition.Registry Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry + Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking Swarm.Game.Scenario.Topography.Structure.Recognition.Type + Swarm.Game.Scenario.Topography.Terraform Swarm.Game.Universe Swarm.Game.World.Coords @@ -247,6 +249,7 @@ library swarm-topography nonempty-containers >=0.3.4 && <0.3.5, servant-docs >=0.12 && <0.14, text >=1.2.4 && <2.2, + transformers, unordered-containers, vector >=0.12 && <0.14, yaml >=0.11 && <0.11.12.0, @@ -386,7 +389,6 @@ library swarm-engine Swarm.Game.Scenario.Scoring.GenericMetrics Swarm.Game.Scenario.Status Swarm.Game.Scenario.Topography.Navigation.Util - Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking Swarm.Game.ScenarioInfo Swarm.Game.State Swarm.Game.State.Initialize @@ -416,7 +418,6 @@ library swarm-engine other-modules: Paths_swarm autogen-modules: Paths_swarm build-depends: - AhoCorasick >=0.0.4 && <0.0.5, SHA >=1.6.4 && <1.6.5, aeson >=2.2 && <2.3, array >=0.5.4 && <0.6, @@ -432,7 +433,6 @@ library swarm-engine fused-effects >=1.1.1.1 && <1.2, fused-effects-lens >=1.2.0.1 && <1.3, githash, - hashable >=1.3.4 && <1.5, http-client >=0.7 && <0.8, http-client-tls >=0.3 && <0.4, http-types >=0.12 && <0.13,