{-# LANGUAGE OverloadedStrings #-}
module Swarm.Game.Scenario.Topography.WorldPalette where
import Control.Arrow (first)
import Control.Lens hiding (from, (.=), (<.>))
import Data.Aeson.KeyMap (KeyMap)
import Data.Aeson.KeyMap qualified as KM
import Data.Map qualified as M
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Data.Tuple (swap)
import Swarm.Game.Entity
import Swarm.Game.Scenario.RobotLookup
import Swarm.Game.Scenario.Topography.Cell
import Swarm.Game.Scenario.Topography.EntityFacade
import Swarm.Game.Terrain (TerrainType)
import Swarm.Util.Erasable
import Swarm.Util.Yaml
newtype WorldPalette e = WorldPalette
{forall e. WorldPalette e -> KeyMap (AugmentedCell e)
unPalette :: KeyMap (AugmentedCell e)}
deriving (WorldPalette e -> WorldPalette e -> Bool
forall e. Eq e => WorldPalette e -> WorldPalette e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WorldPalette e -> WorldPalette e -> Bool
$c/= :: forall e. Eq e => WorldPalette e -> WorldPalette e -> Bool
== :: WorldPalette e -> WorldPalette e -> Bool
$c== :: forall e. Eq e => WorldPalette e -> WorldPalette e -> Bool
Eq, Int -> WorldPalette e -> ShowS
forall e. Show e => Int -> WorldPalette e -> ShowS
forall e. Show e => [WorldPalette e] -> ShowS
forall e. Show e => WorldPalette e -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [WorldPalette e] -> ShowS
$cshowList :: forall e. Show e => [WorldPalette e] -> ShowS
show :: WorldPalette e -> [Char]
$cshow :: forall e. Show e => WorldPalette e -> [Char]
showsPrec :: Int -> WorldPalette e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> WorldPalette e -> ShowS
Show)
instance FromJSONE (EntityMap, RobotMap) (WorldPalette Entity) where
parseJSONE :: Value -> ParserE (EntityMap, RobotMap) (WorldPalette Entity)
parseJSONE = forall e a.
[Char] -> (Object -> ParserE e a) -> Value -> ParserE e a
withObjectE [Char]
"palette" forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. KeyMap (AugmentedCell e) -> WorldPalette e
WorldPalette forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall e a. FromJSONE e a => Value -> ParserE e a
parseJSONE
type TerrainWith a = (TerrainType, Erasable a)
cellToTerrainPair :: CellPaintDisplay -> TerrainWith EntityFacade
cellToTerrainPair :: CellPaintDisplay -> TerrainWith EntityFacade
cellToTerrainPair (Cell TerrainType
terrain Erasable EntityFacade
erasableEntity [IndexedTRobot]
_) = (TerrainType
terrain, Erasable EntityFacade
erasableEntity)
toCellPaintDisplay :: Cell -> CellPaintDisplay
toCellPaintDisplay :: Cell -> CellPaintDisplay
toCellPaintDisplay (Cell TerrainType
terrain Erasable Entity
maybeEntity [IndexedTRobot]
r) =
forall e. TerrainType -> Erasable e -> [IndexedTRobot] -> PCell e
Cell TerrainType
terrain (Entity -> EntityFacade
mkFacade forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Erasable Entity
maybeEntity) [IndexedTRobot]
r
toKey :: TerrainWith EntityFacade -> TerrainWith EntityName
toKey :: TerrainWith EntityFacade -> TerrainWith EntityName
toKey = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(EntityFacade EntityName
eName Display
_display) -> EntityName
eName)
getUniqueTerrainFacadePairs ::
[[CellPaintDisplay]] ->
M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
getUniqueTerrainFacadePairs :: [[CellPaintDisplay]]
-> Map (TerrainWith EntityName) (TerrainWith EntityFacade)
getUniqueTerrainFacadePairs [[CellPaintDisplay]]
cellGrid =
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map CellPaintDisplay
-> (TerrainWith EntityName, TerrainWith EntityFacade)
genTuple) [[CellPaintDisplay]]
cellGrid
where
genTuple :: CellPaintDisplay
-> (TerrainWith EntityName, TerrainWith EntityFacade)
genTuple CellPaintDisplay
c =
(TerrainWith EntityFacade -> TerrainWith EntityName
toKey TerrainWith EntityFacade
terrainEfd, TerrainWith EntityFacade
terrainEfd)
where
terrainEfd :: TerrainWith EntityFacade
terrainEfd = CellPaintDisplay -> TerrainWith EntityFacade
cellToTerrainPair CellPaintDisplay
c
constructPalette ::
[(Char, TerrainWith EntityFacade)] ->
KM.KeyMap CellPaintDisplay
constructPalette :: [(Char, TerrainWith EntityFacade)] -> KeyMap CellPaintDisplay
constructPalette [(Char, TerrainWith EntityFacade)]
mappedPairs =
forall v. Map EntityName v -> KeyMap v
KM.fromMapText Map EntityName CellPaintDisplay
terrainEntityPalette
where
g :: (TerrainType, Erasable e) -> PCell e
g (TerrainType
terrain, Erasable e
maybeEfd) = forall e. TerrainType -> Erasable e -> [IndexedTRobot] -> PCell e
Cell TerrainType
terrain Erasable e
maybeEfd []
terrainEntityPalette :: Map EntityName CellPaintDisplay
terrainEntityPalette = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Char -> EntityName
T.singleton forall {e}. (TerrainType, Erasable e) -> PCell e
g) [(Char, TerrainWith EntityFacade)]
mappedPairs
constructWorldMap ::
[(Char, TerrainWith EntityFacade)] ->
[[CellPaintDisplay]] ->
Text
constructWorldMap :: [(Char, TerrainWith EntityFacade)]
-> [[CellPaintDisplay]] -> EntityName
constructWorldMap [(Char, TerrainWith EntityFacade)]
mappedPairs =
[EntityName] -> EntityName
T.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> EntityName
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map CellPaintDisplay -> Char
renderMapCell)
where
invertedMappedPairs :: [(TerrainWith EntityName, Char)]
invertedMappedPairs = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> (b, a)
swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TerrainWith EntityFacade -> TerrainWith EntityName
toKey) [(Char, TerrainWith EntityFacade)]
mappedPairs
renderMapCell :: CellPaintDisplay -> Char
renderMapCell CellPaintDisplay
c =
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault (forall a. HasCallStack => [Char] -> a
error [Char]
"Palette lookup failed!") TerrainWith EntityName
k forall a b. (a -> b) -> a -> b
$
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(TerrainWith EntityName, Char)]
invertedMappedPairs
where
k :: TerrainWith EntityName
k = TerrainWith EntityFacade -> TerrainWith EntityName
toKey forall a b. (a -> b) -> a -> b
$ CellPaintDisplay -> TerrainWith EntityFacade
cellToTerrainPair CellPaintDisplay
c
genericCharacterPool :: Set.Set Char
genericCharacterPool :: Set Char
genericCharacterPool = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ [Char
'A' .. Char
'Z'] forall a. Semigroup a => a -> a -> a
<> [Char
'a' .. Char
'z'] forall a. Semigroup a => a -> a -> a
<> [Char
'0' .. Char
'9']
prepForJson ::
WorldPalette EntityFacade ->
[[CellPaintDisplay]] ->
(Text, KM.KeyMap CellPaintDisplay)
prepForJson :: WorldPalette EntityFacade
-> [[CellPaintDisplay]] -> (EntityName, KeyMap CellPaintDisplay)
prepForJson (WorldPalette KeyMap (AugmentedCell EntityFacade)
suggestedPalette) [[CellPaintDisplay]]
cellGrid =
([(Char, TerrainWith EntityFacade)]
-> [[CellPaintDisplay]] -> EntityName
constructWorldMap [(Char, TerrainWith EntityFacade)]
mappedPairs [[CellPaintDisplay]]
cellGrid, [(Char, TerrainWith EntityFacade)] -> KeyMap CellPaintDisplay
constructPalette [(Char, TerrainWith EntityFacade)]
mappedPairs)
where
preassignments :: [(Char, TerrainWith EntityFacade)]
preassignments :: [(Char, TerrainWith EntityFacade)]
preassignments =
forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first EntityName -> Char
T.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CellPaintDisplay -> TerrainWith EntityFacade
cellToTerrainPair forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. AugmentedCell e -> PCell e
standardCell)) forall a b. (a -> b) -> a -> b
$
forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$
forall v. KeyMap v -> Map EntityName v
KM.toMapText KeyMap (AugmentedCell EntityFacade)
suggestedPalette
entityCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
entityCells :: Map (TerrainWith EntityName) (TerrainWith EntityFacade)
entityCells = [[CellPaintDisplay]]
-> Map (TerrainWith EntityName) (TerrainWith EntityFacade)
getUniqueTerrainFacadePairs [[CellPaintDisplay]]
cellGrid
unassignedCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
unassignedCells :: Map (TerrainWith EntityName) (TerrainWith EntityFacade)
unassignedCells =
forall k a. Ord k => Map k a -> Set k -> Map k a
M.withoutKeys Map (TerrainWith EntityName) (TerrainWith EntityFacade)
entityCells forall a b. (a -> b) -> a -> b
$
forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (TerrainWith EntityFacade -> TerrainWith EntityName
toKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Char, TerrainWith EntityFacade)]
preassignments
unassignedCharacters :: Set.Set Char
unassignedCharacters :: Set Char
unassignedCharacters =
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set Char
genericCharacterPool forall a b. (a -> b) -> a -> b
$
forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Char, TerrainWith EntityFacade)]
preassignments
newlyAssignedPairs :: [(Char, TerrainWith EntityFacade)]
newlyAssignedPairs :: [(Char, TerrainWith EntityFacade)]
newlyAssignedPairs = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Set a -> [a]
Set.toList Set Char
unassignedCharacters) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
M.elems Map (TerrainWith EntityName) (TerrainWith EntityFacade)
unassignedCells
mappedPairs :: [(Char, TerrainWith EntityFacade)]
mappedPairs = [(Char, TerrainWith EntityFacade)]
preassignments forall a. Semigroup a => a -> a -> a
<> [(Char, TerrainWith EntityFacade)]
newlyAssignedPairs