{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
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
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)
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
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