-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Precomputation for structure recognizer.
--
-- = Search process overview
--
-- 2D structures may be defined at the
-- <https://github.com/swarm-game/swarm/blob/main/data/scenarios/_doc-fragments/SCHEMA.md#top-level toplevel of a scenario file>.
-- Upon scenario load, all of the predefined structures that are marked
-- as @"recognize"@ are compiled into searcher state machines.
--
-- When an entity is placed on any cell in the world, the
-- 'Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking.entityModified'
-- function is called, which looks up a customized searcher based
-- on the type of placed entity.
--
-- The first searching stage looks for any member row of all participating
-- structure definitions that contains the placed entity.
-- The value returned by the searcher is a second-stage searcher state machine,
-- which this time searches for complete structures of which the found row may
-- be a member.
--
-- Both the first stage and second stage searcher know to start the search
-- at a certain offset horizontally or vertically from the placed entity,
-- based on where within a structure that entity (or row) may occur.
--
-- Upon locating a complete structure, it is added to a registry
-- (see 'Swarm.Game.Scenario.Topography.Structure.Recognition.Registry.FoundRegistry'), which
-- supports lookups by either name or by location (using two different
-- maps maintained in parallel). The map by location is used to remove
-- a structure from the registry if a member entity is changed.
module Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute (
  -- * Main external interface
  mkAutomatons,

  -- * Helper functions
  populateStaticFoundStructures,
  getEntityGrid,
  lookupStaticPlacements,
) where

import Control.Arrow ((&&&))
import Data.Map qualified as M
import Data.Maybe (catMaybes, mapMaybe)
import Data.Set qualified as Set
import Swarm.Game.Entity (Entity)
import Swarm.Game.Scenario (StaticStructureInfo (..), StructureCells)
import Swarm.Game.Scenario.Topography.Cell (cellEntity)
import Swarm.Game.Scenario.Topography.Grid (getRows)
import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransform, getStructureName)
import Swarm.Game.Scenario.Topography.Structure
import Swarm.Game.Scenario.Topography.Structure qualified as 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 (histogram)
import Swarm.Util.Erasable (erasableToMaybe)

getEntityGrid :: StructureCells -> [SymbolSequence Entity]
getEntityGrid :: StructureCells -> [SymbolSequence Entity]
getEntityGrid = Grid (AtomicKeySymbol Entity) -> [SymbolSequence Entity]
forall a. Grid a -> [[a]]
getRows (Grid (AtomicKeySymbol Entity) -> [SymbolSequence Entity])
-> (StructureCells -> Grid (AtomicKeySymbol Entity))
-> StructureCells
-> [SymbolSequence Entity]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (PCell Entity) -> AtomicKeySymbol Entity)
-> Grid (Maybe (PCell Entity)) -> Grid (AtomicKeySymbol Entity)
forall a b. (a -> b) -> Grid a -> Grid b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Erasable Entity -> AtomicKeySymbol Entity
forall e. Erasable e -> Maybe e
erasableToMaybe (Erasable Entity -> AtomicKeySymbol Entity)
-> (PCell Entity -> Erasable Entity)
-> PCell Entity
-> AtomicKeySymbol Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PCell Entity -> Erasable Entity
forall e. PCell e -> Erasable e
cellEntity) (PCell Entity -> AtomicKeySymbol Entity)
-> Maybe (PCell Entity) -> AtomicKeySymbol Entity
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Grid (Maybe (PCell Entity)) -> Grid (AtomicKeySymbol Entity))
-> (StructureCells -> Grid (Maybe (PCell Entity)))
-> StructureCells
-> Grid (AtomicKeySymbol Entity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StructureCells -> Grid (Maybe (PCell Entity))
forall a. NamedArea a -> a
structure

-- | Create Aho-Corasick matchers that will recognize all of the
-- provided structure definitions
mkAutomatons ::
  [SymmetryAnnotatedGrid StructureCells] ->
  RecognizerAutomatons StructureCells Entity
mkAutomatons :: [SymmetryAnnotatedGrid StructureCells]
-> RecognizerAutomatons StructureCells Entity
mkAutomatons [SymmetryAnnotatedGrid StructureCells]
xs =
  Map OriginalName (StructureInfo StructureCells Entity)
-> HashMap
     Entity
     (AutomatonInfo
        Entity
        (AtomicKeySymbol Entity)
        (StructureSearcher StructureCells Entity))
-> RecognizerAutomatons StructureCells Entity
forall b a.
Map OriginalName (StructureInfo b a)
-> HashMap
     a (AutomatonInfo a (AtomicKeySymbol a) (StructureSearcher b a))
-> RecognizerAutomatons b a
RecognizerAutomatons
    Map OriginalName (StructureInfo StructureCells Entity)
infos
    ([StructureWithGrid StructureCells Entity]
-> HashMap
     Entity
     (AutomatonInfo
        Entity
        (AtomicKeySymbol Entity)
        (StructureSearcher StructureCells Entity))
forall a b.
(Hashable a, Eq a) =>
[StructureWithGrid b a]
-> HashMap
     a (AutomatonInfo a (AtomicKeySymbol a) (StructureSearcher b a))
mkEntityLookup [StructureWithGrid StructureCells Entity]
rotatedGrids)
 where
  rotatedGrids :: [StructureWithGrid StructureCells Entity]
rotatedGrids = (SymmetryAnnotatedGrid StructureCells
 -> [StructureWithGrid StructureCells Entity])
-> [SymmetryAnnotatedGrid StructureCells]
-> [StructureWithGrid StructureCells Entity]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (StructureCells -> [StructureWithGrid StructureCells Entity]
extractGrids (StructureCells -> [StructureWithGrid StructureCells Entity])
-> (SymmetryAnnotatedGrid StructureCells -> StructureCells)
-> SymmetryAnnotatedGrid StructureCells
-> [StructureWithGrid StructureCells Entity]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymmetryAnnotatedGrid StructureCells -> StructureCells
forall a. SymmetryAnnotatedGrid a -> a
namedGrid) [SymmetryAnnotatedGrid StructureCells]
xs

  process :: SymmetryAnnotatedGrid StructureCells
-> StructureInfo StructureCells Entity
process SymmetryAnnotatedGrid StructureCells
g = SymmetryAnnotatedGrid StructureCells
-> [SymbolSequence Entity]
-> Map Entity Int
-> StructureInfo StructureCells Entity
forall b a.
SymmetryAnnotatedGrid b
-> [SymbolSequence a] -> Map a Int -> StructureInfo b a
StructureInfo SymmetryAnnotatedGrid StructureCells
g [SymbolSequence Entity]
entGrid Map Entity Int
countsMap
   where
    entGrid :: [SymbolSequence Entity]
entGrid = StructureCells -> [SymbolSequence Entity]
getEntityGrid (StructureCells -> [SymbolSequence Entity])
-> StructureCells -> [SymbolSequence Entity]
forall a b. (a -> b) -> a -> b
$ SymmetryAnnotatedGrid StructureCells -> StructureCells
forall a. SymmetryAnnotatedGrid a -> a
namedGrid SymmetryAnnotatedGrid StructureCells
g
    countsMap :: Map Entity Int
countsMap = [Entity] -> Map Entity Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> Map a Int
histogram ([Entity] -> Map Entity Int) -> [Entity] -> Map Entity Int
forall a b. (a -> b) -> a -> b
$ (SymbolSequence Entity -> [Entity])
-> [SymbolSequence Entity] -> [Entity]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SymbolSequence Entity -> [Entity]
forall a. [Maybe a] -> [a]
catMaybes [SymbolSequence Entity]
entGrid

  infos :: Map OriginalName (StructureInfo StructureCells Entity)
infos =
    [(OriginalName, StructureInfo StructureCells Entity)]
-> Map OriginalName (StructureInfo StructureCells Entity)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(OriginalName, StructureInfo StructureCells Entity)]
 -> Map OriginalName (StructureInfo StructureCells Entity))
-> [(OriginalName, StructureInfo StructureCells Entity)]
-> Map OriginalName (StructureInfo StructureCells Entity)
forall a b. (a -> b) -> a -> b
$
      (SymmetryAnnotatedGrid StructureCells
 -> (OriginalName, StructureInfo StructureCells Entity))
-> [SymmetryAnnotatedGrid StructureCells]
-> [(OriginalName, StructureInfo StructureCells Entity)]
forall a b. (a -> b) -> [a] -> [b]
map (StructureName -> OriginalName
getStructureName (StructureName -> OriginalName)
-> (SymmetryAnnotatedGrid StructureCells -> StructureName)
-> SymmetryAnnotatedGrid StructureCells
-> OriginalName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StructureCells -> StructureName
forall a. NamedArea a -> StructureName
Structure.name (StructureCells -> StructureName)
-> (SymmetryAnnotatedGrid StructureCells -> StructureCells)
-> SymmetryAnnotatedGrid StructureCells
-> StructureName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymmetryAnnotatedGrid StructureCells -> StructureCells
forall a. SymmetryAnnotatedGrid a -> a
namedGrid (SymmetryAnnotatedGrid StructureCells -> OriginalName)
-> (SymmetryAnnotatedGrid StructureCells
    -> StructureInfo StructureCells Entity)
-> SymmetryAnnotatedGrid StructureCells
-> (OriginalName, StructureInfo StructureCells Entity)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& SymmetryAnnotatedGrid StructureCells
-> StructureInfo StructureCells Entity
process) [SymmetryAnnotatedGrid StructureCells]
xs

extractOrientedGrid ::
  StructureCells ->
  AbsoluteDir ->
  StructureWithGrid StructureCells Entity
extractOrientedGrid :: StructureCells
-> AbsoluteDir -> StructureWithGrid StructureCells Entity
extractOrientedGrid StructureCells
x AbsoluteDir
d =
  NamedOriginal StructureCells
-> AbsoluteDir
-> [SymbolSequence Entity]
-> StructureWithGrid StructureCells Entity
forall b a.
NamedOriginal b
-> AbsoluteDir -> [SymbolSequence a] -> StructureWithGrid b a
StructureWithGrid NamedOriginal StructureCells
wrapped AbsoluteDir
d ([SymbolSequence Entity]
 -> StructureWithGrid StructureCells Entity)
-> [SymbolSequence Entity]
-> StructureWithGrid StructureCells Entity
forall a b. (a -> b) -> a -> b
$ StructureCells -> [SymbolSequence Entity]
getEntityGrid StructureCells
g
 where
  wrapped :: NamedOriginal StructureCells
wrapped = OriginalName -> StructureCells -> NamedOriginal StructureCells
forall a. OriginalName -> a -> NamedOriginal a
NamedOriginal (StructureName -> OriginalName
getStructureName (StructureName -> OriginalName) -> StructureName -> OriginalName
forall a b. (a -> b) -> a -> b
$ StructureCells -> StructureName
forall a. NamedArea a -> StructureName
Structure.name StructureCells
x) StructureCells
x
  g :: StructureCells
g = Orientation
-> Grid (Maybe (PCell Entity)) -> Grid (Maybe (PCell Entity))
forall a. Orientation -> Grid a -> Grid a
applyOrientationTransform (AbsoluteDir -> Bool -> Orientation
Orientation AbsoluteDir
d Bool
False) (Grid (Maybe (PCell Entity)) -> Grid (Maybe (PCell Entity)))
-> StructureCells -> StructureCells
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StructureCells
x

-- | At this point, we have already ensured that orientations
-- redundant by rotational symmetry have been excluded
-- (i.e. at Scenario validation time).
extractGrids :: StructureCells -> [StructureWithGrid StructureCells Entity]
extractGrids :: StructureCells -> [StructureWithGrid StructureCells Entity]
extractGrids StructureCells
x = (AbsoluteDir -> StructureWithGrid StructureCells Entity)
-> [AbsoluteDir] -> [StructureWithGrid StructureCells Entity]
forall a b. (a -> b) -> [a] -> [b]
map (StructureCells
-> AbsoluteDir -> StructureWithGrid StructureCells Entity
extractOrientedGrid StructureCells
x) ([AbsoluteDir] -> [StructureWithGrid StructureCells Entity])
-> [AbsoluteDir] -> [StructureWithGrid StructureCells Entity]
forall a b. (a -> b) -> a -> b
$ Set AbsoluteDir -> [AbsoluteDir]
forall a. Set a -> [a]
Set.toList (Set AbsoluteDir -> [AbsoluteDir])
-> Set AbsoluteDir -> [AbsoluteDir]
forall a b. (a -> b) -> a -> b
$ StructureCells -> Set AbsoluteDir
forall a. NamedArea a -> Set AbsoluteDir
recognize StructureCells
x

-- | The output list of 'FoundStructure' records is not yet
-- vetted; the 'ensureStructureIntact' function will subsequently
-- filter this list.
lookupStaticPlacements :: StaticStructureInfo -> [FoundStructure StructureCells Entity]
lookupStaticPlacements :: StaticStructureInfo -> [FoundStructure StructureCells Entity]
lookupStaticPlacements (StaticStructureInfo [SymmetryAnnotatedGrid StructureCells]
structDefs Map SubworldName [LocatedStructure]
thePlacements) =
  ((SubworldName, [LocatedStructure])
 -> [FoundStructure StructureCells Entity])
-> [(SubworldName, [LocatedStructure])]
-> [FoundStructure StructureCells Entity]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (SubworldName, [LocatedStructure])
-> [FoundStructure StructureCells Entity]
f ([(SubworldName, [LocatedStructure])]
 -> [FoundStructure StructureCells Entity])
-> [(SubworldName, [LocatedStructure])]
-> [FoundStructure StructureCells Entity]
forall a b. (a -> b) -> a -> b
$ Map SubworldName [LocatedStructure]
-> [(SubworldName, [LocatedStructure])]
forall k a. Map k a -> [(k, a)]
M.toList Map SubworldName [LocatedStructure]
thePlacements
 where
  definitionMap :: Map StructureName StructureCells
definitionMap = [(StructureName, StructureCells)]
-> Map StructureName StructureCells
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(StructureName, StructureCells)]
 -> Map StructureName StructureCells)
-> [(StructureName, StructureCells)]
-> Map StructureName StructureCells
forall a b. (a -> b) -> a -> b
$ (SymmetryAnnotatedGrid StructureCells
 -> (StructureName, StructureCells))
-> [SymmetryAnnotatedGrid StructureCells]
-> [(StructureName, StructureCells)]
forall a b. (a -> b) -> [a] -> [b]
map ((StructureCells -> StructureName
forall a. NamedArea a -> StructureName
Structure.name (StructureCells -> StructureName)
-> (StructureCells -> StructureCells)
-> StructureCells
-> (StructureName, StructureCells)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& StructureCells -> StructureCells
forall a. a -> a
id) (StructureCells -> (StructureName, StructureCells))
-> (SymmetryAnnotatedGrid StructureCells -> StructureCells)
-> SymmetryAnnotatedGrid StructureCells
-> (StructureName, StructureCells)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymmetryAnnotatedGrid StructureCells -> StructureCells
forall a. SymmetryAnnotatedGrid a -> a
namedGrid) [SymmetryAnnotatedGrid StructureCells]
structDefs

  f :: (SubworldName, [LocatedStructure])
-> [FoundStructure StructureCells Entity]
f (SubworldName
subworldName, [LocatedStructure]
locatedList) = (LocatedStructure -> Maybe (FoundStructure StructureCells Entity))
-> [LocatedStructure] -> [FoundStructure StructureCells Entity]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LocatedStructure -> Maybe (FoundStructure StructureCells Entity)
g [LocatedStructure]
locatedList
   where
    g :: LocatedStructure -> Maybe (FoundStructure StructureCells Entity)
g (LocatedStructure StructureName
theName AbsoluteDir
d Location
loc) = do
      StructureCells
sGrid <- StructureName
-> Map StructureName StructureCells -> Maybe StructureCells
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup StructureName
theName Map StructureName StructureCells
definitionMap
      FoundStructure StructureCells Entity
-> Maybe (FoundStructure StructureCells Entity)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (FoundStructure StructureCells Entity
 -> Maybe (FoundStructure StructureCells Entity))
-> FoundStructure StructureCells Entity
-> Maybe (FoundStructure StructureCells Entity)
forall a b. (a -> b) -> a -> b
$ StructureWithGrid StructureCells Entity
-> Cosmic Location -> FoundStructure StructureCells Entity
forall b a.
StructureWithGrid b a -> Cosmic Location -> FoundStructure b a
FoundStructure (StructureCells
-> AbsoluteDir -> StructureWithGrid StructureCells Entity
extractOrientedGrid StructureCells
sGrid AbsoluteDir
d) (Cosmic Location -> FoundStructure StructureCells Entity)
-> Cosmic Location -> FoundStructure StructureCells Entity
forall a b. (a -> b) -> a -> b
$ SubworldName -> Location -> Cosmic Location
forall a. SubworldName -> a -> Cosmic a
Cosmic SubworldName
subworldName Location
loc