diff --git a/src/swarm-engine/Swarm/Game/State/Initialize.hs b/src/swarm-engine/Swarm/Game/State/Initialize.hs index f670d1524..b88aff783 100644 --- a/src/swarm-engine/Swarm/Game/State/Initialize.hs +++ b/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 diff --git a/src/swarm-engine/Swarm/Game/Step/Util.hs b/src/swarm-engine/Swarm/Game/Step/Util.hs index c66cd624b..e0acc276d 100644 --- a/src/swarm-engine/Swarm/Game/Step/Util.hs +++ b/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 diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs index 5bd8c163d..352a00d68 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs +++ b/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 } diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs index 336643643..634cc2463 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs +++ b/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 diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Prep.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Prep.hs index 9b4d7a2cf..e265fb98c 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Prep.hs +++ b/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 diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs index 89358fe7f..a8c2fd0b5 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs +++ b/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'. -- diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs index 8908d0584..7344d5de8 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs +++ b/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: diff --git a/swarm.cabal b/swarm.cabal index fcdca6e6a..3424b1c65 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -497,6 +497,7 @@ library swarm-topography JuicyPixels, aeson, array, + either, base, containers, extra,