-- |
-- SPDX-License-Identifier: BSD-3-Clause
module Swarm.Game.Scenario.Topography.WorldPalette where

import Control.Lens hiding (from, (.=), (<.>))
import Data.Aeson.KeyMap qualified as KM
import Data.Map qualified as M
import Data.Maybe (catMaybes)
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Tuple (swap)
import Swarm.Game.Entity
import Swarm.Game.Scenario.Topography.Cell
import Swarm.Game.Scenario.Topography.EntityFacade
import Swarm.Game.Scenario.Topography.Grid
import Swarm.Game.Scenario.Topography.ProtoCell
import Swarm.Game.Terrain (TerrainType)
import Swarm.Util.Erasable

-- | A world palette maps characters to 'Cell' values.
type WorldPalette e = StructurePalette (PCell e)

type TerrainWith a = (TerrainType, Erasable a)

cellToTerrainPair :: CellPaintDisplay -> TerrainWith EntityFacade
cellToTerrainPair :: CellPaintDisplay -> TerrainWith EntityFacade
cellToTerrainPair (Cell TerrainType
terrain Erasable EntityFacade
erasableEntity [IndexedTRobot]
_) = (TerrainType
terrain, Erasable EntityFacade
erasableEntity)

toCellPaintDisplay :: Cell -> CellPaintDisplay
toCellPaintDisplay :: Cell -> CellPaintDisplay
toCellPaintDisplay (Cell TerrainType
terrain Erasable Entity
maybeEntity [IndexedTRobot]
r) =
  TerrainType
-> Erasable EntityFacade -> [IndexedTRobot] -> CellPaintDisplay
forall e. TerrainType -> Erasable e -> [IndexedTRobot] -> PCell e
Cell TerrainType
terrain (Entity -> EntityFacade
mkFacade (Entity -> EntityFacade)
-> Erasable Entity -> Erasable EntityFacade
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Erasable Entity
maybeEntity) [IndexedTRobot]
r

toKey :: TerrainWith EntityFacade -> TerrainWith EntityName
toKey :: TerrainWith EntityFacade -> TerrainWith EntityName
toKey = (Erasable EntityFacade -> Erasable EntityName)
-> TerrainWith EntityFacade -> TerrainWith EntityName
forall a b. (a -> b) -> (TerrainType, a) -> (TerrainType, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Erasable EntityFacade -> Erasable EntityName)
 -> TerrainWith EntityFacade -> TerrainWith EntityName)
-> (Erasable EntityFacade -> Erasable EntityName)
-> TerrainWith EntityFacade
-> TerrainWith EntityName
forall a b. (a -> b) -> a -> b
$ (EntityFacade -> EntityName)
-> Erasable EntityFacade -> Erasable EntityName
forall a b. (a -> b) -> Erasable a -> Erasable b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(EntityFacade EntityName
eName Display
_display) -> EntityName
eName)

-- | We want to identify all of the unique (terrain, entity facade) pairs.
-- However, "EntityFacade" includes a "Display" record, which contains more
-- fields than desirable for use as a unique key.
-- Therefore, we extract just the entity name for use in a
-- (terrain, entity name) key, and couple it with the original
-- (terrain, entity facade) pair in a Map.
getUniqueTerrainFacadePairs ::
  [CellPaintDisplay] ->
  M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
getUniqueTerrainFacadePairs :: [CellPaintDisplay]
-> Map (TerrainWith EntityName) (TerrainWith EntityFacade)
getUniqueTerrainFacadePairs [CellPaintDisplay]
cellGrid =
  [(TerrainWith EntityName, TerrainWith EntityFacade)]
-> Map (TerrainWith EntityName) (TerrainWith EntityFacade)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(TerrainWith EntityName, TerrainWith EntityFacade)]
 -> Map (TerrainWith EntityName) (TerrainWith EntityFacade))
-> [(TerrainWith EntityName, TerrainWith EntityFacade)]
-> Map (TerrainWith EntityName) (TerrainWith EntityFacade)
forall a b. (a -> b) -> a -> b
$ (CellPaintDisplay
 -> (TerrainWith EntityName, TerrainWith EntityFacade))
-> [CellPaintDisplay]
-> [(TerrainWith EntityName, TerrainWith EntityFacade)]
forall a b. (a -> b) -> [a] -> [b]
map CellPaintDisplay
-> (TerrainWith EntityName, TerrainWith EntityFacade)
genTuple [CellPaintDisplay]
cellGrid
 where
  genTuple :: CellPaintDisplay
-> (TerrainWith EntityName, TerrainWith EntityFacade)
genTuple CellPaintDisplay
c =
    (TerrainWith EntityFacade -> TerrainWith EntityName
toKey TerrainWith EntityFacade
terrainEfd, TerrainWith EntityFacade
terrainEfd)
   where
    terrainEfd :: TerrainWith EntityFacade
terrainEfd = CellPaintDisplay -> TerrainWith EntityFacade
cellToTerrainPair CellPaintDisplay
c

constructPalette ::
  [(Char, TerrainWith EntityFacade)] ->
  KM.KeyMap CellPaintDisplay
constructPalette :: [(Char, TerrainWith EntityFacade)] -> KeyMap CellPaintDisplay
constructPalette [(Char, TerrainWith EntityFacade)]
mappedPairs =
  Map EntityName CellPaintDisplay -> KeyMap CellPaintDisplay
forall v. Map EntityName v -> KeyMap v
KM.fromMapText Map EntityName CellPaintDisplay
terrainEntityPalette
 where
  g :: (TerrainType, Erasable e) -> PCell e
g (TerrainType
terrain, Erasable e
maybeEfd) = TerrainType -> Erasable e -> [IndexedTRobot] -> PCell e
forall e. TerrainType -> Erasable e -> [IndexedTRobot] -> PCell e
Cell TerrainType
terrain Erasable e
maybeEfd []
  terrainEntityPalette :: Map EntityName CellPaintDisplay
terrainEntityPalette = [(EntityName, CellPaintDisplay)] -> Map EntityName CellPaintDisplay
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(EntityName, CellPaintDisplay)]
 -> Map EntityName CellPaintDisplay)
-> [(EntityName, CellPaintDisplay)]
-> Map EntityName CellPaintDisplay
forall a b. (a -> b) -> a -> b
$ ((Char, TerrainWith EntityFacade)
 -> (EntityName, CellPaintDisplay))
-> [(Char, TerrainWith EntityFacade)]
-> [(EntityName, CellPaintDisplay)]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> EntityName)
-> (TerrainWith EntityFacade -> CellPaintDisplay)
-> (Char, TerrainWith EntityFacade)
-> (EntityName, CellPaintDisplay)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Char -> EntityName
T.singleton TerrainWith EntityFacade -> CellPaintDisplay
forall {e}. (TerrainType, Erasable e) -> PCell e
g) [(Char, TerrainWith EntityFacade)]
mappedPairs

constructWorldMap ::
  [(Char, TerrainWith EntityFacade)] ->
  -- | Mask char
  Char ->
  Grid (Maybe CellPaintDisplay) ->
  String
constructWorldMap :: [(Char, TerrainWith EntityFacade)]
-> Char -> Grid (Maybe CellPaintDisplay) -> [Char]
constructWorldMap [(Char, TerrainWith EntityFacade)]
mappedPairs Char
maskChar =
  [[Char]] -> [Char]
unlines ([[Char]] -> [Char])
-> (Grid (Maybe CellPaintDisplay) -> [[Char]])
-> Grid (Maybe CellPaintDisplay)
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Grid Char -> [[Char]]
forall a. Grid a -> [[a]]
getRows (Grid Char -> [[Char]])
-> (Grid (Maybe CellPaintDisplay) -> Grid Char)
-> Grid (Maybe CellPaintDisplay)
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe CellPaintDisplay -> Char)
-> Grid (Maybe CellPaintDisplay) -> Grid Char
forall a b. (a -> b) -> Grid a -> Grid b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe CellPaintDisplay -> Char
renderMapCell
 where
  invertedMappedPairs :: [(TerrainWith EntityName, Char)]
invertedMappedPairs = ((Char, TerrainWith EntityFacade)
 -> (TerrainWith EntityName, Char))
-> [(Char, TerrainWith EntityFacade)]
-> [(TerrainWith EntityName, Char)]
forall a b. (a -> b) -> [a] -> [b]
map ((Char, TerrainWith EntityName) -> (TerrainWith EntityName, Char)
forall a b. (a, b) -> (b, a)
swap ((Char, TerrainWith EntityName) -> (TerrainWith EntityName, Char))
-> ((Char, TerrainWith EntityFacade)
    -> (Char, TerrainWith EntityName))
-> (Char, TerrainWith EntityFacade)
-> (TerrainWith EntityName, Char)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TerrainWith EntityFacade -> TerrainWith EntityName)
-> (Char, TerrainWith EntityFacade)
-> (Char, TerrainWith EntityName)
forall a b. (a -> b) -> (Char, a) -> (Char, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TerrainWith EntityFacade -> TerrainWith EntityName
toKey) [(Char, TerrainWith EntityFacade)]
mappedPairs

  renderMapCell :: Maybe CellPaintDisplay -> Char
  renderMapCell :: Maybe CellPaintDisplay -> Char
renderMapCell Maybe CellPaintDisplay
maybeC = case Maybe CellPaintDisplay
maybeC of
    Maybe CellPaintDisplay
Nothing -> Char
maskChar
    Just CellPaintDisplay
c ->
      -- NOTE: This lookup should never fail; if it does for some
      -- reason, return Z rather than crash the game
      Char
-> TerrainWith EntityName
-> Map (TerrainWith EntityName) Char
-> Char
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Char
'Z' TerrainWith EntityName
k (Map (TerrainWith EntityName) Char -> Char)
-> Map (TerrainWith EntityName) Char -> Char
forall a b. (a -> b) -> a -> b
$
        [(TerrainWith EntityName, Char)]
-> Map (TerrainWith EntityName) Char
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(TerrainWith EntityName, Char)]
invertedMappedPairs
     where
      k :: TerrainWith EntityName
k = TerrainWith EntityFacade -> TerrainWith EntityName
toKey (TerrainWith EntityFacade -> TerrainWith EntityName)
-> TerrainWith EntityFacade -> TerrainWith EntityName
forall a b. (a -> b) -> a -> b
$ CellPaintDisplay -> TerrainWith EntityFacade
cellToTerrainPair CellPaintDisplay
c

-- | All alphanumeric characters. These are used as supplemental
-- map placeholders in case a pre-existing display character is
-- not available to re-use.
genericCharacterPool :: Set.Set Char
genericCharacterPool :: Set Char
genericCharacterPool = [Char] -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList ([Char] -> Set Char) -> [Char] -> Set Char
forall a b. (a -> b) -> a -> b
$ [Char
'A' .. Char
'Z'] [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char
'a' .. Char
'z'] [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char
'0' .. Char
'9']

data PaletteAndMaskChar = PaletteAndMaskChar
  { PaletteAndMaskChar -> WorldPalette EntityFacade
paletteEntries :: WorldPalette EntityFacade
  , PaletteAndMaskChar -> Maybe Char
reservedMaskChar :: Maybe Char
  -- ^ represents a transparent cell
  }

-- | Note that display characters are not unique
-- across different entities! However, the palette KeyMap
-- as a conveyance serves to dedupe them.
prepForJson ::
  PaletteAndMaskChar ->
  Grid (Maybe CellPaintDisplay) ->
  (String, KM.KeyMap CellPaintDisplay)
prepForJson :: PaletteAndMaskChar
-> Grid (Maybe CellPaintDisplay)
-> ([Char], KeyMap CellPaintDisplay)
prepForJson (PaletteAndMaskChar (StructurePalette Map Char (SignpostableCell CellPaintDisplay)
suggestedPalette) Maybe Char
maybeMaskChar) Grid (Maybe CellPaintDisplay)
cellGrid =
  ([(Char, TerrainWith EntityFacade)]
-> Char -> Grid (Maybe CellPaintDisplay) -> [Char]
constructWorldMap [(Char, TerrainWith EntityFacade)]
mappedPairs Char
maskCharacter Grid (Maybe CellPaintDisplay)
cellGrid, [(Char, TerrainWith EntityFacade)] -> KeyMap CellPaintDisplay
constructPalette [(Char, TerrainWith EntityFacade)]
mappedPairs)
 where
  preassignments :: [(Char, TerrainWith EntityFacade)]
  preassignments :: [(Char, TerrainWith EntityFacade)]
preassignments =
    ((Char, SignpostableCell CellPaintDisplay)
 -> (Char, TerrainWith EntityFacade))
-> [(Char, SignpostableCell CellPaintDisplay)]
-> [(Char, TerrainWith EntityFacade)]
forall a b. (a -> b) -> [a] -> [b]
map ((SignpostableCell CellPaintDisplay -> TerrainWith EntityFacade)
-> (Char, SignpostableCell CellPaintDisplay)
-> (Char, TerrainWith EntityFacade)
forall a b. (a -> b) -> (Char, a) -> (Char, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CellPaintDisplay -> TerrainWith EntityFacade
cellToTerrainPair (CellPaintDisplay -> TerrainWith EntityFacade)
-> (SignpostableCell CellPaintDisplay -> CellPaintDisplay)
-> SignpostableCell CellPaintDisplay
-> TerrainWith EntityFacade
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignpostableCell CellPaintDisplay -> CellPaintDisplay
forall c. SignpostableCell c -> c
standardCell)) ([(Char, SignpostableCell CellPaintDisplay)]
 -> [(Char, TerrainWith EntityFacade)])
-> [(Char, SignpostableCell CellPaintDisplay)]
-> [(Char, TerrainWith EntityFacade)]
forall a b. (a -> b) -> a -> b
$
      Map Char (SignpostableCell CellPaintDisplay)
-> [(Char, SignpostableCell CellPaintDisplay)]
forall k a. Map k a -> [(k, a)]
M.toList Map Char (SignpostableCell CellPaintDisplay)
suggestedPalette

  entityCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
  entityCells :: Map (TerrainWith EntityName) (TerrainWith EntityFacade)
entityCells = [CellPaintDisplay]
-> Map (TerrainWith EntityName) (TerrainWith EntityFacade)
getUniqueTerrainFacadePairs ([CellPaintDisplay]
 -> Map (TerrainWith EntityName) (TerrainWith EntityFacade))
-> [CellPaintDisplay]
-> Map (TerrainWith EntityName) (TerrainWith EntityFacade)
forall a b. (a -> b) -> a -> b
$ [Maybe CellPaintDisplay] -> [CellPaintDisplay]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe CellPaintDisplay] -> [CellPaintDisplay])
-> [Maybe CellPaintDisplay] -> [CellPaintDisplay]
forall a b. (a -> b) -> a -> b
$ Grid (Maybe CellPaintDisplay) -> [Maybe CellPaintDisplay]
forall a. Grid a -> [a]
allMembers Grid (Maybe CellPaintDisplay)
cellGrid

  unassignedCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
  unassignedCells :: Map (TerrainWith EntityName) (TerrainWith EntityFacade)
unassignedCells =
    Map (TerrainWith EntityName) (TerrainWith EntityFacade)
-> Set (TerrainWith EntityName)
-> Map (TerrainWith EntityName) (TerrainWith EntityFacade)
forall k a. Ord k => Map k a -> Set k -> Map k a
M.withoutKeys Map (TerrainWith EntityName) (TerrainWith EntityFacade)
entityCells (Set (TerrainWith EntityName)
 -> Map (TerrainWith EntityName) (TerrainWith EntityFacade))
-> Set (TerrainWith EntityName)
-> Map (TerrainWith EntityName) (TerrainWith EntityFacade)
forall a b. (a -> b) -> a -> b
$
      [TerrainWith EntityName] -> Set (TerrainWith EntityName)
forall a. Ord a => [a] -> Set a
Set.fromList ([TerrainWith EntityName] -> Set (TerrainWith EntityName))
-> [TerrainWith EntityName] -> Set (TerrainWith EntityName)
forall a b. (a -> b) -> a -> b
$
        ((Char, TerrainWith EntityFacade) -> TerrainWith EntityName)
-> [(Char, TerrainWith EntityFacade)] -> [TerrainWith EntityName]
forall a b. (a -> b) -> [a] -> [b]
map (TerrainWith EntityFacade -> TerrainWith EntityName
toKey (TerrainWith EntityFacade -> TerrainWith EntityName)
-> ((Char, TerrainWith EntityFacade) -> TerrainWith EntityFacade)
-> (Char, TerrainWith EntityFacade)
-> TerrainWith EntityName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, TerrainWith EntityFacade) -> TerrainWith EntityFacade
forall a b. (a, b) -> b
snd) [(Char, TerrainWith EntityFacade)]
preassignments

  (Char
maskCharacter, Set Char
availableCharacterPool) = case Maybe Char
maybeMaskChar of
    Just Char
c -> (Char
c, Set Char
genericCharacterPool)
    Maybe Char
Nothing -> Set Char -> (Char, Set Char)
forall a. Set a -> (a, Set a)
Set.deleteFindMin Set Char
genericCharacterPool

  unassignedCharacters :: Set.Set Char
  unassignedCharacters :: Set Char
unassignedCharacters =
    -- TODO (#1149): How can we efficiently use the Unicode categories (in "Data.Char")
    -- to generate this pool?
    Set Char -> Set Char -> Set Char
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set Char
availableCharacterPool Set Char
usedCharacters
   where
    usedCharacters :: Set Char
usedCharacters =
      [Char] -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList ([Char] -> Set Char) -> [Char] -> Set Char
forall a b. (a -> b) -> a -> b
$
        ((Char, TerrainWith EntityFacade) -> Char)
-> [(Char, TerrainWith EntityFacade)] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map (Char, TerrainWith EntityFacade) -> Char
forall a b. (a, b) -> a
fst [(Char, TerrainWith EntityFacade)]
preassignments

  newlyAssignedPairs :: [(Char, TerrainWith EntityFacade)]
  newlyAssignedPairs :: [(Char, TerrainWith EntityFacade)]
newlyAssignedPairs = [Char]
-> [TerrainWith EntityFacade] -> [(Char, TerrainWith EntityFacade)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Set Char -> [Char]
forall a. Set a -> [a]
Set.toList Set Char
unassignedCharacters) ([TerrainWith EntityFacade] -> [(Char, TerrainWith EntityFacade)])
-> [TerrainWith EntityFacade] -> [(Char, TerrainWith EntityFacade)]
forall a b. (a -> b) -> a -> b
$ Map (TerrainWith EntityName) (TerrainWith EntityFacade)
-> [TerrainWith EntityFacade]
forall k a. Map k a -> [a]
M.elems Map (TerrainWith EntityName) (TerrainWith EntityFacade)
unassignedCells

  mappedPairs :: [(Char, TerrainWith EntityFacade)]
mappedPairs = [(Char, TerrainWith EntityFacade)]
preassignments [(Char, TerrainWith EntityFacade)]
-> [(Char, TerrainWith EntityFacade)]
-> [(Char, TerrainWith EntityFacade)]
forall a. Semigroup a => a -> a -> a
<> [(Char, TerrainWith EntityFacade)]
newlyAssignedPairs