{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
module Swarm.Game.Scenario.Topography.WorldDescription where

import Control.Carrier.Reader (runReader)
import Control.Carrier.Throw.Either
import Control.Monad (forM)
import Data.Coerce
import Data.Functor.Identity
import Data.Text qualified as T
import Data.Yaml as Y
import Swarm.Game.Entity (Entity)
import Swarm.Game.Land
import Swarm.Game.Location
import Swarm.Game.Scenario.RobotLookup (RobotMap)
import Swarm.Game.Scenario.Topography.Cell
import Swarm.Game.Scenario.Topography.EntityFacade (EntityFacade)
import Swarm.Game.Scenario.Topography.Navigation.Portal
import Swarm.Game.Scenario.Topography.Navigation.Waypoint (
  Parentage (Root),
  WaypointName,
 )
import Swarm.Game.Scenario.Topography.ProtoCell (
  StructurePalette (StructurePalette),
 )
import Swarm.Game.Scenario.Topography.Structure (
  MergedStructure (MergedStructure),
  NamedStructure,
  parseStructure,
 )
import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly
import Swarm.Game.Scenario.Topography.Structure.Overlay (
  PositionedGrid (..),
 )
import Swarm.Game.Scenario.Topography.Structure.Recognition.Static (LocatedStructure)
import Swarm.Game.Scenario.Topography.WorldPalette
import Swarm.Game.Universe (SubworldName (DefaultRootSubworld))
import Swarm.Game.World.Parse ()
import Swarm.Game.World.Syntax
import Swarm.Game.World.Typecheck
import Swarm.Pretty (prettyString)
import Swarm.Util.Yaml

------------------------------------------------------------
-- World description
------------------------------------------------------------

-- | A description of a world parsed from a YAML file.
-- This type is parameterized to accommodate Cells that
-- utilize a less stateful Entity type.
data PWorldDescription e = WorldDescription
  { forall e. PWorldDescription e -> Bool
scrollable :: Bool
  , forall e. PWorldDescription e -> WorldPalette e
palette :: WorldPalette e
  , forall e. PWorldDescription e -> PositionedGrid (Maybe (PCell e))
area :: PositionedGrid (Maybe (PCell e))
  , forall e. PWorldDescription e -> Navigation Identity WaypointName
navigation :: Navigation Identity WaypointName
  , forall e. PWorldDescription e -> [LocatedStructure]
placedStructures :: [LocatedStructure]
  -- ^ statically-placed structures to pre-populate
  -- the structure recognizer
  , forall e. PWorldDescription e -> SubworldName
worldName :: SubworldName
  , forall e. PWorldDescription e -> Maybe (TTerm '[] (World CellVal))
worldProg :: Maybe (TTerm '[] (World CellVal))
  }
  deriving (Int -> PWorldDescription e -> ShowS
[PWorldDescription e] -> ShowS
PWorldDescription e -> String
(Int -> PWorldDescription e -> ShowS)
-> (PWorldDescription e -> String)
-> ([PWorldDescription e] -> ShowS)
-> Show (PWorldDescription e)
forall e. Show e => Int -> PWorldDescription e -> ShowS
forall e. Show e => [PWorldDescription e] -> ShowS
forall e. Show e => PWorldDescription e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall e. Show e => Int -> PWorldDescription e -> ShowS
showsPrec :: Int -> PWorldDescription e -> ShowS
$cshow :: forall e. Show e => PWorldDescription e -> String
show :: PWorldDescription e -> String
$cshowList :: forall e. Show e => [PWorldDescription e] -> ShowS
showList :: [PWorldDescription e] -> ShowS
Show)

type WorldDescription = PWorldDescription Entity

type InheritedStructureDefs = [NamedStructure (Maybe Cell)]

data WorldParseDependencies
  = WorldParseDependencies
      WorldMap
      InheritedStructureDefs
      RobotMap
      -- | last for the benefit of partial application
      TerrainEntityMaps

instance FromJSONE WorldParseDependencies WorldDescription where
  parseJSONE :: Value -> ParserE WorldParseDependencies WorldDescription
parseJSONE = String
-> (Object -> ParserE WorldParseDependencies WorldDescription)
-> Value
-> ParserE WorldParseDependencies WorldDescription
forall e a.
String -> (Object -> ParserE e a) -> Value -> ParserE e a
withObjectE String
"world description" ((Object -> ParserE WorldParseDependencies WorldDescription)
 -> Value -> ParserE WorldParseDependencies WorldDescription)
-> (Object -> ParserE WorldParseDependencies WorldDescription)
-> Value
-> ParserE WorldParseDependencies WorldDescription
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    WorldParseDependencies WorldMap
worldMap [NamedStructure (Maybe (PCell Entity))]
scenarioLevelStructureDefs RobotMap
rm TerrainEntityMaps
tem <- With WorldParseDependencies Parser WorldParseDependencies
forall (f :: * -> *) e. Monad f => With e f e
getE

    let withDeps :: With (TerrainEntityMaps, RobotMap) f a -> With e' f a
withDeps = (e' -> (TerrainEntityMaps, RobotMap))
-> With (TerrainEntityMaps, RobotMap) f a -> With e' f a
forall e' e (f :: * -> *) a. (e' -> e) -> With e f a -> With e' f a
localE ((TerrainEntityMaps, RobotMap)
-> e' -> (TerrainEntityMaps, RobotMap)
forall a b. a -> b -> a
const (TerrainEntityMaps
tem, RobotMap
rm))
    StructurePalette (PCell Entity)
palette <-
      With
  (TerrainEntityMaps, RobotMap)
  Parser
  (StructurePalette (PCell Entity))
-> With
     WorldParseDependencies Parser (StructurePalette (PCell Entity))
forall {f :: * -> *} {a} {e'}.
With (TerrainEntityMaps, RobotMap) f a -> With e' f a
withDeps (With
   (TerrainEntityMaps, RobotMap)
   Parser
   (StructurePalette (PCell Entity))
 -> With
      WorldParseDependencies Parser (StructurePalette (PCell Entity)))
-> With
     (TerrainEntityMaps, RobotMap)
     Parser
     (StructurePalette (PCell Entity))
-> With
     WorldParseDependencies Parser (StructurePalette (PCell Entity))
forall a b. (a -> b) -> a -> b
$
        Object
v Object
-> Text
-> ParserE
     (TerrainEntityMaps, RobotMap)
     (Maybe (StructurePalette (PCell Entity)))
forall e a. FromJSONE e a => Object -> Text -> ParserE e (Maybe a)
..:? Text
"palette" ParserE
  (TerrainEntityMaps, RobotMap)
  (Maybe (StructurePalette (PCell Entity)))
-> StructurePalette (PCell Entity)
-> With
     (TerrainEntityMaps, RobotMap)
     Parser
     (StructurePalette (PCell Entity))
forall (f :: * -> *) a. Functor f => f (Maybe a) -> a -> f a
..!= Map Char (SignpostableCell (PCell Entity))
-> StructurePalette (PCell Entity)
forall e. Map Char (SignpostableCell e) -> StructurePalette e
StructurePalette Map Char (SignpostableCell (PCell Entity))
forall a. Monoid a => a
mempty
    [NamedStructure (Maybe (PCell Entity))]
subworldLocalStructureDefs <-
      With
  (TerrainEntityMaps, RobotMap)
  Parser
  [NamedStructure (Maybe (PCell Entity))]
-> With
     WorldParseDependencies
     Parser
     [NamedStructure (Maybe (PCell Entity))]
forall {f :: * -> *} {a} {e'}.
With (TerrainEntityMaps, RobotMap) f a -> With e' f a
withDeps (With
   (TerrainEntityMaps, RobotMap)
   Parser
   [NamedStructure (Maybe (PCell Entity))]
 -> With
      WorldParseDependencies
      Parser
      [NamedStructure (Maybe (PCell Entity))])
-> With
     (TerrainEntityMaps, RobotMap)
     Parser
     [NamedStructure (Maybe (PCell Entity))]
-> With
     WorldParseDependencies
     Parser
     [NamedStructure (Maybe (PCell Entity))]
forall a b. (a -> b) -> a -> b
$
        Object
v Object
-> Text
-> ParserE
     (TerrainEntityMaps, RobotMap)
     (Maybe [NamedStructure (Maybe (PCell Entity))])
forall e a. FromJSONE e a => Object -> Text -> ParserE e (Maybe a)
..:? Text
"structures" ParserE
  (TerrainEntityMaps, RobotMap)
  (Maybe [NamedStructure (Maybe (PCell Entity))])
-> [NamedStructure (Maybe (PCell Entity))]
-> With
     (TerrainEntityMaps, RobotMap)
     Parser
     [NamedStructure (Maybe (PCell Entity))]
forall (f :: * -> *) a. Functor f => f (Maybe a) -> a -> f a
..!= []

    let initialStructureDefs :: [NamedStructure (Maybe (PCell Entity))]
initialStructureDefs = [NamedStructure (Maybe (PCell Entity))]
scenarioLevelStructureDefs [NamedStructure (Maybe (PCell Entity))]
-> [NamedStructure (Maybe (PCell Entity))]
-> [NamedStructure (Maybe (PCell Entity))]
forall a. Semigroup a => a -> a -> a
<> [NamedStructure (Maybe (PCell Entity))]
subworldLocalStructureDefs
    Parser WorldDescription
-> ParserE WorldParseDependencies WorldDescription
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Parser WorldDescription
 -> ParserE WorldParseDependencies WorldDescription)
-> Parser WorldDescription
-> ParserE WorldParseDependencies WorldDescription
forall a b. (a -> b) -> a -> b
$ TerrainEntityMaps
-> WorldMap
-> StructurePalette (PCell Entity)
-> [NamedStructure (Maybe (PCell Entity))]
-> Object
-> Parser WorldDescription
forall {p} {p} {e}.
(Member
   (Reader WorldMap)
   (Reader p :+: (Reader p :+: (Throw CheckErr :+: Lift Identity))),
 Member
   (Reader TerrainEntityMaps)
   (Reader p
    :+: (Reader p :+: (Throw CheckErr :+: Lift Identity)))) =>
p
-> p
-> StructurePalette (PCell e)
-> [NamedStructure (Maybe (PCell e))]
-> Object
-> Parser (PWorldDescription e)
mkWorld TerrainEntityMaps
tem WorldMap
worldMap StructurePalette (PCell Entity)
palette [NamedStructure (Maybe (PCell Entity))]
initialStructureDefs Object
v
   where
    mkWorld :: p
-> p
-> StructurePalette (PCell e)
-> [NamedStructure (Maybe (PCell e))]
-> Object
-> Parser (PWorldDescription e)
mkWorld p
tem p
worldMap StructurePalette (PCell e)
palette [NamedStructure (Maybe (PCell e))]
initialStructureDefs Object
v = do
      MergedStructure PositionedGrid (Maybe (PCell e))
mergedGrid [LocatedStructure]
staticStructurePlacements [Originated Waypoint]
unmergedWaypoints <- do
        PStructure (Maybe (PCell e))
unflattenedStructure <- StructurePalette (PCell e)
-> [NamedStructure (Maybe (PCell e))]
-> Object
-> Parser (PStructure (Maybe (PCell e)))
forall c.
StructurePalette c
-> [NamedStructure (Maybe c)]
-> Object
-> Parser (PStructure (Maybe c))
parseStructure StructurePalette (PCell e)
palette [NamedStructure (Maybe (PCell e))]
initialStructureDefs Object
v

        -- NOTE: In contrast with the 'Swarm.Game.Scenario' module,
        -- we do not need to pass in a structure map here,
        -- because all the structure definitions we need are at this
        -- point already stored inside the "Structure" object.
        (Text -> Parser (MergedStructure (Maybe (PCell e))))
-> (MergedStructure (Maybe (PCell e))
    -> Parser (MergedStructure (Maybe (PCell e))))
-> Either Text (MergedStructure (Maybe (PCell e)))
-> Parser (MergedStructure (Maybe (PCell e)))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser (MergedStructure (Maybe (PCell e)))
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (MergedStructure (Maybe (PCell e))))
-> (Text -> String)
-> Text
-> Parser (MergedStructure (Maybe (PCell e)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) MergedStructure (Maybe (PCell e))
-> Parser (MergedStructure (Maybe (PCell e)))
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (MergedStructure (Maybe (PCell e)))
 -> Parser (MergedStructure (Maybe (PCell e))))
-> Either Text (MergedStructure (Maybe (PCell e)))
-> Parser (MergedStructure (Maybe (PCell e)))
forall a b. (a -> b) -> a -> b
$
          Map StructureName (NamedStructure (Maybe (PCell e)))
-> Parentage Placement
-> PStructure (Maybe (PCell e))
-> Either Text (MergedStructure (Maybe (PCell e)))
forall a.
Map StructureName (NamedStructure (Maybe a))
-> Parentage Placement
-> PStructure (Maybe a)
-> Either Text (MergedStructure (Maybe a))
Assembly.mergeStructures Map StructureName (NamedStructure (Maybe (PCell e)))
forall a. Monoid a => a
mempty Parentage Placement
forall a. Parentage a
Root PStructure (Maybe (PCell e))
unflattenedStructure

      SubworldName
worldName <- Object
v Object -> Key -> Parser (Maybe SubworldName)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"name" Parser (Maybe SubworldName) -> SubworldName -> Parser SubworldName
forall a. Parser (Maybe a) -> a -> Parser a
.!= SubworldName
DefaultRootSubworld
      Location
ul <- Object
v Object -> Key -> Parser (Maybe Location)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"upperleft" Parser (Maybe Location) -> Location -> Parser Location
forall a. Parser (Maybe a) -> a -> Parser a
.!= Location
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin
      [Portal]
portalDefs <- Object
v Object -> Key -> Parser (Maybe [Portal])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"portals" Parser (Maybe [Portal]) -> [Portal] -> Parser [Portal]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
      Navigation Identity WaypointName
navigation <-
        SubworldName
-> Location
-> [Originated Waypoint]
-> [Portal]
-> Parser (Navigation Identity WaypointName)
forall (m :: * -> *) (t :: * -> *).
(MonadFail m, Traversable t) =>
SubworldName
-> Location
-> [Originated Waypoint]
-> t Portal
-> m (Navigation Identity WaypointName)
validatePartialNavigation
          SubworldName
worldName
          Location
ul
          [Originated Waypoint]
unmergedWaypoints
          [Portal]
portalDefs

      Maybe WExp
mwexp <- Object
v Object -> Key -> Parser (Maybe WExp)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"dsl"
      Maybe (TTerm '[] (World CellVal))
worldProg <- Maybe WExp
-> (WExp -> Parser (TTerm '[] (World CellVal)))
-> Parser (Maybe (TTerm '[] (World CellVal)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe WExp
mwexp ((WExp -> Parser (TTerm '[] (World CellVal)))
 -> Parser (Maybe (TTerm '[] (World CellVal))))
-> (WExp -> Parser (TTerm '[] (World CellVal)))
-> Parser (Maybe (TTerm '[] (World CellVal)))
forall a b. (a -> b) -> a -> b
$ \WExp
wexp -> do
        let checkResult :: Either CheckErr (TTerm '[] (World CellVal))
checkResult =
              Identity (Either CheckErr (TTerm '[] (World CellVal)))
-> Either CheckErr (TTerm '[] (World CellVal))
forall a. Identity a -> a
run (Identity (Either CheckErr (TTerm '[] (World CellVal)))
 -> Either CheckErr (TTerm '[] (World CellVal)))
-> (ReaderC
      p
      (ReaderC p (ThrowC CheckErr Identity))
      (TTerm '[] (World CellVal))
    -> Identity (Either CheckErr (TTerm '[] (World CellVal))))
-> ReaderC
     p
     (ReaderC p (ThrowC CheckErr Identity))
     (TTerm '[] (World CellVal))
-> Either CheckErr (TTerm '[] (World CellVal))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow @CheckErr (ThrowC CheckErr Identity (TTerm '[] (World CellVal))
 -> Identity (Either CheckErr (TTerm '[] (World CellVal))))
-> (ReaderC
      p
      (ReaderC p (ThrowC CheckErr Identity))
      (TTerm '[] (World CellVal))
    -> ThrowC CheckErr Identity (TTerm '[] (World CellVal)))
-> ReaderC
     p
     (ReaderC p (ThrowC CheckErr Identity))
     (TTerm '[] (World CellVal))
-> Identity (Either CheckErr (TTerm '[] (World CellVal)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p
-> ReaderC p (ThrowC CheckErr Identity) (TTerm '[] (World CellVal))
-> ThrowC CheckErr Identity (TTerm '[] (World CellVal))
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader p
worldMap (ReaderC p (ThrowC CheckErr Identity) (TTerm '[] (World CellVal))
 -> ThrowC CheckErr Identity (TTerm '[] (World CellVal)))
-> (ReaderC
      p
      (ReaderC p (ThrowC CheckErr Identity))
      (TTerm '[] (World CellVal))
    -> ReaderC
         p (ThrowC CheckErr Identity) (TTerm '[] (World CellVal)))
-> ReaderC
     p
     (ReaderC p (ThrowC CheckErr Identity))
     (TTerm '[] (World CellVal))
-> ThrowC CheckErr Identity (TTerm '[] (World CellVal))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p
-> ReaderC
     p
     (ReaderC p (ThrowC CheckErr Identity))
     (TTerm '[] (World CellVal))
-> ReaderC p (ThrowC CheckErr Identity) (TTerm '[] (World CellVal))
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader p
tem (ReaderC
   p
   (ReaderC p (ThrowC CheckErr Identity))
   (TTerm '[] (World CellVal))
 -> Either CheckErr (TTerm '[] (World CellVal)))
-> ReaderC
     p
     (ReaderC p (ThrowC CheckErr Identity))
     (TTerm '[] (World CellVal))
-> Either CheckErr (TTerm '[] (World CellVal))
forall a b. (a -> b) -> a -> b
$
                Ctx '[]
-> TTy (World CellVal)
-> WExp
-> ReaderC
     p
     (ReaderC p (ThrowC CheckErr Identity))
     (TTerm '[] (World CellVal))
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (g :: [*]) t.
(Has (Throw CheckErr) sig m, Has (Reader TerrainEntityMaps) sig m,
 Has (Reader WorldMap) sig m) =>
Ctx g -> TTy t -> WExp -> m (TTerm g t)
check Ctx '[]
CNil (TTy CellVal -> TTy (World CellVal)
forall t. TTy t -> TTy (Coords -> t)
TTyWorld TTy CellVal
TTyCell) WExp
wexp
        (CheckErr -> Parser (TTerm '[] (World CellVal)))
-> (TTerm '[] (World CellVal)
    -> Parser (TTerm '[] (World CellVal)))
-> Either CheckErr (TTerm '[] (World CellVal))
-> Parser (TTerm '[] (World CellVal))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser (TTerm '[] (World CellVal))
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (TTerm '[] (World CellVal)))
-> (CheckErr -> String)
-> CheckErr
-> Parser (TTerm '[] (World CellVal))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckErr -> String
forall a. PrettyPrec a => a -> String
prettyString) TTerm '[] (World CellVal) -> Parser (TTerm '[] (World CellVal))
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Either CheckErr (TTerm '[] (World CellVal))
checkResult

      Bool
scrollable <- Object
v Object -> Key -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"scrollable" Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
True
      let placedStructures :: [LocatedStructure]
placedStructures =
            (LocatedStructure -> LocatedStructure)
-> [LocatedStructure] -> [LocatedStructure]
forall a b. (a -> b) -> [a] -> [b]
map (V2 Int32 -> LocatedStructure -> LocatedStructure
forall a. HasLocation a => V2 Int32 -> a -> a
offsetLoc (V2 Int32 -> LocatedStructure -> LocatedStructure)
-> V2 Int32 -> LocatedStructure -> LocatedStructure
forall a b. (a -> b) -> a -> b
$ Location -> V2 Int32
forall a b. Coercible a b => a -> b
coerce Location
ul) [LocatedStructure]
staticStructurePlacements

      let area :: PositionedGrid (Maybe (PCell e))
area = (Location -> Location)
-> PositionedGrid (Maybe (PCell e))
-> PositionedGrid (Maybe (PCell e))
forall a. HasLocation a => (Location -> Location) -> a -> a
modifyLoc ((Location
ul Location -> Diff (Point V2) Int32 -> Location
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^) (V2 Int32 -> Location)
-> (Location -> V2 Int32) -> Location -> Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> V2 Int32
asVector) PositionedGrid (Maybe (PCell e))
mergedGrid
      PWorldDescription e -> Parser (PWorldDescription e)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (PWorldDescription e -> Parser (PWorldDescription e))
-> PWorldDescription e -> Parser (PWorldDescription e)
forall a b. (a -> b) -> a -> b
$ WorldDescription {Bool
[LocatedStructure]
Maybe (TTerm '[] (World CellVal))
SubworldName
Navigation Identity WaypointName
StructurePalette (PCell e)
PositionedGrid (Maybe (PCell e))
scrollable :: Bool
palette :: StructurePalette (PCell e)
area :: PositionedGrid (Maybe (PCell e))
navigation :: Navigation Identity WaypointName
placedStructures :: [LocatedStructure]
worldName :: SubworldName
worldProg :: Maybe (TTerm '[] (World CellVal))
palette :: StructurePalette (PCell e)
worldName :: SubworldName
navigation :: Navigation Identity WaypointName
worldProg :: Maybe (TTerm '[] (World CellVal))
scrollable :: Bool
placedStructures :: [LocatedStructure]
area :: PositionedGrid (Maybe (PCell e))
..}

------------------------------------------------------------
-- World editor
------------------------------------------------------------

-- | A pared-down (stateless) version of "WorldDescription" just for
-- the purpose of rendering a Scenario file
type WorldDescriptionPaint = PWorldDescription EntityFacade

instance ToJSON WorldDescriptionPaint where
  toJSON :: WorldDescriptionPaint -> Value
toJSON WorldDescriptionPaint
w =
    [Pair] -> Value
object
      [ Key
"palette" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= KeyMap CellPaintDisplay -> Value
forall a. ToJSON a => a -> Value
Y.toJSON KeyMap CellPaintDisplay
paletteKeymap
      , Key
"upperleft" Key -> Location -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PositionedGrid (Maybe CellPaintDisplay) -> Location
forall a. PositionedGrid a -> Location
gridPosition (WorldDescriptionPaint -> PositionedGrid (Maybe CellPaintDisplay)
forall e. PWorldDescription e -> PositionedGrid (Maybe (PCell e))
area WorldDescriptionPaint
w)
      , Key
"map" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String -> Value
forall a. ToJSON a => a -> Value
Y.toJSON String
mapText
      ]
   where
    cellGrid :: Grid (Maybe CellPaintDisplay)
cellGrid = PositionedGrid (Maybe CellPaintDisplay)
-> Grid (Maybe CellPaintDisplay)
forall a. PositionedGrid a -> Grid a
gridContent (PositionedGrid (Maybe CellPaintDisplay)
 -> Grid (Maybe CellPaintDisplay))
-> PositionedGrid (Maybe CellPaintDisplay)
-> Grid (Maybe CellPaintDisplay)
forall a b. (a -> b) -> a -> b
$ WorldDescriptionPaint -> PositionedGrid (Maybe CellPaintDisplay)
forall e. PWorldDescription e -> PositionedGrid (Maybe (PCell e))
area WorldDescriptionPaint
w
    suggestedPalette :: PaletteAndMaskChar
suggestedPalette = WorldPalette EntityFacade -> Maybe Char -> PaletteAndMaskChar
PaletteAndMaskChar (WorldDescriptionPaint -> WorldPalette EntityFacade
forall e. PWorldDescription e -> WorldPalette e
palette WorldDescriptionPaint
w) Maybe Char
forall a. Maybe a
Nothing
    (String
mapText, KeyMap CellPaintDisplay
paletteKeymap) = PaletteAndMaskChar
-> Grid (Maybe CellPaintDisplay)
-> (String, KeyMap CellPaintDisplay)
prepForJson PaletteAndMaskChar
suggestedPalette Grid (Maybe CellPaintDisplay)
cellGrid