{-# LANGUAGE OverloadedStrings #-}

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

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

-- | A world palette maps characters to 'Cell' values.
newtype WorldPalette e = WorldPalette
  {forall e. WorldPalette e -> KeyMap (AugmentedCell e)
unPalette :: KeyMap (AugmentedCell e)}
  deriving (WorldPalette e -> WorldPalette e -> Bool
forall e. Eq e => WorldPalette e -> WorldPalette e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WorldPalette e -> WorldPalette e -> Bool
$c/= :: forall e. Eq e => WorldPalette e -> WorldPalette e -> Bool
== :: WorldPalette e -> WorldPalette e -> Bool
$c== :: forall e. Eq e => WorldPalette e -> WorldPalette e -> Bool
Eq, Int -> WorldPalette e -> ShowS
forall e. Show e => Int -> WorldPalette e -> ShowS
forall e. Show e => [WorldPalette e] -> ShowS
forall e. Show e => WorldPalette e -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [WorldPalette e] -> ShowS
$cshowList :: forall e. Show e => [WorldPalette e] -> ShowS
show :: WorldPalette e -> [Char]
$cshow :: forall e. Show e => WorldPalette e -> [Char]
showsPrec :: Int -> WorldPalette e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> WorldPalette e -> ShowS
Show)

instance FromJSONE (EntityMap, RobotMap) (WorldPalette Entity) where
  parseJSONE :: Value -> ParserE (EntityMap, RobotMap) (WorldPalette Entity)
parseJSONE = forall e a.
[Char] -> (Object -> ParserE e a) -> Value -> ParserE e a
withObjectE [Char]
"palette" forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. KeyMap (AugmentedCell e) -> WorldPalette e
WorldPalette forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall e a. FromJSONE e a => Value -> ParserE e a
parseJSONE

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) =
  forall e. TerrainType -> Erasable e -> [IndexedTRobot] -> PCell e
Cell TerrainType
terrain (Entity -> EntityFacade
mkFacade 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> 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 =
  forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (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 =
  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) = forall e. TerrainType -> Erasable e -> [IndexedTRobot] -> PCell e
Cell TerrainType
terrain Erasable e
maybeEfd []
  terrainEntityPalette :: Map EntityName CellPaintDisplay
terrainEntityPalette = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Char -> EntityName
T.singleton forall {e}. (TerrainType, Erasable e) -> PCell e
g) [(Char, TerrainWith EntityFacade)]
mappedPairs

constructWorldMap ::
  [(Char, TerrainWith EntityFacade)] ->
  [[CellPaintDisplay]] ->
  Text
constructWorldMap :: [(Char, TerrainWith EntityFacade)]
-> [[CellPaintDisplay]] -> EntityName
constructWorldMap [(Char, TerrainWith EntityFacade)]
mappedPairs =
  [EntityName] -> EntityName
T.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> EntityName
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map CellPaintDisplay -> Char
renderMapCell)
 where
  invertedMappedPairs :: [(TerrainWith EntityName, Char)]
invertedMappedPairs = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> (b, a)
swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TerrainWith EntityFacade -> TerrainWith EntityName
toKey) [(Char, TerrainWith EntityFacade)]
mappedPairs

  renderMapCell :: CellPaintDisplay -> Char
renderMapCell CellPaintDisplay
c =
    -- NOTE: This lookup should never fail
    forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault (forall a. HasCallStack => [Char] -> a
error [Char]
"Palette lookup failed!") TerrainWith EntityName
k forall a b. (a -> b) -> a -> b
$
      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 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 = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ [Char
'A' .. Char
'Z'] forall a. Semigroup a => a -> a -> a
<> [Char
'a' .. Char
'z'] forall a. Semigroup a => a -> a -> a
<> [Char
'0' .. Char
'9']

-- | Note that display characters are not unique
-- across different entities! However, the palette KeyMap
-- as a conveyance serves to dedupe them.
prepForJson ::
  WorldPalette EntityFacade ->
  [[CellPaintDisplay]] ->
  (Text, KM.KeyMap CellPaintDisplay)
prepForJson :: WorldPalette EntityFacade
-> [[CellPaintDisplay]] -> (EntityName, KeyMap CellPaintDisplay)
prepForJson (WorldPalette KeyMap (AugmentedCell EntityFacade)
suggestedPalette) [[CellPaintDisplay]]
cellGrid =
  ([(Char, TerrainWith EntityFacade)]
-> [[CellPaintDisplay]] -> EntityName
constructWorldMap [(Char, TerrainWith EntityFacade)]
mappedPairs [[CellPaintDisplay]]
cellGrid, [(Char, TerrainWith EntityFacade)] -> KeyMap CellPaintDisplay
constructPalette [(Char, TerrainWith EntityFacade)]
mappedPairs)
 where
  preassignments :: [(Char, TerrainWith EntityFacade)]
  preassignments :: [(Char, TerrainWith EntityFacade)]
preassignments =
    forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first EntityName -> Char
T.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CellPaintDisplay -> TerrainWith EntityFacade
cellToTerrainPair forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. AugmentedCell e -> PCell e
standardCell)) forall a b. (a -> b) -> a -> b
$
      forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$
        forall v. KeyMap v -> Map EntityName v
KM.toMapText KeyMap (AugmentedCell EntityFacade)
suggestedPalette

  entityCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
  entityCells :: Map (TerrainWith EntityName) (TerrainWith EntityFacade)
entityCells = [[CellPaintDisplay]]
-> Map (TerrainWith EntityName) (TerrainWith EntityFacade)
getUniqueTerrainFacadePairs [[CellPaintDisplay]]
cellGrid

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

  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?
    forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set Char
genericCharacterPool forall a b. (a -> b) -> a -> b
$
      forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Char, TerrainWith EntityFacade)]
preassignments

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

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