{-# 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
import Swarm.Game.Land
import Swarm.Game.Location
import Swarm.Game.Scenario.RobotLookup
import Swarm.Game.Scenario.Topography.Cell
import Swarm.Game.Scenario.Topography.EntityFacade
import Swarm.Game.Scenario.Topography.Grid (Grid (EmptyGrid))
import Swarm.Game.Scenario.Topography.Navigation.Portal
import Swarm.Game.Scenario.Topography.Navigation.Waypoint (
  Parentage (Root),
  WaypointName,
 )
import Swarm.Game.Scenario.Topography.ProtoCell
import Swarm.Game.Scenario.Topography.Structure (
  LocatedStructure,
  MergedStructure (MergedStructure),
  NamedStructure,
  PStructure (Structure),
  paintMap,
 )
import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly
import Swarm.Game.Scenario.Topography.Structure.Overlay
import Swarm.Game.Scenario.Topography.WorldPalette
import Swarm.Game.Universe
import Swarm.Game.World.Parse ()
import Swarm.Game.World.Syntax
import Swarm.Game.World.Typecheck
import Swarm.Language.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
offsetOrigin :: Bool
  , forall e. PWorldDescription e -> Bool
scrollable :: Bool
  , forall e. PWorldDescription e -> WorldPalette e
palette :: WorldPalette e
  , forall e. PWorldDescription e -> Location
ul :: Location
  , 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]
  , 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

integrateArea ::
  WorldPalette e ->
  [NamedStructure (Maybe (PCell e))] ->
  Object ->
  Parser (MergedStructure (Maybe (PCell e)))
integrateArea :: forall e.
WorldPalette e
-> [NamedStructure (Maybe (PCell e))]
-> Object
-> Parser (MergedStructure (Maybe (PCell e)))
integrateArea WorldPalette e
palette [NamedStructure (Maybe (PCell e))]
initialStructureDefs Object
v = do
  [Placement]
placementDefs <- Object
v Object -> Key -> Parser (Maybe [Placement])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"placements" Parser (Maybe [Placement]) -> [Placement] -> Parser [Placement]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
  [Waypoint]
waypointDefs <- Object
v Object -> Key -> Parser (Maybe [Waypoint])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"waypoints" Parser (Maybe [Waypoint]) -> [Waypoint] -> Parser [Waypoint]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
  Grid Char
rawMap <- Object
v Object -> Key -> Parser (Maybe (Grid Char))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"map" Parser (Maybe (Grid Char)) -> Grid Char -> Parser (Grid Char)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Grid Char
forall c. Grid c
EmptyGrid
  (Grid (Maybe (PCell e))
initialArea, [Waypoint]
mapWaypoints) <- Maybe Char
-> WorldPalette e
-> Grid Char
-> Parser (Grid (Maybe (PCell e)), [Waypoint])
forall (m :: * -> *) c.
MonadFail m =>
Maybe Char
-> StructurePalette c
-> Grid Char
-> m (Grid (Maybe c), [Waypoint])
paintMap Maybe Char
forall a. Maybe a
Nothing WorldPalette e
palette Grid Char
rawMap
  let unflattenedStructure :: PStructure (Maybe (PCell e))
unflattenedStructure =
        PositionedGrid (Maybe (PCell e))
-> [NamedStructure (Maybe (PCell e))]
-> [Placement]
-> [Waypoint]
-> PStructure (Maybe (PCell e))
forall c.
PositionedGrid c
-> [NamedStructure c] -> [Placement] -> [Waypoint] -> PStructure c
Structure
          (Location
-> Grid (Maybe (PCell e)) -> PositionedGrid (Maybe (PCell e))
forall a. Location -> Grid a -> PositionedGrid a
PositionedGrid Location
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin Grid (Maybe (PCell e))
initialArea)
          [NamedStructure (Maybe (PCell e))]
initialStructureDefs
          [Placement]
placementDefs
          ([Waypoint]
waypointDefs [Waypoint] -> [Waypoint] -> [Waypoint]
forall a. Semigroup a => a -> a -> a
<> [Waypoint]
mapWaypoints)
  (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

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
..!= KeyMap (SignpostableCell (PCell Entity))
-> StructurePalette (PCell Entity)
forall e. KeyMap (SignpostableCell e) -> StructurePalette e
StructurePalette KeyMap (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 structureDefs :: [NamedStructure (Maybe (PCell Entity))]
structureDefs = [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
    MergedStructure PositionedGrid (Maybe (PCell Entity))
area [LocatedStructure]
staticStructurePlacements [Originated Waypoint]
unmergedWaypoints <-
      Parser (MergedStructure (Maybe (PCell Entity)))
-> With
     WorldParseDependencies
     Parser
     (MergedStructure (Maybe (PCell Entity)))
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Parser (MergedStructure (Maybe (PCell Entity)))
 -> With
      WorldParseDependencies
      Parser
      (MergedStructure (Maybe (PCell Entity))))
-> Parser (MergedStructure (Maybe (PCell Entity)))
-> With
     WorldParseDependencies
     Parser
     (MergedStructure (Maybe (PCell Entity)))
forall a b. (a -> b) -> a -> b
$ StructurePalette (PCell Entity)
-> [NamedStructure (Maybe (PCell Entity))]
-> Object
-> Parser (MergedStructure (Maybe (PCell Entity)))
forall e.
WorldPalette e
-> [NamedStructure (Maybe (PCell e))]
-> Object
-> Parser (MergedStructure (Maybe (PCell e)))
integrateArea StructurePalette (PCell Entity)
palette [NamedStructure (Maybe (PCell Entity))]
structureDefs Object
v

    SubworldName
worldName <- Parser SubworldName
-> With WorldParseDependencies Parser SubworldName
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Parser SubworldName
 -> With WorldParseDependencies Parser SubworldName)
-> Parser SubworldName
-> With WorldParseDependencies Parser SubworldName
forall a b. (a -> b) -> a -> b
$ 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 <- Parser Location -> With WorldParseDependencies Parser Location
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Parser Location -> With WorldParseDependencies Parser Location)
-> Parser Location -> With WorldParseDependencies Parser Location
forall a b. (a -> b) -> a -> b
$ 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 <- Parser [Portal] -> With WorldParseDependencies Parser [Portal]
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Parser [Portal] -> With WorldParseDependencies Parser [Portal])
-> Parser [Portal] -> With WorldParseDependencies Parser [Portal]
forall a b. (a -> b) -> a -> b
$ 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]
-> With
     WorldParseDependencies 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 <- Parser (Maybe WExp)
-> With WorldParseDependencies Parser (Maybe WExp)
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Parser (Maybe WExp)
 -> With WorldParseDependencies Parser (Maybe WExp))
-> Parser (Maybe WExp)
-> With WorldParseDependencies Parser (Maybe WExp)
forall a b. (a -> b) -> a -> b
$ 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
    -> With WorldParseDependencies Parser (TTerm '[] (World CellVal)))
-> With
     WorldParseDependencies 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
  -> With WorldParseDependencies Parser (TTerm '[] (World CellVal)))
 -> With
      WorldParseDependencies Parser (Maybe (TTerm '[] (World CellVal))))
-> (WExp
    -> With WorldParseDependencies Parser (TTerm '[] (World CellVal)))
-> With
     WorldParseDependencies 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
      TerrainEntityMaps
      (ReaderC WorldMap (ThrowC CheckErr Identity))
      (TTerm '[] (World CellVal))
    -> Identity (Either CheckErr (TTerm '[] (World CellVal))))
-> ReaderC
     TerrainEntityMaps
     (ReaderC WorldMap (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
      TerrainEntityMaps
      (ReaderC WorldMap (ThrowC CheckErr Identity))
      (TTerm '[] (World CellVal))
    -> ThrowC CheckErr Identity (TTerm '[] (World CellVal)))
-> ReaderC
     TerrainEntityMaps
     (ReaderC WorldMap (ThrowC CheckErr Identity))
     (TTerm '[] (World CellVal))
-> Identity (Either CheckErr (TTerm '[] (World CellVal)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorldMap
-> ReaderC
     WorldMap (ThrowC CheckErr Identity) (TTerm '[] (World CellVal))
-> ThrowC CheckErr Identity (TTerm '[] (World CellVal))
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader WorldMap
worldMap (ReaderC
   WorldMap (ThrowC CheckErr Identity) (TTerm '[] (World CellVal))
 -> ThrowC CheckErr Identity (TTerm '[] (World CellVal)))
-> (ReaderC
      TerrainEntityMaps
      (ReaderC WorldMap (ThrowC CheckErr Identity))
      (TTerm '[] (World CellVal))
    -> ReaderC
         WorldMap (ThrowC CheckErr Identity) (TTerm '[] (World CellVal)))
-> ReaderC
     TerrainEntityMaps
     (ReaderC WorldMap (ThrowC CheckErr Identity))
     (TTerm '[] (World CellVal))
-> ThrowC CheckErr Identity (TTerm '[] (World CellVal))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TerrainEntityMaps
-> ReaderC
     TerrainEntityMaps
     (ReaderC WorldMap (ThrowC CheckErr Identity))
     (TTerm '[] (World CellVal))
-> ReaderC
     WorldMap (ThrowC CheckErr Identity) (TTerm '[] (World CellVal))
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader TerrainEntityMaps
tem (ReaderC
   TerrainEntityMaps
   (ReaderC WorldMap (ThrowC CheckErr Identity))
   (TTerm '[] (World CellVal))
 -> Either CheckErr (TTerm '[] (World CellVal)))
-> ReaderC
     TerrainEntityMaps
     (ReaderC WorldMap (ThrowC CheckErr Identity))
     (TTerm '[] (World CellVal))
-> Either CheckErr (TTerm '[] (World CellVal))
forall a b. (a -> b) -> a -> b
$
              Ctx '[]
-> TTy (World CellVal)
-> WExp
-> ReaderC
     TerrainEntityMaps
     (ReaderC WorldMap (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
 -> With WorldParseDependencies Parser (TTerm '[] (World CellVal)))
-> (TTerm '[] (World CellVal)
    -> With WorldParseDependencies Parser (TTerm '[] (World CellVal)))
-> Either CheckErr (TTerm '[] (World CellVal))
-> With WorldParseDependencies Parser (TTerm '[] (World CellVal))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String
-> With WorldParseDependencies Parser (TTerm '[] (World CellVal))
forall a. String -> With WorldParseDependencies Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
 -> With WorldParseDependencies Parser (TTerm '[] (World CellVal)))
-> (CheckErr -> String)
-> CheckErr
-> With WorldParseDependencies 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)
-> With WorldParseDependencies Parser (TTerm '[] (World CellVal))
forall a. a -> With WorldParseDependencies Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Either CheckErr (TTerm '[] (World CellVal))
checkResult

    Bool
offsetOrigin <- Parser Bool -> With WorldParseDependencies Parser Bool
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Parser Bool -> With WorldParseDependencies Parser Bool)
-> Parser Bool -> With WorldParseDependencies Parser Bool
forall a b. (a -> b) -> a -> b
$ Object
v Object -> Key -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"offset" Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False
    Bool
scrollable <- Parser Bool -> With WorldParseDependencies Parser Bool
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Parser Bool -> With WorldParseDependencies Parser Bool)
-> Parser Bool -> With WorldParseDependencies Parser Bool
forall a b. (a -> b) -> a -> b
$ 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
    WorldDescription -> ParserE WorldParseDependencies WorldDescription
forall a. a -> With WorldParseDependencies Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (WorldDescription
 -> ParserE WorldParseDependencies WorldDescription)
-> WorldDescription
-> ParserE WorldParseDependencies WorldDescription
forall a b. (a -> b) -> a -> b
$ WorldDescription {Bool
[LocatedStructure]
Maybe (TTerm '[] (World CellVal))
Location
SubworldName
Navigation Identity WaypointName
StructurePalette (PCell Entity)
PositionedGrid (Maybe (PCell Entity))
offsetOrigin :: Bool
scrollable :: Bool
palette :: StructurePalette (PCell Entity)
ul :: Location
area :: PositionedGrid (Maybe (PCell Entity))
navigation :: Navigation Identity WaypointName
placedStructures :: [LocatedStructure]
worldName :: SubworldName
worldProg :: Maybe (TTerm '[] (World CellVal))
palette :: StructurePalette (PCell Entity)
area :: PositionedGrid (Maybe (PCell Entity))
worldName :: SubworldName
ul :: Location
navigation :: Navigation Identity WaypointName
worldProg :: Maybe (TTerm '[] (World CellVal))
offsetOrigin :: Bool
scrollable :: Bool
placedStructures :: [LocatedStructure]
..}

------------------------------------------------------------
-- 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
"offset" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= WorldDescriptionPaint -> Bool
forall e. PWorldDescription e -> Bool
offsetOrigin WorldDescriptionPaint
w
      , 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
.= WorldDescriptionPaint -> Location
forall e. PWorldDescription e -> Location
ul 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