{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
module Swarm.TUI.Editor.Palette where

import Control.Lens
import Control.Monad (guard)
import Data.Aeson.KeyMap qualified as KM
import Data.List (sortOn)
import Data.List.NonEmpty qualified as NE
import Data.Map (Map)
import Data.Map qualified as M
import Data.Maybe (catMaybes, mapMaybe)
import Data.Ord (Down (..))
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Tuple (swap)
import Swarm.Game.Display (Display, defaultChar)
import Swarm.Game.Entity (Entity, EntityName, entitiesByName)
import Swarm.Game.Land
import Swarm.Game.Location
import Swarm.Game.Scenario
import Swarm.Game.Scenario.Topography.Area
import Swarm.Game.Scenario.Topography.Cell
import Swarm.Game.Scenario.Topography.EntityFacade
import Swarm.Game.Scenario.Topography.Grid
import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..))
import Swarm.Game.Scenario.Topography.ProtoCell
import Swarm.Game.Scenario.Topography.Structure.Overlay
import Swarm.Game.Scenario.Topography.WorldPalette
import Swarm.Game.Terrain (TerrainMap, TerrainType, getTerrainDefaultPaletteChar, terrainByName)
import Swarm.Game.Universe
import Swarm.Language.Text.Markdown (fromText)
import Swarm.TUI.Editor.Json (SkeletonScenario (SkeletonScenario))
import Swarm.Util (binTuples, histogram)
import Swarm.Util.Erasable

makeSuggestedPalette ::
  TerrainMap ->
  KM.KeyMap (AugmentedCell Entity) ->
  Grid (Maybe CellPaintDisplay) ->
  KM.KeyMap (AugmentedCell EntityFacade)
makeSuggestedPalette :: TerrainMap
-> KeyMap (AugmentedCell Entity)
-> Grid (Maybe (PCell EntityFacade))
-> KeyMap (AugmentedCell EntityFacade)
makeSuggestedPalette TerrainMap
tm KeyMap (AugmentedCell Entity)
originalScenarioPalette Grid (Maybe (PCell EntityFacade))
cellGrid =
  Map EntityName (AugmentedCell EntityFacade)
-> KeyMap (AugmentedCell EntityFacade)
forall v. Map EntityName v -> KeyMap v
KM.fromMapText
    (Map EntityName (AugmentedCell EntityFacade)
 -> KeyMap (AugmentedCell EntityFacade))
-> (Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
    -> Map EntityName (AugmentedCell EntityFacade))
-> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
-> KeyMap (AugmentedCell EntityFacade)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PCell EntityFacade -> AugmentedCell EntityFacade)
-> Map EntityName (PCell EntityFacade)
-> Map EntityName (AugmentedCell EntityFacade)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Maybe WaypointConfig
-> PCell EntityFacade -> AugmentedCell EntityFacade
forall c. Maybe WaypointConfig -> c -> SignpostableCell c
SignpostableCell Maybe WaypointConfig
forall a. Maybe a
Nothing)
    (Map EntityName (PCell EntityFacade)
 -> Map EntityName (AugmentedCell EntityFacade))
-> (Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
    -> Map EntityName (PCell EntityFacade))
-> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
-> Map EntityName (AugmentedCell EntityFacade)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(EntityName, PCell EntityFacade)]
-> Map EntityName (PCell EntityFacade)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
    ([(EntityName, PCell EntityFacade)]
 -> Map EntityName (PCell EntityFacade))
-> (Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
    -> [(EntityName, PCell EntityFacade)])
-> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
-> Map EntityName (PCell EntityFacade)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
-> [(EntityName, PCell EntityFacade)]
forall k a. Map k a -> [a]
M.elems
    -- NOTE: the left-most maps take precedence!
    (Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
 -> KeyMap (AugmentedCell EntityFacade))
-> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
-> KeyMap (AugmentedCell EntityFacade)
forall a b. (a -> b) -> a -> b
$ Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
paletteCellsByKey Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
-> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
-> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
forall a. Semigroup a => a -> a -> a
<> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
pairsWithDisplays Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
-> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
-> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
forall a. Semigroup a => a -> a -> a
<> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
terrainOnlyPalette
 where
  cellList :: [PCell EntityFacade]
cellList = [Maybe (PCell EntityFacade)] -> [PCell EntityFacade]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (PCell EntityFacade)] -> [PCell EntityFacade])
-> [Maybe (PCell EntityFacade)] -> [PCell EntityFacade]
forall a b. (a -> b) -> a -> b
$ Grid (Maybe (PCell EntityFacade)) -> [Maybe (PCell EntityFacade)]
forall a. Grid a -> [a]
allMembers Grid (Maybe (PCell EntityFacade))
cellGrid

  getMaybeEntityDisplay :: PCell EntityFacade -> Maybe (EntityName, Display)
  getMaybeEntityDisplay :: PCell EntityFacade -> Maybe (EntityName, Display)
getMaybeEntityDisplay (Cell TerrainType
_terrain (Erasable EntityFacade -> Maybe EntityFacade
forall e. Erasable e -> Maybe e
erasableToMaybe -> Maybe EntityFacade
maybeEntity) [IndexedTRobot]
_) = do
    EntityFacade EntityName
eName Display
d <- Maybe EntityFacade
maybeEntity
    (EntityName, Display) -> Maybe (EntityName, Display)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (EntityName
eName, Display
d)

  getMaybeEntityNameTerrainPair :: PCell EntityFacade -> Maybe (EntityName, TerrainType)
  getMaybeEntityNameTerrainPair :: PCell EntityFacade -> Maybe (EntityName, TerrainType)
getMaybeEntityNameTerrainPair (Cell TerrainType
terrain (Erasable EntityFacade -> Maybe EntityFacade
forall e. Erasable e -> Maybe e
erasableToMaybe -> Maybe EntityFacade
maybeEntity) [IndexedTRobot]
_) = do
    EntityFacade EntityName
eName Display
_ <- Maybe EntityFacade
maybeEntity
    (EntityName, TerrainType) -> Maybe (EntityName, TerrainType)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (EntityName
eName, TerrainType
terrain)

  getEntityTerrainMultiplicity :: Map EntityName (Map TerrainType Int)
  getEntityTerrainMultiplicity :: Map EntityName (Map TerrainType Int)
getEntityTerrainMultiplicity =
    (NonEmpty TerrainType -> Map TerrainType Int)
-> Map EntityName (NonEmpty TerrainType)
-> Map EntityName (Map TerrainType Int)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map NonEmpty TerrainType -> Map TerrainType Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> Map a Int
histogram (Map EntityName (NonEmpty TerrainType)
 -> Map EntityName (Map TerrainType Int))
-> Map EntityName (NonEmpty TerrainType)
-> Map EntityName (Map TerrainType Int)
forall a b. (a -> b) -> a -> b
$ [(EntityName, TerrainType)]
-> Map EntityName (NonEmpty TerrainType)
forall (t :: * -> *) a b.
(Foldable t, Ord a) =>
t (a, b) -> Map a (NonEmpty b)
binTuples ([(EntityName, TerrainType)]
 -> Map EntityName (NonEmpty TerrainType))
-> [(EntityName, TerrainType)]
-> Map EntityName (NonEmpty TerrainType)
forall a b. (a -> b) -> a -> b
$ (PCell EntityFacade -> Maybe (EntityName, TerrainType))
-> [PCell EntityFacade] -> [(EntityName, TerrainType)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PCell EntityFacade -> Maybe (EntityName, TerrainType)
getMaybeEntityNameTerrainPair [PCell EntityFacade]
cellList

  usedEntityDisplays :: Map EntityName Display
  usedEntityDisplays :: Map EntityName Display
usedEntityDisplays =
    [(EntityName, Display)] -> Map EntityName Display
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(EntityName, Display)] -> Map EntityName Display)
-> [(EntityName, Display)] -> Map EntityName Display
forall a b. (a -> b) -> a -> b
$ (PCell EntityFacade -> Maybe (EntityName, Display))
-> [PCell EntityFacade] -> [(EntityName, Display)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PCell EntityFacade -> Maybe (EntityName, Display)
getMaybeEntityDisplay [PCell EntityFacade]
cellList

  -- Finds the most-used terrain type (the "mode" in the statistical sense)
  -- paired with each entity
  entitiesWithModalTerrain :: [(TerrainType, EntityName)]
  entitiesWithModalTerrain :: [(TerrainType, EntityName)]
entitiesWithModalTerrain =
    ((EntityName, NonEmpty (TerrainType, Int))
 -> (TerrainType, EntityName))
-> [(EntityName, NonEmpty (TerrainType, Int))]
-> [(TerrainType, EntityName)]
forall a b. (a -> b) -> [a] -> [b]
map ((EntityName, TerrainType) -> (TerrainType, EntityName)
forall a b. (a, b) -> (b, a)
swap ((EntityName, TerrainType) -> (TerrainType, EntityName))
-> ((EntityName, NonEmpty (TerrainType, Int))
    -> (EntityName, TerrainType))
-> (EntityName, NonEmpty (TerrainType, Int))
-> (TerrainType, EntityName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (TerrainType, Int) -> TerrainType)
-> (EntityName, NonEmpty (TerrainType, Int))
-> (EntityName, TerrainType)
forall a b. (a -> b) -> (EntityName, a) -> (EntityName, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TerrainType, Int) -> TerrainType
forall a b. (a, b) -> a
fst ((TerrainType, Int) -> TerrainType)
-> (NonEmpty (TerrainType, Int) -> (TerrainType, Int))
-> NonEmpty (TerrainType, Int)
-> TerrainType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (TerrainType, Int) -> (TerrainType, Int)
forall a. NonEmpty a -> a
NE.head))
      ([(EntityName, NonEmpty (TerrainType, Int))]
 -> [(TerrainType, EntityName)])
-> (Map EntityName (Maybe (NonEmpty (TerrainType, Int)))
    -> [(EntityName, NonEmpty (TerrainType, Int))])
-> Map EntityName (Maybe (NonEmpty (TerrainType, Int)))
-> [(TerrainType, EntityName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((EntityName, Maybe (NonEmpty (TerrainType, Int)))
 -> Maybe (EntityName, NonEmpty (TerrainType, Int)))
-> [(EntityName, Maybe (NonEmpty (TerrainType, Int)))]
-> [(EntityName, NonEmpty (TerrainType, Int))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (EntityName, Maybe (NonEmpty (TerrainType, Int)))
-> Maybe (EntityName, NonEmpty (TerrainType, Int))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
(EntityName, f a) -> f (EntityName, a)
sequenceA
      ([(EntityName, Maybe (NonEmpty (TerrainType, Int)))]
 -> [(EntityName, NonEmpty (TerrainType, Int))])
-> (Map EntityName (Maybe (NonEmpty (TerrainType, Int)))
    -> [(EntityName, Maybe (NonEmpty (TerrainType, Int)))])
-> Map EntityName (Maybe (NonEmpty (TerrainType, Int)))
-> [(EntityName, NonEmpty (TerrainType, Int))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map EntityName (Maybe (NonEmpty (TerrainType, Int)))
-> [(EntityName, Maybe (NonEmpty (TerrainType, Int)))]
forall k a. Map k a -> [(k, a)]
M.toList
      (Map EntityName (Maybe (NonEmpty (TerrainType, Int)))
 -> [(TerrainType, EntityName)])
-> Map EntityName (Maybe (NonEmpty (TerrainType, Int)))
-> [(TerrainType, EntityName)]
forall a b. (a -> b) -> a -> b
$ (Map TerrainType Int -> Maybe (NonEmpty (TerrainType, Int)))
-> Map EntityName (Map TerrainType Int)
-> Map EntityName (Maybe (NonEmpty (TerrainType, Int)))
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ([(TerrainType, Int)] -> Maybe (NonEmpty (TerrainType, Int))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([(TerrainType, Int)] -> Maybe (NonEmpty (TerrainType, Int)))
-> (Map TerrainType Int -> [(TerrainType, Int)])
-> Map TerrainType Int
-> Maybe (NonEmpty (TerrainType, Int))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TerrainType, Int) -> Int)
-> [(TerrainType, Int)] -> [(TerrainType, Int)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (TerrainType, Int) -> Int
forall a b. (a, b) -> b
snd ([(TerrainType, Int)] -> [(TerrainType, Int)])
-> (Map TerrainType Int -> [(TerrainType, Int)])
-> Map TerrainType Int
-> [(TerrainType, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TerrainType Int -> [(TerrainType, Int)]
forall k a. Map k a -> [(k, a)]
M.toList) Map EntityName (Map TerrainType Int)
getEntityTerrainMultiplicity

  invertPaletteMapToDedupe ::
    Map a CellPaintDisplay ->
    [(TerrainWith EntityName, (a, CellPaintDisplay))]
  invertPaletteMapToDedupe :: forall a.
Map a (PCell EntityFacade)
-> [(TerrainWith EntityName, (a, PCell EntityFacade))]
invertPaletteMapToDedupe =
    ((a, PCell EntityFacade)
 -> (TerrainWith EntityName, (a, PCell EntityFacade)))
-> [(a, PCell EntityFacade)]
-> [(TerrainWith EntityName, (a, PCell EntityFacade))]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: (a, PCell EntityFacade)
x@(a
_, PCell EntityFacade
c) -> (TerrainWith EntityFacade -> TerrainWith EntityName
toKey (TerrainWith EntityFacade -> TerrainWith EntityName)
-> TerrainWith EntityFacade -> TerrainWith EntityName
forall a b. (a -> b) -> a -> b
$ PCell EntityFacade -> TerrainWith EntityFacade
cellToTerrainPair PCell EntityFacade
c, (a, PCell EntityFacade)
x)) ([(a, PCell EntityFacade)]
 -> [(TerrainWith EntityName, (a, PCell EntityFacade))])
-> (Map a (PCell EntityFacade) -> [(a, PCell EntityFacade)])
-> Map a (PCell EntityFacade)
-> [(TerrainWith EntityName, (a, PCell EntityFacade))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a (PCell EntityFacade) -> [(a, PCell EntityFacade)]
forall k a. Map k a -> [(k, a)]
M.toList

  paletteCellsByKey :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay)
  paletteCellsByKey :: Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
paletteCellsByKey =
    (NonEmpty (EntityName, PCell EntityFacade)
 -> (EntityName, PCell EntityFacade))
-> Map
     (TerrainWith EntityName)
     (NonEmpty (EntityName, PCell EntityFacade))
-> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (NonEmpty (EntityName, PCell EntityFacade)
-> (EntityName, PCell EntityFacade)
forall a. NonEmpty a -> a
NE.head (NonEmpty (EntityName, PCell EntityFacade)
 -> (EntityName, PCell EntityFacade))
-> (NonEmpty (EntityName, PCell EntityFacade)
    -> NonEmpty (EntityName, PCell EntityFacade))
-> NonEmpty (EntityName, PCell EntityFacade)
-> (EntityName, PCell EntityFacade)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((EntityName, PCell EntityFacade) -> Down (Bool, EntityName))
-> NonEmpty (EntityName, PCell EntityFacade)
-> NonEmpty (EntityName, PCell EntityFacade)
forall o a. Ord o => (a -> o) -> NonEmpty a -> NonEmpty a
NE.sortWith (EntityName, PCell EntityFacade) -> Down (Bool, EntityName)
forall {b} {e}. (b, PCell e) -> Down (Bool, b)
toSortVal)
      (Map
   (TerrainWith EntityName)
   (NonEmpty (EntityName, PCell EntityFacade))
 -> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade))
-> (Map EntityName (PCell EntityFacade)
    -> Map
         (TerrainWith EntityName)
         (NonEmpty (EntityName, PCell EntityFacade)))
-> Map EntityName (PCell EntityFacade)
-> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TerrainWith EntityName, (EntityName, PCell EntityFacade))]
-> Map
     (TerrainWith EntityName)
     (NonEmpty (EntityName, PCell EntityFacade))
forall (t :: * -> *) a b.
(Foldable t, Ord a) =>
t (a, b) -> Map a (NonEmpty b)
binTuples
      ([(TerrainWith EntityName, (EntityName, PCell EntityFacade))]
 -> Map
      (TerrainWith EntityName)
      (NonEmpty (EntityName, PCell EntityFacade)))
-> (Map EntityName (PCell EntityFacade)
    -> [(TerrainWith EntityName, (EntityName, PCell EntityFacade))])
-> Map EntityName (PCell EntityFacade)
-> Map
     (TerrainWith EntityName)
     (NonEmpty (EntityName, PCell EntityFacade))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map EntityName (PCell EntityFacade)
-> [(TerrainWith EntityName, (EntityName, PCell EntityFacade))]
forall a.
Map a (PCell EntityFacade)
-> [(TerrainWith EntityName, (a, PCell EntityFacade))]
invertPaletteMapToDedupe
      (Map EntityName (PCell EntityFacade)
 -> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade))
-> Map EntityName (PCell EntityFacade)
-> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
forall a b. (a -> b) -> a -> b
$ KeyMap (PCell EntityFacade) -> Map EntityName (PCell EntityFacade)
forall v. KeyMap v -> Map EntityName v
KM.toMapText KeyMap (PCell EntityFacade)
originalPalette
   where
    toSortVal :: (b, PCell e) -> Down (Bool, b)
toSortVal (b
symbol, Cell TerrainType
_terrain Erasable e
_maybeEntity [IndexedTRobot]
robots) = (Bool, b) -> Down (Bool, b)
forall a. a -> Down a
Down ([IndexedTRobot] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IndexedTRobot]
robots, b
symbol)

  excludedPaletteChars :: Set Char
  excludedPaletteChars :: Set Char
excludedPaletteChars = [Char] -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList [Char
' ']

  originalPalette :: KM.KeyMap CellPaintDisplay
  originalPalette :: KeyMap (PCell EntityFacade)
originalPalette =
    (AugmentedCell Entity -> PCell EntityFacade)
-> KeyMap (AugmentedCell Entity) -> KeyMap (PCell EntityFacade)
forall a b. (a -> b) -> KeyMap a -> KeyMap b
KM.map (Cell -> PCell EntityFacade
toCellPaintDisplay (Cell -> PCell EntityFacade)
-> (AugmentedCell Entity -> Cell)
-> AugmentedCell Entity
-> PCell EntityFacade
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AugmentedCell Entity -> Cell
forall c. SignpostableCell c -> c
standardCell) KeyMap (AugmentedCell Entity)
originalScenarioPalette

  pairsWithDisplays :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay)
  pairsWithDisplays :: Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
pairsWithDisplays = [(TerrainWith EntityName, (EntityName, PCell EntityFacade))]
-> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(TerrainWith EntityName, (EntityName, PCell EntityFacade))]
 -> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade))
-> [(TerrainWith EntityName, (EntityName, PCell EntityFacade))]
-> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
forall a b. (a -> b) -> a -> b
$ ((TerrainType, EntityName)
 -> Maybe
      (TerrainWith EntityName, (EntityName, PCell EntityFacade)))
-> [(TerrainType, EntityName)]
-> [(TerrainWith EntityName, (EntityName, PCell EntityFacade))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TerrainType, EntityName)
-> Maybe (TerrainWith EntityName, (EntityName, PCell EntityFacade))
g [(TerrainType, EntityName)]
entitiesWithModalTerrain
   where
    g :: (TerrainType, EntityName)
-> Maybe (TerrainWith EntityName, (EntityName, PCell EntityFacade))
g (TerrainType
terrain, EntityName
eName) = do
      Display
eDisplay <- EntityName -> Map EntityName Display -> Maybe Display
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EntityName
eName Map EntityName Display
usedEntityDisplays
      let displayChar :: Char
displayChar = Display
eDisplay Display -> Getting Char Display Char -> Char
forall s a. s -> Getting a s a -> a
^. Getting Char Display Char
Lens' Display Char
defaultChar
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Char -> Set Char -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember Char
displayChar Set Char
excludedPaletteChars
      let cell :: PCell EntityFacade
cell = TerrainType
-> Erasable EntityFacade -> [IndexedTRobot] -> PCell EntityFacade
forall e. TerrainType -> Erasable e -> [IndexedTRobot] -> PCell e
Cell TerrainType
terrain (EntityFacade -> Erasable EntityFacade
forall e. e -> Erasable e
EJust (EntityFacade -> Erasable EntityFacade)
-> EntityFacade -> Erasable EntityFacade
forall a b. (a -> b) -> a -> b
$ EntityName -> Display -> EntityFacade
EntityFacade EntityName
eName Display
eDisplay) []
      (TerrainWith EntityName, (EntityName, PCell EntityFacade))
-> Maybe (TerrainWith EntityName, (EntityName, PCell EntityFacade))
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TerrainType
terrain, EntityName -> Erasable EntityName
forall e. e -> Erasable e
EJust EntityName
eName), (Char -> EntityName
T.singleton Char
displayChar, PCell EntityFacade
cell))

  -- TODO (#1153): Filter out terrain-only palette entries that aren't actually
  -- used in the map.
  terrainOnlyPalette :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay)
  terrainOnlyPalette :: Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
terrainOnlyPalette = [(TerrainWith EntityName, (EntityName, PCell EntityFacade))]
-> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(TerrainWith EntityName, (EntityName, PCell EntityFacade))]
 -> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade))
-> (Map TerrainType TerrainObj
    -> [(TerrainWith EntityName, (EntityName, PCell EntityFacade))])
-> Map TerrainType TerrainObj
-> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TerrainType
 -> (TerrainWith EntityName, (EntityName, PCell EntityFacade)))
-> [TerrainType]
-> [(TerrainWith EntityName, (EntityName, PCell EntityFacade))]
forall a b. (a -> b) -> [a] -> [b]
map TerrainType
-> (TerrainWith EntityName, (EntityName, PCell EntityFacade))
forall {e} {e}.
TerrainType -> ((TerrainType, Erasable e), (EntityName, PCell e))
f ([TerrainType]
 -> [(TerrainWith EntityName, (EntityName, PCell EntityFacade))])
-> (Map TerrainType TerrainObj -> [TerrainType])
-> Map TerrainType TerrainObj
-> [(TerrainWith EntityName, (EntityName, PCell EntityFacade))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TerrainType TerrainObj -> [TerrainType]
forall k a. Map k a -> [k]
M.keys (Map TerrainType TerrainObj
 -> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade))
-> Map TerrainType TerrainObj
-> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
forall a b. (a -> b) -> a -> b
$ TerrainMap -> Map TerrainType TerrainObj
terrainByName TerrainMap
tm
   where
    f :: TerrainType -> ((TerrainType, Erasable e), (EntityName, PCell e))
f TerrainType
x = ((TerrainType
x, Erasable e
forall e. Erasable e
ENothing), (Char -> EntityName
T.singleton (Char -> EntityName) -> Char -> EntityName
forall a b. (a -> b) -> a -> b
$ TerrainType -> Char
getTerrainDefaultPaletteChar TerrainType
x, TerrainType -> Erasable e -> [IndexedTRobot] -> PCell e
forall e. TerrainType -> Erasable e -> [IndexedTRobot] -> PCell e
Cell TerrainType
x Erasable e
forall e. Erasable e
ENothing []))

-- | Generate a \"skeleton\" scenario with placeholders for certain required fields
constructScenario :: Maybe Scenario -> Grid (Maybe CellPaintDisplay) -> SkeletonScenario
constructScenario :: Maybe Scenario
-> Grid (Maybe (PCell EntityFacade)) -> SkeletonScenario
constructScenario Maybe Scenario
maybeOriginalScenario Grid (Maybe (PCell EntityFacade))
cellGrid =
  Int
-> EntityName
-> Document Syntax
-> Bool
-> [Entity]
-> WorldDescriptionPaint
-> [[Char]]
-> SkeletonScenario
SkeletonScenario
    (Int -> (Scenario -> Int) -> Maybe Scenario -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
1 (Scenario -> Getting Int Scenario Int -> Int
forall s a. s -> Getting a s a -> a
^. (ScenarioMetadata -> Const Int ScenarioMetadata)
-> Scenario -> Const Int Scenario
Lens' Scenario ScenarioMetadata
scenarioMetadata ((ScenarioMetadata -> Const Int ScenarioMetadata)
 -> Scenario -> Const Int Scenario)
-> ((Int -> Const Int Int)
    -> ScenarioMetadata -> Const Int ScenarioMetadata)
-> Getting Int Scenario Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int)
-> ScenarioMetadata -> Const Int ScenarioMetadata
Lens' ScenarioMetadata Int
scenarioVersion) Maybe Scenario
maybeOriginalScenario)
    (EntityName
-> (Scenario -> EntityName) -> Maybe Scenario -> EntityName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe EntityName
"My Scenario" (Scenario -> Getting EntityName Scenario EntityName -> EntityName
forall s a. s -> Getting a s a -> a
^. (ScenarioMetadata -> Const EntityName ScenarioMetadata)
-> Scenario -> Const EntityName Scenario
Lens' Scenario ScenarioMetadata
scenarioMetadata ((ScenarioMetadata -> Const EntityName ScenarioMetadata)
 -> Scenario -> Const EntityName Scenario)
-> ((EntityName -> Const EntityName EntityName)
    -> ScenarioMetadata -> Const EntityName ScenarioMetadata)
-> Getting EntityName Scenario EntityName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EntityName -> Const EntityName EntityName)
-> ScenarioMetadata -> Const EntityName ScenarioMetadata
Lens' ScenarioMetadata EntityName
scenarioName) Maybe Scenario
maybeOriginalScenario)
    (Document Syntax
-> (Scenario -> Document Syntax)
-> Maybe Scenario
-> Document Syntax
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (EntityName -> Document Syntax
fromText EntityName
"The scenario description...") (Scenario
-> Getting (Document Syntax) Scenario (Document Syntax)
-> Document Syntax
forall s a. s -> Getting a s a -> a
^. (ScenarioOperation -> Const (Document Syntax) ScenarioOperation)
-> Scenario -> Const (Document Syntax) Scenario
Lens' Scenario ScenarioOperation
scenarioOperation ((ScenarioOperation -> Const (Document Syntax) ScenarioOperation)
 -> Scenario -> Const (Document Syntax) Scenario)
-> ((Document Syntax -> Const (Document Syntax) (Document Syntax))
    -> ScenarioOperation -> Const (Document Syntax) ScenarioOperation)
-> Getting (Document Syntax) Scenario (Document Syntax)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Document Syntax -> Const (Document Syntax) (Document Syntax))
-> ScenarioOperation -> Const (Document Syntax) ScenarioOperation
Lens' ScenarioOperation (Document Syntax)
scenarioDescription) Maybe Scenario
maybeOriginalScenario)
    -- (maybe True (^. scenarioCreative) maybeOriginalScenario)
    Bool
True
    (Map EntityName Entity -> [Entity]
forall k a. Map k a -> [a]
M.elems (Map EntityName Entity -> [Entity])
-> Map EntityName Entity -> [Entity]
forall a b. (a -> b) -> a -> b
$ EntityMap -> Map EntityName Entity
entitiesByName EntityMap
customEntities)
    WorldDescriptionPaint
wd
    [] -- robots
 where
  tem :: TerrainEntityMaps
tem = TerrainEntityMaps
-> (Scenario -> TerrainEntityMaps)
-> Maybe Scenario
-> TerrainEntityMaps
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TerrainEntityMaps
forall a. Monoid a => a
mempty (Scenario
-> Getting TerrainEntityMaps Scenario TerrainEntityMaps
-> TerrainEntityMaps
forall s a. s -> Getting a s a -> a
^. (ScenarioLandscape -> Const TerrainEntityMaps ScenarioLandscape)
-> Scenario -> Const TerrainEntityMaps Scenario
Lens' Scenario ScenarioLandscape
scenarioLandscape ((ScenarioLandscape -> Const TerrainEntityMaps ScenarioLandscape)
 -> Scenario -> Const TerrainEntityMaps Scenario)
-> ((TerrainEntityMaps
     -> Const TerrainEntityMaps TerrainEntityMaps)
    -> ScenarioLandscape -> Const TerrainEntityMaps ScenarioLandscape)
-> Getting TerrainEntityMaps Scenario TerrainEntityMaps
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TerrainEntityMaps -> Const TerrainEntityMaps TerrainEntityMaps)
-> ScenarioLandscape -> Const TerrainEntityMaps ScenarioLandscape
Lens' ScenarioLandscape TerrainEntityMaps
scenarioTerrainAndEntities) Maybe Scenario
maybeOriginalScenario
  customEntities :: EntityMap
customEntities = TerrainEntityMaps
tem TerrainEntityMaps
-> Getting EntityMap TerrainEntityMaps EntityMap -> EntityMap
forall s a. s -> Getting a s a -> a
^. Getting EntityMap TerrainEntityMaps EntityMap
Lens' TerrainEntityMaps EntityMap
entityMap
  wd :: WorldDescriptionPaint
wd =
    WorldDescription
      { offsetOrigin :: Bool
offsetOrigin = Bool
False
      , scrollable :: Bool
scrollable = Bool
True
      , palette :: WorldPalette EntityFacade
palette = KeyMap (AugmentedCell EntityFacade) -> WorldPalette EntityFacade
forall e. KeyMap (SignpostableCell e) -> StructurePalette e
StructurePalette KeyMap (AugmentedCell EntityFacade)
suggestedPalette
      , ul :: Location
ul = Location
upperLeftCoord
      , area :: PositionedGrid (Maybe (PCell EntityFacade))
area = Location
-> Grid (Maybe (PCell EntityFacade))
-> PositionedGrid (Maybe (PCell EntityFacade))
forall a. Location -> Grid a -> PositionedGrid a
PositionedGrid Location
upperLeftCoord Grid (Maybe (PCell EntityFacade))
cellGrid
      , navigation :: Navigation Identity WaypointName
navigation = Identity WaypointMap
-> Map (Cosmic Location) (AnnotatedDestination WaypointName)
-> Navigation Identity WaypointName
forall (additionalDimension :: * -> *) portalExitLoc.
additionalDimension WaypointMap
-> Map (Cosmic Location) (AnnotatedDestination portalExitLoc)
-> Navigation additionalDimension portalExitLoc
Navigation Identity WaypointMap
forall a. Monoid a => a
mempty Map (Cosmic Location) (AnnotatedDestination WaypointName)
forall a. Monoid a => a
mempty
      , placedStructures :: [LocatedStructure]
placedStructures = [LocatedStructure]
forall a. Monoid a => a
mempty
      , worldName :: SubworldName
worldName = SubworldName
DefaultRootSubworld
      , worldProg :: Maybe (TTerm '[] (World CellVal))
worldProg = Maybe (TTerm '[] (World CellVal))
forall a. Maybe a
Nothing
      }

  extractPalette :: Scenario -> KeyMap (AugmentedCell Entity)
extractPalette = StructurePalette Cell -> KeyMap (AugmentedCell Entity)
forall e. StructurePalette e -> KeyMap (SignpostableCell e)
unPalette (StructurePalette Cell -> KeyMap (AugmentedCell Entity))
-> (Scenario -> StructurePalette Cell)
-> Scenario
-> KeyMap (AugmentedCell Entity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PWorldDescription Entity -> StructurePalette Cell
forall e. PWorldDescription e -> WorldPalette e
palette (PWorldDescription Entity -> StructurePalette Cell)
-> (Scenario -> PWorldDescription Entity)
-> Scenario
-> StructurePalette Cell
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (PWorldDescription Entity) -> PWorldDescription Entity
forall a. NonEmpty a -> a
NE.head (NonEmpty (PWorldDescription Entity) -> PWorldDescription Entity)
-> (Scenario -> NonEmpty (PWorldDescription Entity))
-> Scenario
-> PWorldDescription Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Scenario
-> Getting
     (NonEmpty (PWorldDescription Entity))
     Scenario
     (NonEmpty (PWorldDescription Entity))
-> NonEmpty (PWorldDescription Entity)
forall s a. s -> Getting a s a -> a
^. (ScenarioLandscape
 -> Const (NonEmpty (PWorldDescription Entity)) ScenarioLandscape)
-> Scenario -> Const (NonEmpty (PWorldDescription Entity)) Scenario
Lens' Scenario ScenarioLandscape
scenarioLandscape ((ScenarioLandscape
  -> Const (NonEmpty (PWorldDescription Entity)) ScenarioLandscape)
 -> Scenario
 -> Const (NonEmpty (PWorldDescription Entity)) Scenario)
-> ((NonEmpty (PWorldDescription Entity)
     -> Const
          (NonEmpty (PWorldDescription Entity))
          (NonEmpty (PWorldDescription Entity)))
    -> ScenarioLandscape
    -> Const (NonEmpty (PWorldDescription Entity)) ScenarioLandscape)
-> Getting
     (NonEmpty (PWorldDescription Entity))
     Scenario
     (NonEmpty (PWorldDescription Entity))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (PWorldDescription Entity)
 -> Const
      (NonEmpty (PWorldDescription Entity))
      (NonEmpty (PWorldDescription Entity)))
-> ScenarioLandscape
-> Const (NonEmpty (PWorldDescription Entity)) ScenarioLandscape
Lens' ScenarioLandscape (NonEmpty (PWorldDescription Entity))
scenarioWorlds)
  originalPalette :: KeyMap (AugmentedCell Entity)
originalPalette = KeyMap (AugmentedCell Entity)
-> (Scenario -> KeyMap (AugmentedCell Entity))
-> Maybe Scenario
-> KeyMap (AugmentedCell Entity)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe KeyMap (AugmentedCell Entity)
forall a. Monoid a => a
mempty Scenario -> KeyMap (AugmentedCell Entity)
extractPalette Maybe Scenario
maybeOriginalScenario
  suggestedPalette :: KeyMap (AugmentedCell EntityFacade)
suggestedPalette = TerrainMap
-> KeyMap (AugmentedCell Entity)
-> Grid (Maybe (PCell EntityFacade))
-> KeyMap (AugmentedCell EntityFacade)
makeSuggestedPalette (TerrainEntityMaps
tem TerrainEntityMaps
-> Getting TerrainMap TerrainEntityMaps TerrainMap -> TerrainMap
forall s a. s -> Getting a s a -> a
^. Getting TerrainMap TerrainEntityMaps TerrainMap
Lens' TerrainEntityMaps TerrainMap
terrainMap) KeyMap (AugmentedCell Entity)
originalPalette Grid (Maybe (PCell EntityFacade))
cellGrid

  upperLeftCoord :: Location
upperLeftCoord =
    Int32 -> Int32 -> Location
Location
      (Int32 -> Int32
forall a. Num a => a -> a
negate (Int32 -> Int32) -> Int32 -> Int32
forall a b. (a -> b) -> a -> b
$ Int32
w Int32 -> Int32 -> Int32
forall a. Integral a => a -> a -> a
`div` Int32
2)
      (Int32
h Int32 -> Int32 -> Int32
forall a. Integral a => a -> a -> a
`div` Int32
2)
   where
    AreaDimensions Int32
w Int32
h = Grid (Maybe (PCell EntityFacade)) -> AreaDimensions
forall a. Grid a -> AreaDimensions
getGridDimensions Grid (Maybe (PCell EntityFacade))
cellGrid