-- |
-- 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.
-- If we observe a row in the world that happens to occur in a structure, we use both
-- the horizontal found offset and the index of the row within this structure to compute
-- the expected world location of the candidate structure.
-- Then we perform a full scan of that candidate structure against the world to verify
-- the match.
--
-- 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,

  -- * Types
  GenericEntLocator,

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

import Control.Arrow ((&&&))
import Control.Lens ((^.))
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.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Maybe (catMaybes, mapMaybe)
import Data.Set qualified as Set
import Data.Tuple (swap)
import Data.Tuple.Extra (dupe)
import Swarm.Game.Location (Location, asVector)
import Swarm.Game.Scenario.Topography.Area (getNEGridDimensions, rectWidth)
import Swarm.Game.Scenario.Topography.Grid
import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransformNE)
import Swarm.Game.Scenario.Topography.Structure.Named
import Swarm.Game.Scenario.Topography.Structure.Recognition.Prep (
  mkEntityLookup,
 )
import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (
  FoundRegistry,
  foundByLocation,
  populateStaticFoundStructures,
 )
import Swarm.Game.Scenario.Topography.Structure.Recognition.Static
import Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry
import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
import Swarm.Game.Universe (Cosmic (..), offsetBy, planar)
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 (AtomicKeySymbol a)

-- | Create Aho-Corasick matchers that will recognize all of the
-- provided structure definitions
mkAutomatons ::
  (Ord a, Hashable a) =>
  (b -> NonEmptyGrid (AtomicKeySymbol a)) ->
  [NamedArea b] ->
  Either RedundantOrientations (RecognizerAutomatons b a)
mkAutomatons :: forall a b.
(Ord a, Hashable a) =>
(b -> NonEmptyGrid (AtomicKeySymbol a))
-> [NamedArea b]
-> Either RedundantOrientations (RecognizerAutomatons b a)
mkAutomatons b -> NonEmptyGrid (AtomicKeySymbol a)
extractor [NamedArea b]
rawGrids = do
  [SymmetryAnnotatedGrid (ExtractedArea b a)]
onlyNonempties <- (ExtractedArea b a
 -> Either
      RedundantOrientations (SymmetryAnnotatedGrid (ExtractedArea b a)))
-> [ExtractedArea b a]
-> Either
     RedundantOrientations [SymmetryAnnotatedGrid (ExtractedArea b a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ExtractedArea b a
-> Either
     RedundantOrientations (SymmetryAnnotatedGrid (ExtractedArea b a))
forall a b.
Eq a =>
ExtractedArea b a
-> Either
     RedundantOrientations (SymmetryAnnotatedGrid (ExtractedArea b a))
checkSymmetry [ExtractedArea b a]
extractedItems
  let rotatedGrids :: [StructureWithGrid b a]
rotatedGrids = (SymmetryAnnotatedGrid (ExtractedArea b a)
 -> [StructureWithGrid b a])
-> [SymmetryAnnotatedGrid (ExtractedArea b a)]
-> [StructureWithGrid b a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ExtractedArea b a -> [StructureWithGrid b a]
forall b a. ExtractedArea b a -> [StructureWithGrid b a]
extractGrids (ExtractedArea b a -> [StructureWithGrid b a])
-> (SymmetryAnnotatedGrid (ExtractedArea b a) -> ExtractedArea b a)
-> SymmetryAnnotatedGrid (ExtractedArea b a)
-> [StructureWithGrid b a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymmetryAnnotatedGrid (ExtractedArea b a) -> ExtractedArea b a
forall a. SymmetryAnnotatedGrid a -> a
grid) [SymmetryAnnotatedGrid (ExtractedArea b a)]
onlyNonempties
      infos :: Map StructureName (StructureInfo b a)
infos =
        [(StructureName, StructureInfo b a)]
-> Map StructureName (StructureInfo b a)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(StructureName, StructureInfo b a)]
 -> Map StructureName (StructureInfo b a))
-> [(StructureName, StructureInfo b a)]
-> Map StructureName (StructureInfo b a)
forall a b. (a -> b) -> a -> b
$
          (SymmetryAnnotatedGrid (ExtractedArea b a)
 -> (StructureName, StructureInfo b a))
-> [SymmetryAnnotatedGrid (ExtractedArea b a)]
-> [(StructureName, StructureInfo b a)]
forall a b. (a -> b) -> [a] -> [b]
map ((NamedArea b -> StructureName
forall a. NamedArea a -> StructureName
name (NamedArea b -> StructureName)
-> (StructureInfo b a -> NamedArea b)
-> StructureInfo b a
-> StructureName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtractedArea b a -> NamedArea b
forall b a. ExtractedArea b a -> NamedArea b
originalItem (ExtractedArea b a -> NamedArea b)
-> (StructureInfo b a -> ExtractedArea b a)
-> StructureInfo b a
-> NamedArea b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymmetryAnnotatedGrid (ExtractedArea b a) -> ExtractedArea b a
forall a. SymmetryAnnotatedGrid a -> a
grid (SymmetryAnnotatedGrid (ExtractedArea b a) -> ExtractedArea b a)
-> (StructureInfo b a -> SymmetryAnnotatedGrid (ExtractedArea b a))
-> StructureInfo b a
-> ExtractedArea b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StructureInfo b a -> SymmetryAnnotatedGrid (ExtractedArea b a)
forall b a.
StructureInfo b a -> SymmetryAnnotatedGrid (ExtractedArea b a)
annotatedGrid (StructureInfo b a -> StructureName)
-> (StructureInfo b a -> StructureInfo b a)
-> StructureInfo b a
-> (StructureName, StructureInfo b a)
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')
&&& StructureInfo b a -> StructureInfo b a
forall a. a -> a
id) (StructureInfo b a -> (StructureName, StructureInfo b a))
-> (SymmetryAnnotatedGrid (ExtractedArea b a) -> StructureInfo b a)
-> SymmetryAnnotatedGrid (ExtractedArea b a)
-> (StructureName, StructureInfo b a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymmetryAnnotatedGrid (ExtractedArea b a) -> StructureInfo b a
forall {a} {b}.
Ord a =>
SymmetryAnnotatedGrid (ExtractedArea b a) -> StructureInfo b a
process) [SymmetryAnnotatedGrid (ExtractedArea b a)]
onlyNonempties
  RecognizerAutomatons b a
-> Either RedundantOrientations (RecognizerAutomatons b a)
forall a. a -> Either RedundantOrientations a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecognizerAutomatons b a
 -> Either RedundantOrientations (RecognizerAutomatons b a))
-> RecognizerAutomatons b a
-> Either RedundantOrientations (RecognizerAutomatons b a)
forall a b. (a -> b) -> a -> b
$
    Map StructureName (StructureInfo b a)
-> HashMap a (AutomatonInfo b a) -> RecognizerAutomatons b a
forall b a.
Map StructureName (StructureInfo b a)
-> HashMap a (AutomatonInfo b a) -> RecognizerAutomatons b a
RecognizerAutomatons
      Map StructureName (StructureInfo b a)
infos
      ([StructureWithGrid b a] -> HashMap a (AutomatonInfo b a)
forall a b.
(Hashable a, Eq a) =>
[StructureWithGrid b a] -> HashMap a (AutomatonInfo b a)
mkEntityLookup [StructureWithGrid b a]
rotatedGrids)
 where
  extractedItems :: [ExtractedArea b a]
extractedItems = (NamedArea b -> ExtractedArea b a)
-> [NamedArea b] -> [ExtractedArea b a]
forall a b. (a -> b) -> [a] -> [b]
map ((NamedArea b
 -> NonEmptyGrid (AtomicKeySymbol a) -> ExtractedArea b a)
-> (NamedArea b, NonEmptyGrid (AtomicKeySymbol a))
-> ExtractedArea b a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry NamedArea b
-> NonEmptyGrid (AtomicKeySymbol a) -> ExtractedArea b a
forall b a.
NamedArea b
-> NonEmptyGrid (AtomicKeySymbol a) -> ExtractedArea b a
ExtractedArea ((NamedArea b, NonEmptyGrid (AtomicKeySymbol a))
 -> ExtractedArea b a)
-> (NamedArea b -> (NamedArea b, NonEmptyGrid (AtomicKeySymbol a)))
-> NamedArea b
-> ExtractedArea b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedArea b -> NonEmptyGrid (AtomicKeySymbol a))
-> (NamedArea b, NamedArea b)
-> (NamedArea b, NonEmptyGrid (AtomicKeySymbol a))
forall a b. (a -> b) -> (NamedArea b, a) -> (NamedArea b, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> NonEmptyGrid (AtomicKeySymbol a)
extractor (b -> NonEmptyGrid (AtomicKeySymbol a))
-> (NamedArea b -> b)
-> NamedArea b
-> NonEmptyGrid (AtomicKeySymbol a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArea b -> b
forall a. NamedArea a -> a
structure) ((NamedArea b, NamedArea b)
 -> (NamedArea b, NonEmptyGrid (AtomicKeySymbol a)))
-> (NamedArea b -> (NamedArea b, NamedArea b))
-> NamedArea b
-> (NamedArea b, NonEmptyGrid (AtomicKeySymbol a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArea b -> (NamedArea b, NamedArea b)
forall a. a -> (a, a)
dupe) [NamedArea b]
rawGrids

  process :: SymmetryAnnotatedGrid (ExtractedArea b a) -> StructureInfo b a
process SymmetryAnnotatedGrid (ExtractedArea b a)
g = SymmetryAnnotatedGrid (ExtractedArea b a)
-> NonEmptyGrid (AtomicKeySymbol a)
-> Map a Int
-> StructureInfo b a
forall b a.
SymmetryAnnotatedGrid (ExtractedArea b a)
-> NonEmptyGrid (AtomicKeySymbol a)
-> Map a Int
-> StructureInfo b a
StructureInfo SymmetryAnnotatedGrid (ExtractedArea b a)
g NonEmptyGrid (AtomicKeySymbol a)
entGrid Map a Int
countsMap
   where
    entGrid :: NonEmptyGrid (AtomicKeySymbol a)
entGrid = ExtractedArea b a -> NonEmptyGrid (AtomicKeySymbol a)
forall b a. ExtractedArea b a -> NonEmptyGrid (AtomicKeySymbol a)
extractedGrid (ExtractedArea b a -> NonEmptyGrid (AtomicKeySymbol a))
-> ExtractedArea b a -> NonEmptyGrid (AtomicKeySymbol a)
forall a b. (a -> b) -> a -> b
$ SymmetryAnnotatedGrid (ExtractedArea b a) -> ExtractedArea b a
forall a. SymmetryAnnotatedGrid a -> a
grid SymmetryAnnotatedGrid (ExtractedArea b a)
g
    countsMap :: Map a Int
countsMap = [a] -> Map a Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> Map a Int
histogram ([a] -> Map a Int)
-> (NonEmpty (AtomicKeySymbol a) -> [a])
-> NonEmpty (AtomicKeySymbol a)
-> Map a Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [AtomicKeySymbol a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes ([AtomicKeySymbol a] -> [a])
-> (NonEmpty (AtomicKeySymbol a) -> [AtomicKeySymbol a])
-> NonEmpty (AtomicKeySymbol a)
-> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (AtomicKeySymbol a) -> [AtomicKeySymbol a]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (AtomicKeySymbol a) -> Map a Int)
-> NonEmpty (AtomicKeySymbol a) -> Map a Int
forall a b. (a -> b) -> a -> b
$ NonEmptyGrid (AtomicKeySymbol a) -> NonEmpty (AtomicKeySymbol a)
forall c. NonEmptyGrid c -> NonEmpty c
allMembersNE NonEmptyGrid (AtomicKeySymbol a)
entGrid

extractOrientedGrid ::
  ExtractedArea b a ->
  AbsoluteDir ->
  StructureWithGrid b a
extractOrientedGrid :: forall b a.
ExtractedArea b a -> AbsoluteDir -> StructureWithGrid b a
extractOrientedGrid (ExtractedArea NamedArea b
x NonEmptyGrid (AtomicKeySymbol a)
neGrid) AbsoluteDir
d =
  AbsoluteDir
-> RowWidth -> ExtractedArea b a -> StructureWithGrid b a
forall b a.
AbsoluteDir
-> RowWidth -> ExtractedArea b a -> StructureWithGrid b a
StructureWithGrid AbsoluteDir
d RowWidth
w (ExtractedArea b a -> StructureWithGrid b a)
-> ExtractedArea b a -> StructureWithGrid b a
forall a b. (a -> b) -> a -> b
$
    NamedArea b
-> NonEmptyGrid (AtomicKeySymbol a) -> ExtractedArea b a
forall b a.
NamedArea b
-> NonEmptyGrid (AtomicKeySymbol a) -> ExtractedArea b a
ExtractedArea NamedArea b
x (NonEmptyGrid (AtomicKeySymbol a) -> ExtractedArea b a)
-> NonEmptyGrid (AtomicKeySymbol a) -> ExtractedArea b a
forall a b. (a -> b) -> a -> b
$
      Orientation
-> NonEmptyGrid (AtomicKeySymbol a)
-> NonEmptyGrid (AtomicKeySymbol a)
forall a. Orientation -> NonEmptyGrid a -> NonEmptyGrid a
applyOrientationTransformNE (AbsoluteDir -> Bool -> Orientation
Orientation AbsoluteDir
d Bool
False) NonEmptyGrid (AtomicKeySymbol a)
neGrid
 where
  w :: RowWidth
w = Int32 -> RowWidth
RowWidth (Int32 -> RowWidth)
-> (NonEmptyGrid (AtomicKeySymbol a) -> Int32)
-> NonEmptyGrid (AtomicKeySymbol a)
-> RowWidth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AreaDimensions -> Int32
rectWidth (AreaDimensions -> Int32)
-> (NonEmptyGrid (AtomicKeySymbol a) -> AreaDimensions)
-> NonEmptyGrid (AtomicKeySymbol a)
-> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmptyGrid (AtomicKeySymbol a) -> AreaDimensions
forall a. NonEmptyGrid a -> AreaDimensions
getNEGridDimensions (NonEmptyGrid (AtomicKeySymbol a) -> RowWidth)
-> NonEmptyGrid (AtomicKeySymbol a) -> RowWidth
forall a b. (a -> b) -> a -> b
$ NonEmptyGrid (AtomicKeySymbol a)
neGrid

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

-- | The output list of 'FoundStructure' records is not yet
-- vetted; the 'ensureStructureIntact' function will subsequently
-- filter this list.
lookupStaticPlacements ::
  StaticStructureInfo b a ->
  [FoundStructure b a]
lookupStaticPlacements :: forall b a. StaticStructureInfo b a -> [FoundStructure b a]
lookupStaticPlacements (StaticStructureInfo RecognizerAutomatons b a
theAutomatons Map SubworldName [LocatedStructure]
thePlacements) =
  ((SubworldName, [LocatedStructure]) -> [FoundStructure b a])
-> [(SubworldName, [LocatedStructure])] -> [FoundStructure b a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (SubworldName, [LocatedStructure]) -> [FoundStructure b a]
f ([(SubworldName, [LocatedStructure])] -> [FoundStructure b a])
-> [(SubworldName, [LocatedStructure])] -> [FoundStructure b a]
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 (StructureInfo b a)
definitionMap = RecognizerAutomatons b a
theAutomatons RecognizerAutomatons b a
-> Getting
     (Map StructureName (StructureInfo b a))
     (RecognizerAutomatons b a)
     (Map StructureName (StructureInfo b a))
-> Map StructureName (StructureInfo b a)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map StructureName (StructureInfo b a))
  (RecognizerAutomatons b a)
  (Map StructureName (StructureInfo b a))
forall b a (f :: * -> *).
Functor f =>
(Map StructureName (StructureInfo b a)
 -> f (Map StructureName (StructureInfo b a)))
-> RecognizerAutomatons b a -> f (RecognizerAutomatons b a)
originalStructureDefinitions

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

-- | 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) =>
  FoundRegistry b a ->
  GenericEntLocator s a ->
  FoundStructure b a ->
  s (Maybe (StructureIntactnessFailure a))
ensureStructureIntact :: forall (s :: * -> *) a b.
(Monad s, Hashable a) =>
FoundRegistry b a
-> GenericEntLocator s a
-> FoundStructure b a
-> s (Maybe (StructureIntactnessFailure a))
ensureStructureIntact FoundRegistry b a
registry GenericEntLocator s a
entLoader (PositionedStructure Cosmic Location
upperLeft (StructureWithGrid AbsoluteDir
_ RowWidth
_ (ExtractedArea NamedArea b
_ NonEmptyGrid (AtomicKeySymbol a)
g))) = do
  (Either (StructureIntactnessFailure a) (NonEmpty ())
 -> Maybe (StructureIntactnessFailure a))
-> s (Either (StructureIntactnessFailure a) (NonEmpty ()))
-> s (Maybe (StructureIntactnessFailure a))
forall a b. (a -> b) -> s a -> s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either (StructureIntactnessFailure a) (NonEmpty ())
-> Maybe (StructureIntactnessFailure a)
forall a b. Either a b -> Maybe a
leftToMaybe (s (Either (StructureIntactnessFailure a) (NonEmpty ()))
 -> s (Maybe (StructureIntactnessFailure a)))
-> (ExceptT (StructureIntactnessFailure a) s (NonEmpty ())
    -> s (Either (StructureIntactnessFailure a) (NonEmpty ())))
-> ExceptT (StructureIntactnessFailure a) s (NonEmpty ())
-> s (Maybe (StructureIntactnessFailure a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT (StructureIntactnessFailure a) s (NonEmpty ())
-> s (Either (StructureIntactnessFailure a) (NonEmpty ()))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (StructureIntactnessFailure a) s (NonEmpty ())
 -> s (Maybe (StructureIntactnessFailure a)))
-> ExceptT (StructureIntactnessFailure a) s (NonEmpty ())
-> s (Maybe (StructureIntactnessFailure a))
forall a b. (a -> b) -> a -> b
$ ((AtomicKeySymbol a, Cosmic Location)
 -> ExceptT (StructureIntactnessFailure a) s ())
-> NonEmpty (AtomicKeySymbol a, Cosmic Location)
-> ExceptT (StructureIntactnessFailure a) s (NonEmpty ())
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (AtomicKeySymbol a, Cosmic Location)
-> ExceptT (StructureIntactnessFailure a) s ()
forall {t :: * -> *}.
Foldable t =>
(t a, Cosmic Location)
-> ExceptT (StructureIntactnessFailure a) s ()
checkLoc NonEmpty (AtomicKeySymbol a, Cosmic Location)
allLocPairs
 where
  gridArea :: AreaDimensions
gridArea = NonEmptyGrid (AtomicKeySymbol a) -> AreaDimensions
forall a. NonEmptyGrid a -> AreaDimensions
getNEGridDimensions NonEmptyGrid (AtomicKeySymbol a)
g
  checkLoc :: (t a, Cosmic Location)
-> ExceptT (StructureIntactnessFailure a) s ()
checkLoc (t a
maybeTemplateEntity, Cosmic Location
loc) =
    t a
-> (a -> ExceptT (StructureIntactnessFailure a) s ())
-> ExceptT (StructureIntactnessFailure a) s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t a
maybeTemplateEntity ((a -> ExceptT (StructureIntactnessFailure a) s ())
 -> ExceptT (StructureIntactnessFailure a) s ())
-> (a -> ExceptT (StructureIntactnessFailure a) s ())
-> ExceptT (StructureIntactnessFailure a) s ()
forall a b. (a -> b) -> a -> b
$ \a
x -> do
      AtomicKeySymbol a
e <- s (AtomicKeySymbol a)
-> ExceptT (StructureIntactnessFailure a) s (AtomicKeySymbol a)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (StructureIntactnessFailure a) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (s (AtomicKeySymbol a)
 -> ExceptT (StructureIntactnessFailure a) s (AtomicKeySymbol a))
-> s (AtomicKeySymbol a)
-> ExceptT (StructureIntactnessFailure a) s (AtomicKeySymbol a)
forall a b. (a -> b) -> a -> b
$ GenericEntLocator s a
entLoader Cosmic Location
loc

      Maybe (PositionedStructure (StructureWithGrid b a))
-> (PositionedStructure (StructureWithGrid b a)
    -> ExceptT (StructureIntactnessFailure a) s Any)
-> ExceptT (StructureIntactnessFailure a) s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Cosmic Location
-> Map
     (Cosmic Location) (PositionedStructure (StructureWithGrid b a))
-> Maybe (PositionedStructure (StructureWithGrid b a))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Cosmic Location
loc (Map
   (Cosmic Location) (PositionedStructure (StructureWithGrid b a))
 -> Maybe (PositionedStructure (StructureWithGrid b a)))
-> Map
     (Cosmic Location) (PositionedStructure (StructureWithGrid b a))
-> Maybe (PositionedStructure (StructureWithGrid b a))
forall a b. (a -> b) -> a -> b
$ FoundRegistry b a
-> Map
     (Cosmic Location) (PositionedStructure (StructureWithGrid b a))
forall b a.
FoundRegistry b a -> Map (Cosmic Location) (FoundStructure b a)
foundByLocation FoundRegistry b a
registry) ((PositionedStructure (StructureWithGrid b a)
  -> ExceptT (StructureIntactnessFailure a) s Any)
 -> ExceptT (StructureIntactnessFailure a) s ())
-> (PositionedStructure (StructureWithGrid b a)
    -> ExceptT (StructureIntactnessFailure a) s Any)
-> ExceptT (StructureIntactnessFailure a) s ()
forall a b. (a -> b) -> a -> b
$ \PositionedStructure (StructureWithGrid b a)
s ->
        IntactnessFailureReason a
-> ExceptT (StructureIntactnessFailure a) s Any
forall {e} {a}.
IntactnessFailureReason e
-> ExceptT (StructureIntactnessFailure e) s a
errorPrefix
          (IntactnessFailureReason a
 -> ExceptT (StructureIntactnessFailure a) s Any)
-> (StructureWithGrid b a -> IntactnessFailureReason a)
-> StructureWithGrid b a
-> ExceptT (StructureIntactnessFailure a) s Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrientedStructure -> IntactnessFailureReason a
forall e. OrientedStructure -> IntactnessFailureReason e
AlreadyUsedBy
          (OrientedStructure -> IntactnessFailureReason a)
-> (StructureWithGrid b a -> OrientedStructure)
-> StructureWithGrid b a
-> IntactnessFailureReason a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StructureWithGrid b a -> OrientedStructure
forall b a. StructureWithGrid b a -> OrientedStructure
distillLabel
          (StructureWithGrid b a
 -> ExceptT (StructureIntactnessFailure a) s Any)
-> StructureWithGrid b a
-> ExceptT (StructureIntactnessFailure a) s Any
forall a b. (a -> b) -> a -> b
$ PositionedStructure (StructureWithGrid b a)
-> StructureWithGrid b a
forall s. PositionedStructure s -> s
structureWithGrid PositionedStructure (StructureWithGrid b a)
s

      Bool
-> ExceptT (StructureIntactnessFailure a) s ()
-> ExceptT (StructureIntactnessFailure a) s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AtomicKeySymbol a
e AtomicKeySymbol a -> AtomicKeySymbol a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> AtomicKeySymbol a
forall a. a -> Maybe a
Just a
x)
        (ExceptT (StructureIntactnessFailure a) s ()
 -> ExceptT (StructureIntactnessFailure a) s ())
-> (IntactnessFailureReason a
    -> ExceptT (StructureIntactnessFailure a) s ())
-> IntactnessFailureReason a
-> ExceptT (StructureIntactnessFailure a) s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntactnessFailureReason a
-> ExceptT (StructureIntactnessFailure a) s ()
forall {e} {a}.
IntactnessFailureReason e
-> ExceptT (StructureIntactnessFailure e) s a
errorPrefix
        (IntactnessFailureReason a
 -> ExceptT (StructureIntactnessFailure a) s ())
-> IntactnessFailureReason a
-> ExceptT (StructureIntactnessFailure a) s ()
forall a b. (a -> b) -> a -> b
$ EntityDiscrepancy a -> IntactnessFailureReason a
forall e. EntityDiscrepancy e -> IntactnessFailureReason e
DiscrepantEntity
        (EntityDiscrepancy a -> IntactnessFailureReason a)
-> EntityDiscrepancy a -> IntactnessFailureReason a
forall a b. (a -> b) -> a -> b
$ a -> AtomicKeySymbol a -> EntityDiscrepancy a
forall e. e -> AtomicKeySymbol e -> EntityDiscrepancy e
EntityDiscrepancy a
x AtomicKeySymbol a
e
   where
    errorPrefix :: IntactnessFailureReason e
-> ExceptT (StructureIntactnessFailure e) s a
errorPrefix =
      Either (StructureIntactnessFailure e) a
-> ExceptT (StructureIntactnessFailure e) s a
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except
        (Either (StructureIntactnessFailure e) a
 -> ExceptT (StructureIntactnessFailure e) s a)
-> (IntactnessFailureReason e
    -> Either (StructureIntactnessFailure e) a)
-> IntactnessFailureReason e
-> ExceptT (StructureIntactnessFailure e) s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StructureIntactnessFailure e
-> Either (StructureIntactnessFailure e) a
forall a b. a -> Either a b
Left
        (StructureIntactnessFailure e
 -> Either (StructureIntactnessFailure e) a)
-> (IntactnessFailureReason e -> StructureIntactnessFailure e)
-> IntactnessFailureReason e
-> Either (StructureIntactnessFailure e) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location
-> AreaDimensions
-> IntactnessFailureReason e
-> StructureIntactnessFailure e
forall e.
Location
-> AreaDimensions
-> IntactnessFailureReason e
-> StructureIntactnessFailure e
StructureIntactnessFailure (Cosmic Location
loc Cosmic Location
-> Getting Location (Cosmic Location) Location -> Location
forall s a. s -> Getting a s a -> a
^. Getting Location (Cosmic Location) Location
forall a1 a2 (f :: * -> *).
Functor f =>
(a1 -> f a2) -> Cosmic a1 -> f (Cosmic a2)
planar) AreaDimensions
gridArea

  f :: (Coords, b) -> (b, Cosmic Location)
f = (Coords -> Cosmic Location) -> (b, Coords) -> (b, Cosmic Location)
forall a b. (a -> b) -> (b, a) -> (b, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Cosmic Location
upperLeft Cosmic Location -> V2 Int32 -> Cosmic Location
`offsetBy`) (V2 Int32 -> Cosmic Location)
-> (Coords -> V2 Int32) -> Coords -> Cosmic Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> V2 Int32
asVector (Location -> V2 Int32)
-> (Coords -> Location) -> Coords -> V2 Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coords -> Location
coordsToLoc) ((b, Coords) -> (b, Cosmic Location))
-> ((Coords, b) -> (b, Coords))
-> (Coords, b)
-> (b, Cosmic Location)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coords, b) -> (b, Coords)
forall a b. (a, b) -> (b, a)
swap
  allLocPairs :: NonEmpty (AtomicKeySymbol a, Cosmic Location)
allLocPairs = (Coords
 -> AtomicKeySymbol a -> (AtomicKeySymbol a, Cosmic Location))
-> NonEmptyGrid (AtomicKeySymbol a)
-> NonEmpty (AtomicKeySymbol a, Cosmic Location)
forall a b. (Coords -> a -> b) -> NonEmptyGrid a -> NonEmpty b
mapWithCoordsNE (((Coords, AtomicKeySymbol a)
 -> (AtomicKeySymbol a, Cosmic Location))
-> Coords
-> AtomicKeySymbol a
-> (AtomicKeySymbol a, Cosmic Location)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (Coords, AtomicKeySymbol a) -> (AtomicKeySymbol a, Cosmic Location)
forall {b}. (Coords, b) -> (b, Cosmic Location)
f) NonEmptyGrid (AtomicKeySymbol a)
g