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

-- |
-- 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.Functor.Identity
import Data.Maybe (catMaybes)
import Data.Yaml as Y
import Swarm.Game.Entity
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.Navigation.Portal
import Swarm.Game.Scenario.Topography.Navigation.Waypoint (
  WaypointName,
 )
import Swarm.Game.Scenario.Topography.Structure (InheritedStructureDefs, MergedStructure (MergedStructure), PStructure (Structure))
import Swarm.Game.Scenario.Topography.Structure qualified as Structure
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 -> [[PCell e]]
area :: [[PCell e]]
  , forall e. PWorldDescription e -> Navigation Identity WaypointName
navigation :: Navigation Identity WaypointName
  , 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
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
showList :: [PWorldDescription e] -> ShowS
$cshowList :: forall e. Show e => [PWorldDescription e] -> ShowS
show :: PWorldDescription e -> String
$cshow :: forall e. Show e => PWorldDescription e -> String
showsPrec :: Int -> PWorldDescription e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> PWorldDescription e -> ShowS
Show)

type WorldDescription = PWorldDescription Entity

instance FromJSONE (WorldMap, InheritedStructureDefs, EntityMap, RobotMap) WorldDescription where
  parseJSONE :: Value
-> ParserE
     (WorldMap, InheritedStructureDefs, EntityMap, RobotMap)
     WorldDescription
parseJSONE = forall e a.
String -> (Object -> ParserE e a) -> Value -> ParserE e a
withObjectE String
"world description" forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    (WorldMap
worldMap, InheritedStructureDefs
scenarioLevelStructureDefs, EntityMap
em, RobotMap
rm) <- forall (f :: * -> *) e. Monad f => With e f e
getE
    (WorldPalette Entity
pal, InheritedStructureDefs
rootWorldStructureDefs) <- forall e' e (f :: * -> *) a. (e' -> e) -> With e f a -> With e' f a
localE (forall a b. a -> b -> a
const (EntityMap
em, RobotMap
rm)) forall a b. (a -> b) -> a -> b
$ do
      WorldPalette Entity
pal <- Object
v forall e a. FromJSONE e a => Object -> Text -> ParserE e (Maybe a)
..:? Text
"palette" forall (f :: * -> *) a. Functor f => f (Maybe a) -> a -> f a
..!= forall e. KeyMap (AugmentedCell e) -> WorldPalette e
WorldPalette forall a. Monoid a => a
mempty
      InheritedStructureDefs
rootWorldStructs <- Object
v forall e a. FromJSONE e a => Object -> Text -> ParserE e (Maybe a)
..:? Text
"structures" forall (f :: * -> *) a. Functor f => f (Maybe a) -> a -> f a
..!= []
      forall (m :: * -> *) a. Monad m => a -> m a
return (WorldPalette Entity
pal, InheritedStructureDefs
rootWorldStructs)

    [Waypoint]
waypointDefs <- forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE forall a b. (a -> b) -> a -> b
$ Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"waypoints" forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    [Portal]
portalDefs <- forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE forall a b. (a -> b) -> a -> b
$ Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"portals" forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    [Placement]
placementDefs <- forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE forall a b. (a -> b) -> a -> b
$ Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"placements" forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    ([[Maybe (PCell Entity)]]
initialArea, [Waypoint]
mapWaypoints) <- forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE ((Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"map" forall a. Parser (Maybe a) -> a -> Parser a
.!= Text
"") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) e.
MonadFail m =>
Maybe Char
-> WorldPalette e -> Text -> m ([[Maybe (PCell e)]], [Waypoint])
Structure.paintMap forall a. Maybe a
Nothing WorldPalette Entity
pal)

    Location
upperLeft <- forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"upperleft" forall a. Parser (Maybe a) -> a -> Parser a
.!= forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin)
    SubworldName
subWorldName <- forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"name" forall a. Parser (Maybe a) -> a -> Parser a
.!= SubworldName
DefaultRootSubworld)

    let initialStructureDefs :: InheritedStructureDefs
initialStructureDefs = InheritedStructureDefs
scenarioLevelStructureDefs forall a. Semigroup a => a -> a -> a
<> InheritedStructureDefs
rootWorldStructureDefs
        struc :: PStructure (Maybe (PCell Entity))
struc = forall c.
[[c]]
-> [NamedStructure c] -> [Placement] -> [Waypoint] -> PStructure c
Structure [[Maybe (PCell Entity)]]
initialArea InheritedStructureDefs
initialStructureDefs [Placement]
placementDefs forall a b. (a -> b) -> a -> b
$ [Waypoint]
waypointDefs forall a. Semigroup a => a -> a -> a
<> [Waypoint]
mapWaypoints
        MergedStructure [[Maybe (PCell Entity)]]
mergedArea [Originated Waypoint]
unmergedWaypoints = forall a.
Map StructureName (PStructure (Maybe a))
-> Maybe Placement
-> PStructure (Maybe a)
-> MergedStructure (Maybe a)
Structure.mergeStructures forall a. Monoid a => a
mempty forall a. Maybe a
Nothing PStructure (Maybe (PCell Entity))
struc

    Navigation Identity WaypointName
validatedNavigation <-
      forall (m :: * -> *) (t :: * -> *).
(MonadFail m, Traversable t) =>
SubworldName
-> Location
-> [Originated Waypoint]
-> t Portal
-> m (Navigation Identity WaypointName)
validatePartialNavigation
        SubworldName
subWorldName
        Location
upperLeft
        [Originated Waypoint]
unmergedWaypoints
        [Portal]
portalDefs

    Maybe WExp
mwexp <- forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"dsl")
    Maybe (TTerm '[] (World CellVal))
dslTerm <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe WExp
mwexp forall a b. (a -> b) -> a -> b
$ \WExp
wexp -> do
      let checkResult :: Either CheckErr (TTerm '[] (World CellVal))
checkResult =
            forall a. Identity a -> a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow @CheckErr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader WorldMap
worldMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader EntityMap
em forall a b. (a -> b) -> a -> b
$
              forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (g :: [*]) t.
(Has (Throw CheckErr) sig m, Has (Reader EntityMap) sig m,
 Has (Reader WorldMap) sig m) =>
Ctx g -> TTy t -> WExp -> m (TTerm g t)
check Ctx '[]
CNil (forall t. TTy t -> TTy (Coords -> t)
TTyWorld TTy CellVal
TTyCell) WExp
wexp
      forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PrettyPrec a => a -> String
prettyString) forall (m :: * -> *) a. Monad m => a -> m a
return Either CheckErr (TTerm '[] (World CellVal))
checkResult
    forall e.
Bool
-> Bool
-> WorldPalette e
-> Location
-> [[PCell e]]
-> Navigation Identity WaypointName
-> SubworldName
-> Maybe (TTerm '[] (World CellVal))
-> PWorldDescription e
WorldDescription
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"offset" forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False)
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"scrollable" forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
True)
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure WorldPalette Entity
pal
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Location
upperLeft
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (a -> b) -> [a] -> [b]
map forall a. [Maybe a] -> [a]
catMaybes [[Maybe (PCell Entity)]]
mergedArea) -- Root-level map has no transparent cells.
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Navigation Identity WaypointName
validatedNavigation
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure SubworldName
subWorldName
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TTerm '[] (World CellVal))
dslTerm

------------------------------------------------------------
-- 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall e. PWorldDescription e -> Bool
offsetOrigin WorldDescriptionPaint
w
      , Key
"palette" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
Y.toJSON KeyMap CellPaintDisplay
paletteKeymap
      , Key
"upperleft" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall e. PWorldDescription e -> Location
ul WorldDescriptionPaint
w
      , Key
"map" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
Y.toJSON Text
mapText
      ]
   where
    cellGrid :: [[CellPaintDisplay]]
cellGrid = forall e. PWorldDescription e -> [[PCell e]]
area WorldDescriptionPaint
w
    suggestedPalette :: WorldPalette EntityFacade
suggestedPalette = forall e. PWorldDescription e -> WorldPalette e
palette WorldDescriptionPaint
w
    (Text
mapText, KeyMap CellPaintDisplay
paletteKeymap) = WorldPalette EntityFacade
-> [[CellPaintDisplay]] -> (Text, KeyMap CellPaintDisplay)
prepForJson WorldPalette EntityFacade
suggestedPalette [[CellPaintDisplay]]
cellGrid