{-# 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 (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 (EntityName, entitiesByName)
import Swarm.Game.Location
import Swarm.Game.Scenario
import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..), getAreaDimensions)
import Swarm.Game.Scenario.Topography.Cell
import Swarm.Game.Scenario.Topography.EntityFacade
import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..))
import Swarm.Game.Scenario.Topography.WorldPalette
import Swarm.Game.Terrain (TerrainType, getTerrainDefaultPaletteChar)
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 qualified as U
import Swarm.Util.Erasable

makeSuggestedPalette :: Maybe Scenario -> [[CellPaintDisplay]] -> KM.KeyMap (AugmentedCell EntityFacade)
makeSuggestedPalette :: Maybe Scenario
-> [[PCell EntityFacade]] -> KeyMap (AugmentedCell EntityFacade)
makeSuggestedPalette Maybe Scenario
maybeOriginalScenario [[PCell EntityFacade]]
cellGrid =
  forall v. Map EntityName v -> KeyMap v
KM.fromMapText
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> b) -> Map k a -> Map k b
M.map (forall e. Maybe WaypointConfig -> PCell e -> AugmentedCell e
AugmentedCell forall a. Maybe a
Nothing)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
M.elems
    -- NOTE: the left-most maps take precedence!
    forall a b. (a -> b) -> a -> b
$ Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
paletteCellsByKey forall a. Semigroup a => a -> a -> a
<> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
pairsWithDisplays forall a. Semigroup a => a -> a -> a
<> Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
terrainOnlyPalette
 where
  getMaybeEntityDisplay :: PCell EntityFacade -> Maybe (EntityName, Display)
  getMaybeEntityDisplay :: PCell EntityFacade -> Maybe (EntityName, Display)
getMaybeEntityDisplay (Cell TerrainType
_terrain (forall e. Erasable e -> Maybe e
erasableToMaybe -> Maybe EntityFacade
maybeEntity) [IndexedTRobot]
_) = do
    EntityFacade EntityName
eName Display
d <- Maybe EntityFacade
maybeEntity
    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 (forall e. Erasable e -> Maybe e
erasableToMaybe -> Maybe EntityFacade
maybeEntity) [IndexedTRobot]
_) = do
    EntityFacade EntityName
eName Display
_ <- Maybe EntityFacade
maybeEntity
    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 =
    forall a b k. (a -> b) -> Map k a -> Map k b
M.map forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> Map a Int
histogram forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
(Foldable t, Ord a) =>
t (a, b) -> Map a (NonEmpty b)
binTuples forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PCell EntityFacade -> Maybe (EntityName, TerrainType)
getMaybeEntityNameTerrainPair) [[PCell EntityFacade]]
cellGrid

  usedEntityDisplays :: Map EntityName Display
  usedEntityDisplays :: Map EntityName Display
usedEntityDisplays =
    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 -> Maybe b) -> [a] -> [b]
mapMaybe PCell EntityFacade -> Maybe (EntityName, Display)
getMaybeEntityDisplay) [[PCell EntityFacade]]
cellGrid

  -- Finds the most-used terrain type (the "mode" in the statistical sense)
  -- paired with each entity
  entitiesWithModalTerrain :: [(TerrainType, EntityName)]
  entitiesWithModalTerrain :: [(TerrainType, EntityName)]
entitiesWithModalTerrain =
    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 (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NE.head))
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList
      forall a b. (a -> b) -> a -> b
$ forall a b k. (a -> b) -> Map k a -> Map k b
M.map (forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
    forall a b. (a -> b) -> [a] -> [b]
map (\x :: (a, PCell EntityFacade)
x@(a
_, PCell EntityFacade
c) -> (TerrainWith EntityFacade -> TerrainWith EntityName
toKey forall a b. (a -> b) -> a -> b
$ PCell EntityFacade -> TerrainWith EntityFacade
cellToTerrainPair PCell EntityFacade
c, (a, PCell EntityFacade)
x)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
    forall a b k. (a -> b) -> Map k a -> Map k b
M.map (forall a. NonEmpty a -> a
NE.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o a. Ord o => (a -> o) -> NonEmpty a -> NonEmpty a
NE.sortWith forall {b} {e}. (b, PCell e) -> Down (Bool, b)
toSortVal)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
(Foldable t, Ord a) =>
t (a, b) -> Map a (NonEmpty b)
binTuples
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
Map a (PCell EntityFacade)
-> [(TerrainWith EntityName, (a, PCell EntityFacade))]
invertPaletteMapToDedupe
      forall a b. (a -> b) -> a -> b
$ 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) = forall a. a -> Down a
Down (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IndexedTRobot]
robots, b
symbol)

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

  originalPalette :: KM.KeyMap CellPaintDisplay
  originalPalette :: KeyMap (PCell EntityFacade)
originalPalette =
    forall a b. (a -> b) -> KeyMap a -> KeyMap b
KM.map (Cell -> PCell EntityFacade
toCellPaintDisplay 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 b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall e. WorldPalette e -> KeyMap (AugmentedCell e)
unPalette forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. PWorldDescription e -> WorldPalette e
palette forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NE.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. Lens' Scenario (NonEmpty (PWorldDescription Entity))
scenarioWorlds)) Maybe Scenario
maybeOriginalScenario

  pairsWithDisplays :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay)
  pairsWithDisplays :: Map (TerrainWith EntityName) (EntityName, PCell EntityFacade)
pairsWithDisplays = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ 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 <- 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 forall s a. s -> Getting a s a -> a
^. Lens' Display Char
defaultChar
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Bool
Set.notMember Char
displayChar Set Char
excludedPaletteChars
      let cell :: PCell EntityFacade
cell = forall e. TerrainType -> Erasable e -> [IndexedTRobot] -> PCell e
Cell TerrainType
terrain (forall e. e -> Erasable e
EJust forall a b. (a -> b) -> a -> b
$ EntityName -> Display -> EntityFacade
EntityFacade EntityName
eName Display
eDisplay) []
      forall (m :: * -> *) a. Monad m => a -> m a
return ((TerrainType
terrain, 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 = 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 {e} {e}.
TerrainType -> ((TerrainType, Erasable e), (EntityName, PCell e))
f forall e. (Enum e, Bounded e) => [e]
U.listEnums
   where
    f :: TerrainType -> ((TerrainType, Erasable e), (EntityName, PCell e))
f TerrainType
x = ((TerrainType
x, forall e. Erasable e
ENothing), (Char -> EntityName
T.singleton forall a b. (a -> b) -> a -> b
$ TerrainType -> Char
getTerrainDefaultPaletteChar TerrainType
x, forall e. TerrainType -> Erasable e -> [IndexedTRobot] -> PCell e
Cell TerrainType
x forall e. Erasable e
ENothing []))

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

  suggestedPalette :: KeyMap (AugmentedCell EntityFacade)
suggestedPalette = Maybe Scenario
-> [[PCell EntityFacade]] -> KeyMap (AugmentedCell EntityFacade)
makeSuggestedPalette Maybe Scenario
maybeOriginalScenario [[PCell EntityFacade]]
cellGrid

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