-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Registry of found structures.
-- This datatype contains two maps that must be kept in sync.
-- Uses smart constructors to maintain this invariant.
module Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (
  FoundRegistry,

  -- * Instantiation
  emptyFoundStructures,
  populateStaticFoundStructures,

  -- * Read-only accessors
  foundByName,
  foundByLocation,

  -- * Mutation
  addFound,
  removeStructure,
)
where

import Control.Arrow ((&&&))
import Data.List (partition, sortOn)
import Data.List.NonEmpty qualified as NE
import Data.Map (Map)
import Data.Map qualified as M
import Data.Map.NonEmpty (NEMap)
import Data.Map.NonEmpty qualified as NEM
import Data.Maybe (listToMaybe, maybeToList)
import Data.Ord (Down (Down))
import Data.Set qualified as Set
import Swarm.Game.Location
import Swarm.Game.Scenario.Topography.Structure.Named (StructureName, name)
import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
import Swarm.Game.Universe (Cosmic (..))
import Swarm.Language.Syntax.Direction (AbsoluteDir (..))
import Swarm.Util (binTuples, deleteKeys)

-- | The authoritative source of which built structures currently exist.
--
-- The two type parameters, `b` and `a`, correspond
-- to 'Cell' and 'Entity', respectively.
data FoundRegistry b a = FoundRegistry
  { forall b a.
FoundRegistry b a
-> Map
     StructureName
     (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
_foundByName :: Map StructureName (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
  , forall b a.
FoundRegistry b a -> Map (Cosmic Location) (FoundStructure b a)
_foundByLocation :: Map (Cosmic Location) (FoundStructure b a)
  }

emptyFoundStructures :: FoundRegistry b a
emptyFoundStructures :: forall b a. FoundRegistry b a
emptyFoundStructures = Map
  StructureName
  (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
-> Map (Cosmic Location) (FoundStructure b a) -> FoundRegistry b a
forall b a.
Map
  StructureName
  (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
-> Map (Cosmic Location) (FoundStructure b a) -> FoundRegistry b a
FoundRegistry Map
  StructureName
  (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
forall a. Monoid a => a
mempty Map (Cosmic Location) (FoundStructure b a)
forall a. Monoid a => a
mempty

-- | We use a 'NEMap' here so that we can use the
-- safe-indexing function 'indexWrapNonEmpty' in the implementation
-- of the @structure@ command.
foundByName :: FoundRegistry b a -> Map StructureName (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
foundByName :: forall b a.
FoundRegistry b a
-> Map
     StructureName
     (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
foundByName = FoundRegistry b a
-> Map
     StructureName
     (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
forall b a.
FoundRegistry b a
-> Map
     StructureName
     (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
_foundByName

-- | This is a worldwide "mask" that prevents members of placed
-- structures from participating in new structures and facilitates
-- deletion of structures when their elements are removed from the world.
--
-- Each recognized structure instance will have @MxN@ entries in this map.
foundByLocation :: FoundRegistry b a -> Map (Cosmic Location) (FoundStructure b a)
foundByLocation :: forall b a.
FoundRegistry b a -> Map (Cosmic Location) (FoundStructure b a)
foundByLocation = FoundRegistry b a -> Map (Cosmic Location) (FoundStructure b a)
forall b a.
FoundRegistry b a -> Map (Cosmic Location) (FoundStructure b a)
_foundByLocation

removeStructure :: FoundStructure b a -> FoundRegistry b a -> FoundRegistry b a
removeStructure :: forall b a.
FoundStructure b a -> FoundRegistry b a -> FoundRegistry b a
removeStructure FoundStructure b a
fs (FoundRegistry Map
  StructureName
  (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
byName Map (Cosmic Location) (FoundStructure b a)
byLoc) =
  Map
  StructureName
  (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
-> Map (Cosmic Location) (FoundStructure b a) -> FoundRegistry b a
forall b a.
Map
  StructureName
  (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
-> Map (Cosmic Location) (FoundStructure b a) -> FoundRegistry b a
FoundRegistry
    ((NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a)
 -> Maybe
      (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a)))
-> StructureName
-> Map
     StructureName
     (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
-> Map
     StructureName
     (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
M.update NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a)
-> Maybe
     (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
forall {a}.
NEMap (Cosmic Location, AbsoluteDir) a
-> Maybe (NEMap (Cosmic Location, AbsoluteDir) a)
tidyDelete StructureName
structureName Map
  StructureName
  (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
byName)
    ([Cosmic Location]
-> Map (Cosmic Location) (FoundStructure b a)
-> Map (Cosmic Location) (FoundStructure b a)
forall key elt. Ord key => [key] -> Map key elt -> Map key elt
deleteKeys [Cosmic Location]
allOccupiedCoords Map (Cosmic Location) (FoundStructure b a)
byLoc)
 where
  allOccupiedCoords :: [Cosmic Location]
allOccupiedCoords = FoundStructure b a -> [Cosmic Location]
forall b a. FoundStructure b a -> [Cosmic Location]
genOccupiedCoords FoundStructure b a
fs
  structureName :: StructureName
structureName = NamedArea b -> StructureName
forall a. NamedArea a -> StructureName
name (NamedArea b -> StructureName)
-> (StructureWithGrid b a -> NamedArea b)
-> StructureWithGrid 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)
-> (StructureWithGrid b a -> ExtractedArea b a)
-> StructureWithGrid b a
-> NamedArea b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StructureWithGrid b a -> ExtractedArea b a
forall b a. StructureWithGrid b a -> ExtractedArea b a
entityGrid (StructureWithGrid b a -> StructureName)
-> StructureWithGrid b a -> StructureName
forall a b. (a -> b) -> a -> b
$ FoundStructure b a -> StructureWithGrid b a
forall s. PositionedStructure s -> s
structureWithGrid FoundStructure b a
fs
  upperLeft :: Cosmic Location
upperLeft = FoundStructure b a -> Cosmic Location
forall s. PositionedStructure s -> Cosmic Location
upperLeftCorner FoundStructure b a
fs
  rotation :: AbsoluteDir
rotation = StructureWithGrid b a -> AbsoluteDir
forall b a. StructureWithGrid b a -> AbsoluteDir
rotatedTo (StructureWithGrid b a -> AbsoluteDir)
-> StructureWithGrid b a -> AbsoluteDir
forall a b. (a -> b) -> a -> b
$ FoundStructure b a -> StructureWithGrid b a
forall s. PositionedStructure s -> s
structureWithGrid FoundStructure b a
fs

  -- NOTE: Observe similarities to
  -- Swarm.Game.State.removeRobotFromLocationMap
  tidyDelete :: NEMap (Cosmic Location, AbsoluteDir) a
-> Maybe (NEMap (Cosmic Location, AbsoluteDir) a)
tidyDelete = Map (Cosmic Location, AbsoluteDir) a
-> Maybe (NEMap (Cosmic Location, AbsoluteDir) a)
forall k a. Map k a -> Maybe (NEMap k a)
NEM.nonEmptyMap (Map (Cosmic Location, AbsoluteDir) a
 -> Maybe (NEMap (Cosmic Location, AbsoluteDir) a))
-> (NEMap (Cosmic Location, AbsoluteDir) a
    -> Map (Cosmic Location, AbsoluteDir) a)
-> NEMap (Cosmic Location, AbsoluteDir) a
-> Maybe (NEMap (Cosmic Location, AbsoluteDir) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cosmic Location, AbsoluteDir)
-> NEMap (Cosmic Location, AbsoluteDir) a
-> Map (Cosmic Location, AbsoluteDir) a
forall k a. Ord k => k -> NEMap k a -> Map k a
NEM.delete (Cosmic Location
upperLeft, AbsoluteDir
rotation)

addFound :: FoundStructure b a -> FoundRegistry b a -> FoundRegistry b a
addFound :: forall b a.
FoundStructure b a -> FoundRegistry b a -> FoundRegistry b a
addFound fs :: FoundStructure b a
fs@(PositionedStructure Cosmic Location
loc StructureWithGrid b a
swg) (FoundRegistry Map
  StructureName
  (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
byName Map (Cosmic Location) (FoundStructure b a)
byLoc) =
  Map
  StructureName
  (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
-> Map (Cosmic Location) (FoundStructure b a) -> FoundRegistry b a
forall b a.
Map
  StructureName
  (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
-> Map (Cosmic Location) (FoundStructure b a) -> FoundRegistry b a
FoundRegistry
    ((NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a)
 -> NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a)
 -> NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
-> StructureName
-> NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a)
-> Map
     StructureName
     (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
-> Map
     StructureName
     (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a)
-> NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a)
-> NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a)
forall a. Semigroup a => a -> a -> a
(<>) StructureName
k ((Cosmic Location, AbsoluteDir)
-> StructureWithGrid b a
-> NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a)
forall k a. k -> a -> NEMap k a
NEM.singleton (Cosmic Location
loc, StructureWithGrid b a -> AbsoluteDir
forall b a. StructureWithGrid b a -> AbsoluteDir
rotatedTo StructureWithGrid b a
swg) StructureWithGrid b a
swg) Map
  StructureName
  (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
byName)
    (Map (Cosmic Location) (FoundStructure b a)
-> Map (Cosmic Location) (FoundStructure b a)
-> Map (Cosmic Location) (FoundStructure b a)
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map (Cosmic Location) (FoundStructure b a)
occupationMap Map (Cosmic Location) (FoundStructure b a)
byLoc)
 where
  k :: StructureName
k = NamedArea b -> StructureName
forall a. NamedArea a -> StructureName
name (NamedArea b -> StructureName)
-> (ExtractedArea b a -> NamedArea b)
-> ExtractedArea 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 -> StructureName)
-> ExtractedArea b a -> StructureName
forall a b. (a -> b) -> a -> b
$ StructureWithGrid b a -> ExtractedArea b a
forall b a. StructureWithGrid b a -> ExtractedArea b a
entityGrid StructureWithGrid b a
swg
  occupationMap :: Map (Cosmic Location) (FoundStructure b a)
occupationMap = [(Cosmic Location, FoundStructure b a)]
-> Map (Cosmic Location) (FoundStructure b a)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Cosmic Location, FoundStructure b a)]
 -> Map (Cosmic Location) (FoundStructure b a))
-> [(Cosmic Location, FoundStructure b a)]
-> Map (Cosmic Location) (FoundStructure b a)
forall a b. (a -> b) -> a -> b
$ (Cosmic Location -> (Cosmic Location, FoundStructure b a))
-> [Cosmic Location] -> [(Cosmic Location, FoundStructure b a)]
forall a b. (a -> b) -> [a] -> [b]
map (,FoundStructure b a
fs) ([Cosmic Location] -> [(Cosmic Location, FoundStructure b a)])
-> [Cosmic Location] -> [(Cosmic Location, FoundStructure b a)]
forall a b. (a -> b) -> a -> b
$ FoundStructure b a -> [Cosmic Location]
forall b a. FoundStructure b a -> [Cosmic Location]
genOccupiedCoords FoundStructure b a
fs

-- | Bulk insertion of structures statically placed in the scenario definition.
--
-- See the docs for 'Swarm.Game.State.Initialize.initializeRecognition' for more context.
--
-- Note that if any of these pre-placed structures overlap, we can't be sure of
-- the author's intent as to which member of the overlap should take precedence,
-- so perhaps it would be ideal to throw an error at scenario parse time.
--
-- However, determining whether a structure is all three of:
-- 1. placed
-- 2. still recognizable
-- 3. overlapping with another recognized structure
-- occurs at a later phase than scenario parse; it requires access to the 'GameState'.
--
-- So we just use the same sorting criteria as the one used to resolve recognition
-- conflicts at entity placement time (see [STRUCTURE RECOGNIZER CONFLICT RESOLUTION]).
populateStaticFoundStructures ::
  (Eq a, Eq b) =>
  [FoundStructure b a] ->
  FoundRegistry b a
populateStaticFoundStructures :: forall a b.
(Eq a, Eq b) =>
[FoundStructure b a] -> FoundRegistry b a
populateStaticFoundStructures [FoundStructure b a]
allFound =
  Map
  StructureName
  (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
-> Map (Cosmic Location) (FoundStructure b a) -> FoundRegistry b a
forall b a.
Map
  StructureName
  (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
-> Map (Cosmic Location) (FoundStructure b a) -> FoundRegistry b a
FoundRegistry Map
  StructureName
  (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
byName Map (Cosmic Location) (FoundStructure b a)
byLocation
 where
  resolvedCollisions :: [FoundStructure b a]
resolvedCollisions = [FoundStructure b a] -> [FoundStructure b a]
forall {b} {a}.
(Eq b, Eq a) =>
[PositionedStructure (StructureWithGrid b a)]
-> [PositionedStructure (StructureWithGrid b a)]
resolvePreplacementCollisions [FoundStructure b a]
allFound

  mkOccupationMap :: PositionedStructure (StructureWithGrid b a)
-> Map
     (Cosmic Location) (PositionedStructure (StructureWithGrid b a))
mkOccupationMap PositionedStructure (StructureWithGrid b a)
fs = [(Cosmic Location, PositionedStructure (StructureWithGrid b a))]
-> Map
     (Cosmic Location) (PositionedStructure (StructureWithGrid b a))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Cosmic Location, PositionedStructure (StructureWithGrid b a))]
 -> Map
      (Cosmic Location) (PositionedStructure (StructureWithGrid b a)))
-> [(Cosmic Location, PositionedStructure (StructureWithGrid b a))]
-> Map
     (Cosmic Location) (PositionedStructure (StructureWithGrid b a))
forall a b. (a -> b) -> a -> b
$ (Cosmic Location
 -> (Cosmic Location, PositionedStructure (StructureWithGrid b a)))
-> [Cosmic Location]
-> [(Cosmic Location, PositionedStructure (StructureWithGrid b a))]
forall a b. (a -> b) -> [a] -> [b]
map (,PositionedStructure (StructureWithGrid b a)
fs) ([Cosmic Location]
 -> [(Cosmic Location,
      PositionedStructure (StructureWithGrid b a))])
-> [Cosmic Location]
-> [(Cosmic Location, PositionedStructure (StructureWithGrid b a))]
forall a b. (a -> b) -> a -> b
$ PositionedStructure (StructureWithGrid b a) -> [Cosmic Location]
forall b a. FoundStructure b a -> [Cosmic Location]
genOccupiedCoords PositionedStructure (StructureWithGrid b a)
fs
  byLocation :: Map (Cosmic Location) (FoundStructure b a)
byLocation = [Map (Cosmic Location) (FoundStructure b a)]
-> Map (Cosmic Location) (FoundStructure b a)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions ([Map (Cosmic Location) (FoundStructure b a)]
 -> Map (Cosmic Location) (FoundStructure b a))
-> [Map (Cosmic Location) (FoundStructure b a)]
-> Map (Cosmic Location) (FoundStructure b a)
forall a b. (a -> b) -> a -> b
$ (FoundStructure b a -> Map (Cosmic Location) (FoundStructure b a))
-> [FoundStructure b a]
-> [Map (Cosmic Location) (FoundStructure b a)]
forall a b. (a -> b) -> [a] -> [b]
map FoundStructure b a -> Map (Cosmic Location) (FoundStructure b a)
forall {b} {a}.
PositionedStructure (StructureWithGrid b a)
-> Map
     (Cosmic Location) (PositionedStructure (StructureWithGrid b a))
mkOccupationMap [FoundStructure b a]
resolvedCollisions

  byName :: Map
  StructureName
  (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
byName =
    (NonEmpty (FoundStructure b a)
 -> NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
-> Map StructureName (NonEmpty (FoundStructure b a))
-> Map
     StructureName
     (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (NonEmpty ((Cosmic Location, AbsoluteDir), StructureWithGrid b a)
-> NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a)
forall k a. Ord k => NonEmpty (k, a) -> NEMap k a
NEM.fromList (NonEmpty ((Cosmic Location, AbsoluteDir), StructureWithGrid b a)
 -> NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
-> (NonEmpty (FoundStructure b a)
    -> NonEmpty
         ((Cosmic Location, AbsoluteDir), StructureWithGrid b a))
-> NonEmpty (FoundStructure b a)
-> NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FoundStructure b a
 -> ((Cosmic Location, AbsoluteDir), StructureWithGrid b a))
-> NonEmpty (FoundStructure b a)
-> NonEmpty ((Cosmic Location, AbsoluteDir), StructureWithGrid b a)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map ((FoundStructure b a -> Cosmic Location
forall s. PositionedStructure s -> Cosmic Location
upperLeftCorner (FoundStructure b a -> Cosmic Location)
-> (FoundStructure b a -> AbsoluteDir)
-> FoundStructure b a
-> (Cosmic Location, AbsoluteDir)
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')
&&& StructureWithGrid b a -> AbsoluteDir
forall b a. StructureWithGrid b a -> AbsoluteDir
rotatedTo (StructureWithGrid b a -> AbsoluteDir)
-> (FoundStructure b a -> StructureWithGrid b a)
-> FoundStructure b a
-> AbsoluteDir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FoundStructure b a -> StructureWithGrid b a
forall s. PositionedStructure s -> s
structureWithGrid) (FoundStructure b a -> (Cosmic Location, AbsoluteDir))
-> (FoundStructure b a -> StructureWithGrid b a)
-> FoundStructure b a
-> ((Cosmic Location, AbsoluteDir), StructureWithGrid 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')
&&& FoundStructure b a -> StructureWithGrid b a
forall s. PositionedStructure s -> s
structureWithGrid)) (Map StructureName (NonEmpty (FoundStructure b a))
 -> Map
      StructureName
      (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a)))
-> Map StructureName (NonEmpty (FoundStructure b a))
-> Map
     StructureName
     (NEMap (Cosmic Location, AbsoluteDir) (StructureWithGrid b a))
forall a b. (a -> b) -> a -> b
$
      [(StructureName, FoundStructure b a)]
-> Map StructureName (NonEmpty (FoundStructure b a))
forall (t :: * -> *) a b.
(Foldable t, Ord a) =>
t (a, b) -> Map a (NonEmpty b)
binTuples ([(StructureName, FoundStructure b a)]
 -> Map StructureName (NonEmpty (FoundStructure b a)))
-> [(StructureName, FoundStructure b a)]
-> Map StructureName (NonEmpty (FoundStructure b a))
forall a b. (a -> b) -> a -> b
$
        (FoundStructure b a -> (StructureName, FoundStructure b a))
-> [FoundStructure b a] -> [(StructureName, FoundStructure b a)]
forall a b. (a -> b) -> [a] -> [b]
map (NamedArea b -> StructureName
forall a. NamedArea a -> StructureName
name (NamedArea b -> StructureName)
-> (FoundStructure b a -> NamedArea b)
-> FoundStructure 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)
-> (FoundStructure b a -> ExtractedArea b a)
-> FoundStructure b a
-> NamedArea b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StructureWithGrid b a -> ExtractedArea b a
forall b a. StructureWithGrid b a -> ExtractedArea b a
entityGrid (StructureWithGrid b a -> ExtractedArea b a)
-> (FoundStructure b a -> StructureWithGrid b a)
-> FoundStructure b a
-> ExtractedArea b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FoundStructure b a -> StructureWithGrid b a
forall s. PositionedStructure s -> s
structureWithGrid (FoundStructure b a -> StructureName)
-> (FoundStructure b a -> FoundStructure b a)
-> FoundStructure b a
-> (StructureName, FoundStructure 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')
&&& FoundStructure b a -> FoundStructure b a
forall a. a -> a
id) [FoundStructure b a]
resolvedCollisions

  resolvePreplacementCollisions :: [PositionedStructure (StructureWithGrid b a)]
-> [PositionedStructure (StructureWithGrid b a)]
resolvePreplacementCollisions [PositionedStructure (StructureWithGrid b a)]
foundList =
    [PositionedStructure (StructureWithGrid b a)]
nonOverlappingFound [PositionedStructure (StructureWithGrid b a)]
-> [PositionedStructure (StructureWithGrid b a)]
-> [PositionedStructure (StructureWithGrid b a)]
forall a. Semigroup a => a -> a -> a
<> Maybe (PositionedStructure (StructureWithGrid b a))
-> [PositionedStructure (StructureWithGrid b a)]
forall a. Maybe a -> [a]
maybeToList ([PositionedStructure (StructureWithGrid b a)]
-> Maybe (PositionedStructure (StructureWithGrid b a))
forall a. [a] -> Maybe a
listToMaybe [PositionedStructure (StructureWithGrid b a)]
overlapsByDecreasingPreference)
   where
    overlapsByDecreasingPreference :: [PositionedStructure (StructureWithGrid b a)]
overlapsByDecreasingPreference = (PositionedStructure (StructureWithGrid b a)
 -> Down (PositionedStructure (StructureWithGrid b a)))
-> [PositionedStructure (StructureWithGrid b a)]
-> [PositionedStructure (StructureWithGrid b a)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn PositionedStructure (StructureWithGrid b a)
-> Down (PositionedStructure (StructureWithGrid b a))
forall a. a -> Down a
Down [PositionedStructure (StructureWithGrid b a)]
overlappingFound

    ([PositionedStructure (StructureWithGrid b a)]
overlappingFound, [PositionedStructure (StructureWithGrid b a)]
nonOverlappingFound) =
      (PositionedStructure (StructureWithGrid b a) -> Bool)
-> [PositionedStructure (StructureWithGrid b a)]
-> ([PositionedStructure (StructureWithGrid b a)],
    [PositionedStructure (StructureWithGrid b a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((PositionedStructure OrientedStructure
-> Set (PositionedStructure OrientedStructure) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (PositionedStructure OrientedStructure)
overlappingPlacements) (PositionedStructure OrientedStructure -> Bool)
-> (PositionedStructure (StructureWithGrid b a)
    -> PositionedStructure OrientedStructure)
-> PositionedStructure (StructureWithGrid b a)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StructureWithGrid b a -> OrientedStructure)
-> PositionedStructure (StructureWithGrid b a)
-> PositionedStructure OrientedStructure
forall a b.
(a -> b) -> PositionedStructure a -> PositionedStructure b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StructureWithGrid b a -> OrientedStructure
forall b a. StructureWithGrid b a -> OrientedStructure
distillLabel) [PositionedStructure (StructureWithGrid b a)]
foundList

    -- We convert the full-fledged FoundStructure record
    -- to a less-expensive identity-preserving form
    -- for the purpose of set membership
    overlappingPlacements :: Set (PositionedStructure OrientedStructure)
overlappingPlacements =
      [PositionedStructure OrientedStructure]
-> Set (PositionedStructure OrientedStructure)
forall a. Ord a => [a] -> Set a
Set.fromList
        ([PositionedStructure OrientedStructure]
 -> Set (PositionedStructure OrientedStructure))
-> ([Map
       (Cosmic Location)
       (NonEmpty (PositionedStructure (StructureWithGrid b a)))]
    -> [PositionedStructure OrientedStructure])
-> [Map
      (Cosmic Location)
      (NonEmpty (PositionedStructure (StructureWithGrid b a)))]
-> Set (PositionedStructure OrientedStructure)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PositionedStructure (StructureWithGrid b a)
 -> PositionedStructure OrientedStructure)
-> [PositionedStructure (StructureWithGrid b a)]
-> [PositionedStructure OrientedStructure]
forall a b. (a -> b) -> [a] -> [b]
map ((StructureWithGrid b a -> OrientedStructure)
-> PositionedStructure (StructureWithGrid b a)
-> PositionedStructure OrientedStructure
forall a b.
(a -> b) -> PositionedStructure a -> PositionedStructure b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StructureWithGrid b a -> OrientedStructure
forall b a. StructureWithGrid b a -> OrientedStructure
distillLabel)
        ([PositionedStructure (StructureWithGrid b a)]
 -> [PositionedStructure OrientedStructure])
-> ([Map
       (Cosmic Location)
       (NonEmpty (PositionedStructure (StructureWithGrid b a)))]
    -> [PositionedStructure (StructureWithGrid b a)])
-> [Map
      (Cosmic Location)
      (NonEmpty (PositionedStructure (StructureWithGrid b a)))]
-> [PositionedStructure OrientedStructure]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (PositionedStructure (StructureWithGrid b a))
 -> [PositionedStructure (StructureWithGrid b a)])
-> [NonEmpty (PositionedStructure (StructureWithGrid b a))]
-> [PositionedStructure (StructureWithGrid b a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty (PositionedStructure (StructureWithGrid b a))
-> [PositionedStructure (StructureWithGrid b a)]
forall a. NonEmpty a -> [a]
NE.toList
        ([NonEmpty (PositionedStructure (StructureWithGrid b a))]
 -> [PositionedStructure (StructureWithGrid b a)])
-> ([Map
       (Cosmic Location)
       (NonEmpty (PositionedStructure (StructureWithGrid b a)))]
    -> [NonEmpty (PositionedStructure (StructureWithGrid b a))])
-> [Map
      (Cosmic Location)
      (NonEmpty (PositionedStructure (StructureWithGrid b a)))]
-> [PositionedStructure (StructureWithGrid b a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map
  (Cosmic Location)
  (NonEmpty (PositionedStructure (StructureWithGrid b a)))
-> [NonEmpty (PositionedStructure (StructureWithGrid b a))]
forall k a. Map k a -> [a]
M.elems
        (Map
   (Cosmic Location)
   (NonEmpty (PositionedStructure (StructureWithGrid b a)))
 -> [NonEmpty (PositionedStructure (StructureWithGrid b a))])
-> ([Map
       (Cosmic Location)
       (NonEmpty (PositionedStructure (StructureWithGrid b a)))]
    -> Map
         (Cosmic Location)
         (NonEmpty (PositionedStructure (StructureWithGrid b a))))
-> [Map
      (Cosmic Location)
      (NonEmpty (PositionedStructure (StructureWithGrid b a)))]
-> [NonEmpty (PositionedStructure (StructureWithGrid b a))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (PositionedStructure (StructureWithGrid b a)) -> Bool)
-> Map
     (Cosmic Location)
     (NonEmpty (PositionedStructure (StructureWithGrid b a)))
-> Map
     (Cosmic Location)
     (NonEmpty (PositionedStructure (StructureWithGrid b a)))
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Int -> Bool)
-> (NonEmpty (PositionedStructure (StructureWithGrid b a)) -> Int)
-> NonEmpty (PositionedStructure (StructureWithGrid b a))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (PositionedStructure (StructureWithGrid b a)) -> Int
forall a. NonEmpty a -> Int
NE.length)
        (Map
   (Cosmic Location)
   (NonEmpty (PositionedStructure (StructureWithGrid b a)))
 -> Map
      (Cosmic Location)
      (NonEmpty (PositionedStructure (StructureWithGrid b a))))
-> ([Map
       (Cosmic Location)
       (NonEmpty (PositionedStructure (StructureWithGrid b a)))]
    -> Map
         (Cosmic Location)
         (NonEmpty (PositionedStructure (StructureWithGrid b a))))
-> [Map
      (Cosmic Location)
      (NonEmpty (PositionedStructure (StructureWithGrid b a)))]
-> Map
     (Cosmic Location)
     (NonEmpty (PositionedStructure (StructureWithGrid b a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (PositionedStructure (StructureWithGrid b a))
 -> NonEmpty (PositionedStructure (StructureWithGrid b a))
 -> NonEmpty (PositionedStructure (StructureWithGrid b a)))
-> [Map
      (Cosmic Location)
      (NonEmpty (PositionedStructure (StructureWithGrid b a)))]
-> Map
     (Cosmic Location)
     (NonEmpty (PositionedStructure (StructureWithGrid b a)))
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith NonEmpty (PositionedStructure (StructureWithGrid b a))
-> NonEmpty (PositionedStructure (StructureWithGrid b a))
-> NonEmpty (PositionedStructure (StructureWithGrid b a))
forall a. Semigroup a => a -> a -> a
(<>)
        ([Map
    (Cosmic Location)
    (NonEmpty (PositionedStructure (StructureWithGrid b a)))]
 -> Set (PositionedStructure OrientedStructure))
-> [Map
      (Cosmic Location)
      (NonEmpty (PositionedStructure (StructureWithGrid b a)))]
-> Set (PositionedStructure OrientedStructure)
forall a b. (a -> b) -> a -> b
$ (PositionedStructure (StructureWithGrid b a)
 -> Map
      (Cosmic Location)
      (NonEmpty (PositionedStructure (StructureWithGrid b a))))
-> [PositionedStructure (StructureWithGrid b a)]
-> [Map
      (Cosmic Location)
      (NonEmpty (PositionedStructure (StructureWithGrid b a)))]
forall a b. (a -> b) -> [a] -> [b]
map ((PositionedStructure (StructureWithGrid b a)
 -> NonEmpty (PositionedStructure (StructureWithGrid b a)))
-> Map
     (Cosmic Location) (PositionedStructure (StructureWithGrid b a))
-> Map
     (Cosmic Location)
     (NonEmpty (PositionedStructure (StructureWithGrid b a)))
forall a b k. (a -> b) -> Map k a -> Map k b
M.map PositionedStructure (StructureWithGrid b a)
-> NonEmpty (PositionedStructure (StructureWithGrid b a))
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map
   (Cosmic Location) (PositionedStructure (StructureWithGrid b a))
 -> Map
      (Cosmic Location)
      (NonEmpty (PositionedStructure (StructureWithGrid b a))))
-> (PositionedStructure (StructureWithGrid b a)
    -> Map
         (Cosmic Location) (PositionedStructure (StructureWithGrid b a)))
-> PositionedStructure (StructureWithGrid b a)
-> Map
     (Cosmic Location)
     (NonEmpty (PositionedStructure (StructureWithGrid b a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PositionedStructure (StructureWithGrid b a)
-> Map
     (Cosmic Location) (PositionedStructure (StructureWithGrid b a))
forall {b} {a}.
PositionedStructure (StructureWithGrid b a)
-> Map
     (Cosmic Location) (PositionedStructure (StructureWithGrid b a))
mkOccupationMap) [PositionedStructure (StructureWithGrid b a)]
foundList