From 33d38c92a12bf54ad190aedd372bf8d428594b35 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sat, 13 Jul 2024 18:47:06 -0700 Subject: [PATCH] move more recognizer logic into topography sublibrary (#2021) Builds upon #1836. This PR moves functions that are independent of `Entity` type into a new module within `swarm-topography`, alongside most of the other structure recognizer code. Notably, this allows removal of the `AhoCorasick` dependency from the `swarm-scenario` sublibrary. --- .../Structure/Recognition/Precompute.hs | 113 +---------------- .../Topography/Structure/Recognition/Prep.hs | 118 ++++++++++++++++++ swarm.cabal | 3 +- 3 files changed, 122 insertions(+), 112 deletions(-) create mode 100644 src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Prep.hs diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs index efb2635a6..9172a4cb9 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs @@ -37,140 +37,31 @@ module Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute ( -- * Helper functions populateStaticFoundStructures, getEntityGrid, - extractGrids, lookupStaticPlacements, ) where import Control.Arrow ((&&&)) import Control.Lens (view) -import Data.Hashable (Hashable) -import Data.Int (Int32) -import Data.List.NonEmpty qualified as NE import Data.Map qualified as M import Data.Maybe (catMaybes, mapMaybe) -import Data.Semigroup (sconcat) -import Data.Set qualified as S import Data.Set qualified as Set -import Data.Tuple (swap) import Swarm.Game.Entity (Entity, EntityName, entityName) import Swarm.Game.Scenario (StaticStructureInfo (..)) import Swarm.Game.Scenario.Topography.Cell (PCell, cellEntity) import Swarm.Game.Scenario.Topography.Grid (Grid, getRows) import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransform) import Swarm.Game.Scenario.Topography.Structure +import Swarm.Game.Scenario.Topography.Structure.Recognition.Prep import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry import Swarm.Game.Scenario.Topography.Structure.Recognition.Type import Swarm.Game.Universe (Cosmic (..)) import Swarm.Language.Syntax.Direction (AbsoluteDir) -import Swarm.Util (binTuples, histogram) +import Swarm.Util (histogram) import Swarm.Util.Erasable (erasableToMaybe) -import Text.AhoCorasick getEntityGrid :: Grid (Maybe (PCell Entity)) -> [SymbolSequence Entity] getEntityGrid = map (map ((erasableToMaybe . cellEntity) =<<)) . getRows -allStructureRows :: [StructureWithGrid b a] -> [StructureRow b a] -allStructureRows = - concatMap transformRows - where - transformRows :: StructureWithGrid b a -> [StructureRow b a] - transformRows g = zipWith (StructureRow g) [0 ..] $ entityGrid g - -mkOffsets :: Foldable f => Int32 -> f a -> InspectionOffsets -mkOffsets pos xs = - InspectionOffsets (pure (negate pos)) $ - pure $ - fromIntegral (length xs) - 1 - pos - --- | Given each possible row of entities observed in the world, --- yield a searcher that can determine whether adjacent --- rows constitute a complete structure. -mkRowLookup :: - (Hashable a, Ord en) => - (a -> en) -> - NE.NonEmpty (StructureRow b a) -> - AutomatonInfo en (SymbolSequence a) (StructureWithGrid b a) -mkRowLookup nameFunc neList = - AutomatonInfo participatingEnts bounds sm - where - mkSmTuple = entityGrid &&& id - tuples = NE.toList $ NE.map (mkSmTuple . wholeStructure) neList - - -- All of the unique entities across all of the full candidate structures - participatingEnts = - S.fromList $ - map nameFunc $ - concatMap (concatMap catMaybes . fst) tuples - - deriveRowOffsets :: StructureRow b a -> InspectionOffsets - deriveRowOffsets (StructureRow (StructureWithGrid _ _ g) rwIdx _) = - mkOffsets rwIdx g - - bounds = sconcat $ NE.map deriveRowOffsets neList - sm = makeStateMachine tuples - --- | Make the first-phase lookup map, keyed by 'Entity', --- along with automatons whose key symbols are "Maybe Entity". --- --- Each automaton in this first layer will attempt to match the --- underlying world row against all rows within all structures --- (so long as they contain the keyed entity). -mkEntityLookup :: - (Hashable a, Ord a, Ord en) => - (a -> en) -> - [StructureWithGrid b a] -> - M.Map a (AutomatonInfo en (AtomicKeySymbol a) (StructureSearcher b en a)) -mkEntityLookup nameFunc grids = - M.map mkValues rowsByEntityParticipation - where - rowsAcrossAllStructures = allStructureRows grids - - -- The input here are all rows across all structures - -- that share the same entity sequence. - mkSmValue ksms singleRows = - StructureSearcher sm2D ksms singleRows - where - structureRowsNE = NE.map myRow singleRows - sm2D = mkRowLookup nameFunc structureRowsNE - - mkValues neList = AutomatonInfo participatingEnts bounds sm - where - participatingEnts = - (S.fromList . map nameFunc) - (concatMap (catMaybes . fst) tuples) - - tuples = M.toList $ M.mapWithKey mkSmValue groupedByUniqueRow - - groupedByUniqueRow = binTuples $ NE.toList $ NE.map (rowContent . myRow &&& id) neList - bounds = sconcat $ NE.map expandedOffsets neList - sm = makeStateMachine tuples - - -- The values of this map are guaranteed to contain only one - -- entry per row of a given structure. - rowsByEntityParticipation = - binTuples $ - map (myEntity &&& id) $ - concatMap explodeRowEntities rowsAcrossAllStructures - - deriveEntityOffsets :: PositionWithinRow b a -> InspectionOffsets - deriveEntityOffsets (PositionWithinRow pos r) = - mkOffsets pos $ rowContent r - - -- The members of "rowMembers" are of 'Maybe' type; the 'Nothing's - -- are dropped but accounted for when indexing the columns. - explodeRowEntities :: Ord a => StructureRow b a -> [SingleRowEntityOccurrences b a] - explodeRowEntities r@(StructureRow _ _ rowMembers) = - map f $ M.toList $ binTuples unconsolidated - where - f (e, occurrences) = - SingleRowEntityOccurrences r e occurrences $ - sconcat $ - NE.map deriveEntityOffsets occurrences - unconsolidated = - map swap $ - catMaybes $ - zipWith (\idx -> fmap (PositionWithinRow idx r,)) [0 ..] rowMembers - -- | Create Aho-Corasick matchers that will recognize all of the -- provided structure definitions mkAutomatons :: 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 new file mode 100644 index 000000000..17ed924dd --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Prep.hs @@ -0,0 +1,118 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.Game.Scenario.Topography.Structure.Recognition.Prep (mkEntityLookup) where + +import Control.Arrow ((&&&)) +import Data.Hashable (Hashable) +import Data.Int (Int32) +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Maybe (catMaybes) +import Data.Semigroup (sconcat) +import Data.Set qualified as S +import Data.Tuple (swap) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Util (binTuples) +import Text.AhoCorasick + +allStructureRows :: [StructureWithGrid b a] -> [StructureRow b a] +allStructureRows = + concatMap transformRows + where + transformRows :: StructureWithGrid b a -> [StructureRow b a] + transformRows g = zipWith (StructureRow g) [0 ..] $ entityGrid g + +mkOffsets :: Foldable f => Int32 -> f a -> InspectionOffsets +mkOffsets pos xs = + InspectionOffsets (pure (negate pos)) $ + pure $ + fromIntegral (length xs) - 1 - pos + +-- | Given each possible row of entities observed in the world, +-- yield a searcher that can determine whether adjacent +-- rows constitute a complete structure. +mkRowLookup :: + (Hashable a, Ord en) => + (a -> en) -> + NE.NonEmpty (StructureRow b a) -> + AutomatonInfo en (SymbolSequence a) (StructureWithGrid b a) +mkRowLookup nameFunc neList = + AutomatonInfo participatingEnts bounds sm + where + mkSmTuple = entityGrid &&& id + tuples = NE.toList $ NE.map (mkSmTuple . wholeStructure) neList + + -- All of the unique entities across all of the full candidate structures + participatingEnts = + S.fromList $ + map nameFunc $ + concatMap (concatMap catMaybes . fst) tuples + + deriveRowOffsets :: StructureRow b a -> InspectionOffsets + deriveRowOffsets (StructureRow (StructureWithGrid _ _ g) rwIdx _) = + mkOffsets rwIdx g + + bounds = sconcat $ NE.map deriveRowOffsets neList + sm = makeStateMachine tuples + +-- | Make the first-phase lookup map, keyed by 'Entity', +-- along with automatons whose key symbols are "Maybe Entity". +-- +-- Each automaton in this first layer will attempt to match the +-- underlying world row against all rows within all structures +-- (so long as they contain the keyed entity). +mkEntityLookup :: + (Hashable a, Ord a, Ord en) => + (a -> en) -> + [StructureWithGrid b a] -> + M.Map a (AutomatonInfo en (AtomicKeySymbol a) (StructureSearcher b en a)) +mkEntityLookup nameFunc grids = + M.map mkValues rowsByEntityParticipation + where + rowsAcrossAllStructures = allStructureRows grids + + -- The input here are all rows across all structures + -- that share the same entity sequence. + mkSmValue ksms singleRows = + StructureSearcher sm2D ksms singleRows + where + structureRowsNE = NE.map myRow singleRows + sm2D = mkRowLookup nameFunc structureRowsNE + + mkValues neList = AutomatonInfo participatingEnts bounds sm + where + participatingEnts = + (S.fromList . map nameFunc) + (concatMap (catMaybes . fst) tuples) + + tuples = M.toList $ M.mapWithKey mkSmValue groupedByUniqueRow + + groupedByUniqueRow = binTuples $ NE.toList $ NE.map (rowContent . myRow &&& id) neList + bounds = sconcat $ NE.map expandedOffsets neList + sm = makeStateMachine tuples + + -- The values of this map are guaranteed to contain only one + -- entry per row of a given structure. + rowsByEntityParticipation = + binTuples $ + map (myEntity &&& id) $ + concatMap explodeRowEntities rowsAcrossAllStructures + + deriveEntityOffsets :: PositionWithinRow b a -> InspectionOffsets + deriveEntityOffsets (PositionWithinRow pos r) = + mkOffsets pos $ rowContent r + + -- The members of "rowMembers" are of 'Maybe' type; the 'Nothing's + -- are dropped but accounted for when indexing the columns. + explodeRowEntities :: Ord a => StructureRow b a -> [SingleRowEntityOccurrences b a] + explodeRowEntities r@(StructureRow _ _ rowMembers) = + map f $ M.toList $ binTuples unconsolidated + where + f (e, occurrences) = + SingleRowEntityOccurrences r e occurrences $ + sconcat $ + NE.map deriveEntityOffsets occurrences + unconsolidated = + map swap $ + catMaybes $ + zipWith (\idx -> fmap (PositionWithinRow idx r,)) [0 ..] rowMembers diff --git a/swarm.cabal b/swarm.cabal index af20cb3c6..148fadf94 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -221,6 +221,7 @@ library swarm-topography Swarm.Game.Scenario.Topography.Structure.Overlay Swarm.Game.Scenario.Topography.Structure.Recognition Swarm.Game.Scenario.Topography.Structure.Recognition.Log + 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.Type @@ -237,6 +238,7 @@ library swarm-topography base >=4.14 && <4.20, containers >=0.6.2 && <0.8, extra >=1.7 && <1.8, + hashable, lens, linear >=1.21.6 && <1.24, nonempty-containers >=0.3.4 && <0.3.5, @@ -308,7 +310,6 @@ library swarm-scenario other-modules: Paths_swarm autogen-modules: Paths_swarm build-depends: - AhoCorasick >=0.0.4 && <0.0.5, JuicyPixels >=3.3 && <3.4, aeson >=2.2 && <2.3, array >=0.5.4 && <0.6,