-- |
-- 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.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 Swarm.Game.Location (Location)
import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
import Swarm.Game.Universe (Cosmic)
import Swarm.Util (binTuples, deleteKeys)

-- | The authoritative source of which built structures currently exist.
--
-- The two type parameters, `b` and `a`, correspond
-- to 'StructureCells' and 'Entity', respectively.
data FoundRegistry b a = FoundRegistry
  { forall b a.
FoundRegistry b a
-> Map
     OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
_foundByName :: Map OriginalName (NEMap (Cosmic Location) (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 OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
-> Map (Cosmic Location) (FoundStructure b a) -> FoundRegistry b a
forall b a.
Map OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
-> Map (Cosmic Location) (FoundStructure b a) -> FoundRegistry b a
FoundRegistry Map OriginalName (NEMap (Cosmic Location) (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 OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
foundByName :: forall b a.
FoundRegistry b a
-> Map
     OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
foundByName = FoundRegistry b a
-> Map
     OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
forall b a.
FoundRegistry b a
-> Map
     OriginalName (NEMap (Cosmic Location) (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 OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
byName Map (Cosmic Location) (FoundStructure b a)
byLoc) =
  Map OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
-> Map (Cosmic Location) (FoundStructure b a) -> FoundRegistry b a
forall b a.
Map OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
-> Map (Cosmic Location) (FoundStructure b a) -> FoundRegistry b a
FoundRegistry
    ((NEMap (Cosmic Location) (StructureWithGrid b a)
 -> Maybe (NEMap (Cosmic Location) (StructureWithGrid b a)))
-> OriginalName
-> Map
     OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
-> Map
     OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
M.update NEMap (Cosmic Location) (StructureWithGrid b a)
-> Maybe (NEMap (Cosmic Location) (StructureWithGrid b a))
forall {a}.
NEMap (Cosmic Location) a -> Maybe (NEMap (Cosmic Location) a)
tidyDelete OriginalName
structureName Map OriginalName (NEMap (Cosmic Location) (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 :: OriginalName
structureName = NamedOriginal b -> OriginalName
forall a. NamedOriginal a -> OriginalName
getName (NamedOriginal b -> OriginalName)
-> NamedOriginal b -> OriginalName
forall a b. (a -> b) -> a -> b
$ StructureWithGrid b a -> NamedOriginal b
forall b a. StructureWithGrid b a -> NamedOriginal b
originalDefinition (StructureWithGrid b a -> NamedOriginal b)
-> StructureWithGrid b a -> NamedOriginal b
forall a b. (a -> b) -> a -> b
$ FoundStructure b a -> StructureWithGrid b a
forall b a. FoundStructure b a -> StructureWithGrid b a
structureWithGrid FoundStructure b a
fs
  upperLeft :: Cosmic Location
upperLeft = FoundStructure b a -> Cosmic Location
forall b a. FoundStructure b a -> Cosmic Location
upperLeftCorner FoundStructure b a
fs

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

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@(FoundStructure StructureWithGrid b a
swg Cosmic Location
loc) (FoundRegistry Map OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
byName Map (Cosmic Location) (FoundStructure b a)
byLoc) =
  Map OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
-> Map (Cosmic Location) (FoundStructure b a) -> FoundRegistry b a
forall b a.
Map OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
-> Map (Cosmic Location) (FoundStructure b a) -> FoundRegistry b a
FoundRegistry
    ((NEMap (Cosmic Location) (StructureWithGrid b a)
 -> NEMap (Cosmic Location) (StructureWithGrid b a)
 -> NEMap (Cosmic Location) (StructureWithGrid b a))
-> OriginalName
-> NEMap (Cosmic Location) (StructureWithGrid b a)
-> Map
     OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
-> Map
     OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith NEMap (Cosmic Location) (StructureWithGrid b a)
-> NEMap (Cosmic Location) (StructureWithGrid b a)
-> NEMap (Cosmic Location) (StructureWithGrid b a)
forall a. Semigroup a => a -> a -> a
(<>) OriginalName
k (Cosmic Location
-> StructureWithGrid b a
-> NEMap (Cosmic Location) (StructureWithGrid b a)
forall k a. k -> a -> NEMap k a
NEM.singleton Cosmic Location
loc StructureWithGrid b a
swg) Map OriginalName (NEMap (Cosmic Location) (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 :: OriginalName
k = NamedOriginal b -> OriginalName
forall a. NamedOriginal a -> OriginalName
getName (NamedOriginal b -> OriginalName)
-> NamedOriginal b -> OriginalName
forall a b. (a -> b) -> a -> b
$ StructureWithGrid b a -> NamedOriginal b
forall b a. StructureWithGrid b a -> NamedOriginal b
originalDefinition 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 found structures.
--
-- Each of these shall have been re-checked in case
-- a subsequent placement occludes them.
populateStaticFoundStructures :: [FoundStructure b a] -> FoundRegistry b a
populateStaticFoundStructures :: forall b a. [FoundStructure b a] -> FoundRegistry b a
populateStaticFoundStructures [FoundStructure b a]
allFound =
  Map OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
-> Map (Cosmic Location) (FoundStructure b a) -> FoundRegistry b a
forall b a.
Map OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
-> Map (Cosmic Location) (FoundStructure b a) -> FoundRegistry b a
FoundRegistry Map OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
byName Map (Cosmic Location) (FoundStructure b a)
byLocation
 where
  mkOccupationMap :: FoundStructure b a -> Map (Cosmic Location) (FoundStructure b a)
mkOccupationMap FoundStructure b a
fs = [(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
  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}.
FoundStructure b a -> Map (Cosmic Location) (FoundStructure b a)
mkOccupationMap [FoundStructure b a]
allFound

  byName :: Map OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
byName =
    (NonEmpty (FoundStructure b a)
 -> NEMap (Cosmic Location) (StructureWithGrid b a))
-> Map OriginalName (NonEmpty (FoundStructure b a))
-> Map
     OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (NonEmpty (Cosmic Location, StructureWithGrid b a)
-> NEMap (Cosmic Location) (StructureWithGrid b a)
forall k a. Ord k => NonEmpty (k, a) -> NEMap k a
NEM.fromList (NonEmpty (Cosmic Location, StructureWithGrid b a)
 -> NEMap (Cosmic Location) (StructureWithGrid b a))
-> (NonEmpty (FoundStructure b a)
    -> NonEmpty (Cosmic Location, StructureWithGrid b a))
-> NonEmpty (FoundStructure b a)
-> NEMap (Cosmic Location) (StructureWithGrid b a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FoundStructure b a -> (Cosmic Location, StructureWithGrid b a))
-> NonEmpty (FoundStructure b a)
-> NonEmpty (Cosmic Location, StructureWithGrid b a)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (FoundStructure b a -> Cosmic Location
forall b a. FoundStructure b a -> Cosmic Location
upperLeftCorner (FoundStructure b a -> Cosmic Location)
-> (FoundStructure b a -> StructureWithGrid b a)
-> FoundStructure b a
-> (Cosmic Location, 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 b a. FoundStructure b a -> StructureWithGrid b a
structureWithGrid)) (Map OriginalName (NonEmpty (FoundStructure b a))
 -> Map
      OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a)))
-> Map OriginalName (NonEmpty (FoundStructure b a))
-> Map
     OriginalName (NEMap (Cosmic Location) (StructureWithGrid b a))
forall a b. (a -> b) -> a -> b
$
      [(OriginalName, FoundStructure b a)]
-> Map OriginalName (NonEmpty (FoundStructure b a))
forall (t :: * -> *) a b.
(Foldable t, Ord a) =>
t (a, b) -> Map a (NonEmpty b)
binTuples ([(OriginalName, FoundStructure b a)]
 -> Map OriginalName (NonEmpty (FoundStructure b a)))
-> [(OriginalName, FoundStructure b a)]
-> Map OriginalName (NonEmpty (FoundStructure b a))
forall a b. (a -> b) -> a -> b
$
        (FoundStructure b a -> (OriginalName, FoundStructure b a))
-> [FoundStructure b a] -> [(OriginalName, FoundStructure b a)]
forall a b. (a -> b) -> [a] -> [b]
map (NamedOriginal b -> OriginalName
forall a. NamedOriginal a -> OriginalName
getName (NamedOriginal b -> OriginalName)
-> (FoundStructure b a -> NamedOriginal b)
-> FoundStructure b a
-> OriginalName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StructureWithGrid b a -> NamedOriginal b
forall b a. StructureWithGrid b a -> NamedOriginal b
originalDefinition (StructureWithGrid b a -> NamedOriginal b)
-> (FoundStructure b a -> StructureWithGrid b a)
-> FoundStructure b a
-> NamedOriginal b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FoundStructure b a -> StructureWithGrid b a
forall b a. FoundStructure b a -> StructureWithGrid b a
structureWithGrid (FoundStructure b a -> OriginalName)
-> (FoundStructure b a -> FoundStructure b a)
-> FoundStructure b a
-> (OriginalName, 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]
allFound