{-# 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.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.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.WorldDescription
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 ->
  Map Char (AugmentedCell Entity) ->
  Grid (Maybe CellPaintDisplay) ->
  Map Char (AugmentedCell EntityFacade)
makeSuggestedPalette :: TerrainMap
-> Map Char (AugmentedCell Entity)
-> Grid (Maybe (PCell EntityFacade))
-> Map Char (AugmentedCell EntityFacade)
makeSuggestedPalette TerrainMap
tm Map Char (AugmentedCell Entity)
originalScenarioPalette Grid (Maybe (PCell EntityFacade))
cellGrid =
  (PCell EntityFacade -> AugmentedCell EntityFacade)
-> Map Char (PCell EntityFacade)
-> Map Char (AugmentedCell EntityFacade)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Maybe WaypointConfig
-> Maybe StructureMarker
-> PCell EntityFacade
-> AugmentedCell EntityFacade
forall c.
Maybe WaypointConfig
-> Maybe StructureMarker -> c -> SignpostableCell c
SignpostableCell Maybe WaypointConfig
forall a. Maybe a
Nothing Maybe StructureMarker
forall a. Maybe a
Nothing)
    (Map Char (PCell EntityFacade)
 -> Map Char (AugmentedCell EntityFacade))
-> (Map (TerrainWith EntityName) (Char, PCell EntityFacade)
    -> Map Char (PCell EntityFacade))
-> Map (TerrainWith EntityName) (Char, PCell EntityFacade)
-> Map Char (AugmentedCell EntityFacade)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Char, PCell EntityFacade)] -> Map Char (PCell EntityFacade)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
    ([(Char, PCell EntityFacade)] -> Map Char (PCell EntityFacade))
-> (Map (TerrainWith EntityName) (Char, PCell EntityFacade)
    -> [(Char, PCell EntityFacade)])
-> Map (TerrainWith EntityName) (Char, PCell EntityFacade)
-> Map Char (PCell EntityFacade)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (TerrainWith EntityName) (Char, PCell EntityFacade)
-> [(Char, PCell EntityFacade)]
forall k a. Map k a -> [a]
M.elems
    -- NOTE: the left-most maps take precedence!
    (Map (TerrainWith EntityName) (Char, PCell EntityFacade)
 -> Map Char (AugmentedCell EntityFacade))
-> Map (TerrainWith EntityName) (Char, PCell EntityFacade)
-> Map Char (AugmentedCell EntityFacade)
forall a b. (a -> b) -> a -> b
$ Map (TerrainWith EntityName) (Char, PCell EntityFacade)
paletteCellsByKey Map (TerrainWith EntityName) (Char, PCell EntityFacade)
-> Map (TerrainWith EntityName) (Char, PCell EntityFacade)
-> Map (TerrainWith EntityName) (Char, PCell EntityFacade)
forall a. Semigroup a => a -> a -> a
<> Map (TerrainWith EntityName) (Char, PCell EntityFacade)
pairsWithDisplays Map (TerrainWith EntityName) (Char, PCell EntityFacade)
-> Map (TerrainWith EntityName) (Char, PCell EntityFacade)
-> Map (TerrainWith EntityName) (Char, PCell EntityFacade)
forall a. Semigroup a => a -> a -> a
<> Map (TerrainWith EntityName) (Char, 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) (Char, CellPaintDisplay)
  paletteCellsByKey :: Map (TerrainWith EntityName) (Char, PCell EntityFacade)
paletteCellsByKey =
    (NonEmpty (Char, PCell EntityFacade) -> (Char, PCell EntityFacade))
-> Map
     (TerrainWith EntityName) (NonEmpty (Char, PCell EntityFacade))
-> Map (TerrainWith EntityName) (Char, PCell EntityFacade)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (NonEmpty (Char, PCell EntityFacade) -> (Char, PCell EntityFacade)
forall a. NonEmpty a -> a
NE.head (NonEmpty (Char, PCell EntityFacade) -> (Char, PCell EntityFacade))
-> (NonEmpty (Char, PCell EntityFacade)
    -> NonEmpty (Char, PCell EntityFacade))
-> NonEmpty (Char, PCell EntityFacade)
-> (Char, PCell EntityFacade)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char, PCell EntityFacade) -> Down (Bool, Char))
-> NonEmpty (Char, PCell EntityFacade)
-> NonEmpty (Char, PCell EntityFacade)
forall o a. Ord o => (a -> o) -> NonEmpty a -> NonEmpty a
NE.sortWith (Char, PCell EntityFacade) -> Down (Bool, Char)
forall {b} {e}. (b, PCell e) -> Down (Bool, b)
toSortVal)
      (Map (TerrainWith EntityName) (NonEmpty (Char, PCell EntityFacade))
 -> Map (TerrainWith EntityName) (Char, PCell EntityFacade))
-> (Map Char (PCell EntityFacade)
    -> Map
         (TerrainWith EntityName) (NonEmpty (Char, PCell EntityFacade)))
-> Map Char (PCell EntityFacade)
-> Map (TerrainWith EntityName) (Char, PCell EntityFacade)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TerrainWith EntityName, (Char, PCell EntityFacade))]
-> Map
     (TerrainWith EntityName) (NonEmpty (Char, PCell EntityFacade))
forall (t :: * -> *) a b.
(Foldable t, Ord a) =>
t (a, b) -> Map a (NonEmpty b)
binTuples
      ([(TerrainWith EntityName, (Char, PCell EntityFacade))]
 -> Map
      (TerrainWith EntityName) (NonEmpty (Char, PCell EntityFacade)))
-> (Map Char (PCell EntityFacade)
    -> [(TerrainWith EntityName, (Char, PCell EntityFacade))])
-> Map Char (PCell EntityFacade)
-> Map
     (TerrainWith EntityName) (NonEmpty (Char, PCell EntityFacade))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Char (PCell EntityFacade)
-> [(TerrainWith EntityName, (Char, PCell EntityFacade))]
forall a.
Map a (PCell EntityFacade)
-> [(TerrainWith EntityName, (a, PCell EntityFacade))]
invertPaletteMapToDedupe
      (Map Char (PCell EntityFacade)
 -> Map (TerrainWith EntityName) (Char, PCell EntityFacade))
-> Map Char (PCell EntityFacade)
-> Map (TerrainWith EntityName) (Char, PCell EntityFacade)
forall a b. (a -> b) -> a -> b
$ Map Char (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 :: Map Char CellPaintDisplay
  originalPalette :: Map Char (PCell EntityFacade)
originalPalette =
    (AugmentedCell Entity -> PCell EntityFacade)
-> Map Char (AugmentedCell Entity) -> Map Char (PCell EntityFacade)
forall a b k. (a -> b) -> Map k a -> Map k b
M.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) Map Char (AugmentedCell Entity)
originalScenarioPalette

  pairsWithDisplays :: Map (TerrainWith EntityName) (Char, CellPaintDisplay)
  pairsWithDisplays :: Map (TerrainWith EntityName) (Char, PCell EntityFacade)
pairsWithDisplays = [(TerrainWith EntityName, (Char, PCell EntityFacade))]
-> Map (TerrainWith EntityName) (Char, PCell EntityFacade)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(TerrainWith EntityName, (Char, PCell EntityFacade))]
 -> Map (TerrainWith EntityName) (Char, PCell EntityFacade))
-> [(TerrainWith EntityName, (Char, PCell EntityFacade))]
-> Map (TerrainWith EntityName) (Char, PCell EntityFacade)
forall a b. (a -> b) -> a -> b
$ ((TerrainType, EntityName)
 -> Maybe (TerrainWith EntityName, (Char, PCell EntityFacade)))
-> [(TerrainType, EntityName)]
-> [(TerrainWith EntityName, (Char, PCell EntityFacade))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TerrainType, EntityName)
-> Maybe (TerrainWith EntityName, (Char, PCell EntityFacade))
g [(TerrainType, EntityName)]
entitiesWithModalTerrain
   where
    g :: (TerrainType, EntityName)
-> Maybe (TerrainWith EntityName, (Char, 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, (Char, PCell EntityFacade))
-> Maybe (TerrainWith EntityName, (Char, 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
displayChar, PCell EntityFacade
cell))

  -- TODO (#1153): Filter out terrain-only palette entries that aren't actually
  -- used in the map.
  terrainOnlyPalette :: Map (TerrainWith EntityName) (Char, CellPaintDisplay)
  terrainOnlyPalette :: Map (TerrainWith EntityName) (Char, PCell EntityFacade)
terrainOnlyPalette = [(TerrainWith EntityName, (Char, PCell EntityFacade))]
-> Map (TerrainWith EntityName) (Char, PCell EntityFacade)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(TerrainWith EntityName, (Char, PCell EntityFacade))]
 -> Map (TerrainWith EntityName) (Char, PCell EntityFacade))
-> (Map TerrainType TerrainObj
    -> [(TerrainWith EntityName, (Char, PCell EntityFacade))])
-> Map TerrainType TerrainObj
-> Map (TerrainWith EntityName) (Char, PCell EntityFacade)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TerrainType
 -> (TerrainWith EntityName, (Char, PCell EntityFacade)))
-> [TerrainType]
-> [(TerrainWith EntityName, (Char, PCell EntityFacade))]
forall a b. (a -> b) -> [a] -> [b]
map TerrainType -> (TerrainWith EntityName, (Char, PCell EntityFacade))
forall {e} {e}.
TerrainType -> ((TerrainType, Erasable e), (Char, PCell e))
f ([TerrainType]
 -> [(TerrainWith EntityName, (Char, PCell EntityFacade))])
-> (Map TerrainType TerrainObj -> [TerrainType])
-> Map TerrainType TerrainObj
-> [(TerrainWith EntityName, (Char, 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) (Char, PCell EntityFacade))
-> Map TerrainType TerrainObj
-> Map (TerrainWith EntityName) (Char, PCell EntityFacade)
forall a b. (a -> b) -> a -> b
$ TerrainMap -> Map TerrainType TerrainObj
terrainByName TerrainMap
tm
   where
    f :: TerrainType -> ((TerrainType, Erasable e), (Char, PCell e))
f TerrainType
x = ((TerrainType
x, Erasable e
forall e. Erasable e
ENothing), (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
      { scrollable :: Bool
scrollable = Bool
True
      , palette :: WorldPalette EntityFacade
palette = Map Char (AugmentedCell EntityFacade) -> WorldPalette EntityFacade
forall e. Map Char (SignpostableCell e) -> StructurePalette e
StructurePalette Map Char (AugmentedCell EntityFacade)
suggestedPalette
      , 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 -> Map Char (AugmentedCell Entity)
extractPalette = StructurePalette Cell -> Map Char (AugmentedCell Entity)
forall e. StructurePalette e -> Map Char (SignpostableCell e)
unPalette (StructurePalette Cell -> Map Char (AugmentedCell Entity))
-> (Scenario -> StructurePalette Cell)
-> Scenario
-> Map Char (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 :: Map Char (AugmentedCell Entity)
originalPalette = Map Char (AugmentedCell Entity)
-> (Scenario -> Map Char (AugmentedCell Entity))
-> Maybe Scenario
-> Map Char (AugmentedCell Entity)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map Char (AugmentedCell Entity)
forall a. Monoid a => a
mempty Scenario -> Map Char (AugmentedCell Entity)
extractPalette Maybe Scenario
maybeOriginalScenario
  suggestedPalette :: Map Char (AugmentedCell EntityFacade)
suggestedPalette = TerrainMap
-> Map Char (AugmentedCell Entity)
-> Grid (Maybe (PCell EntityFacade))
-> Map Char (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) Map Char (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