{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
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
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
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))
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 []))
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)
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
[]
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