{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
-- Description: Standalone worlds
--
-- Scenarios are standalone worlds with specific starting and winning
-- conditions, which can be used both for building interactive
-- tutorials and for standalone puzzles and scenarios.
module Swarm.Game.Scenario (
  -- * Scenario
  Scenario (..),
  ScenarioLandscape (..),
  ScenarioMetadata (ScenarioMetadata),
  RecognizableStructureContent,
  staticPlacements,

  -- ** Fields
  scenarioMetadata,
  scenarioOperation,
  scenarioLandscape,
  scenarioVersion,
  scenarioName,
  scenarioAuthor,
  scenarioDescription,
  scenarioCreative,
  scenarioSeed,
  scenarioAttrs,
  scenarioTerrainAndEntities,
  scenarioCosmetics,
  scenarioRecipes,
  scenarioKnown,
  scenarioWorlds,
  scenarioNavigation,
  scenarioStructures,
  scenarioRobots,
  scenarioObjectives,
  scenarioSolution,
  scenarioStepsPerTick,

  -- * Loading from disk
  loadScenario,
  loadScenarioFile,
  getScenarioPath,
  loadStandaloneScenario,
  GameStateInputs (..),
  ScenarioInputs (..),

  -- * Utilities
  arbitrateSeed,
) where

import Control.Applicative ((<|>))
import Control.Arrow ((&&&))
import Control.Carrier.Throw.Either (runThrow)
import Control.Effect.Lift (Lift, sendIO)
import Control.Effect.Throw
import Control.Lens hiding (from, (.=), (<.>))
import Control.Monad (filterM, forM_, unless, (<=<))
import Data.Aeson
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Maybe (catMaybes, isNothing, listToMaybe, mapMaybe)
import Data.Sequence (Seq)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics (Generic)
import Swarm.Failure
import Swarm.Game.Entity
import Swarm.Game.Entity.Cosmetic
import Swarm.Game.Entity.Cosmetic.Assignment (worldAttributes)
import Swarm.Game.Land
import Swarm.Game.Location (Location)
import Swarm.Game.Recipe
import Swarm.Game.Robot (TRobot, trobotLocation, trobotName)
import Swarm.Game.Scenario.Objective (Objective)
import Swarm.Game.Scenario.Objective.Validation
import Swarm.Game.Scenario.RobotLookup
import Swarm.Game.Scenario.Style
import Swarm.Game.Scenario.Topography.Cell
import Swarm.Game.Scenario.Topography.Grid
import Swarm.Game.Scenario.Topography.Navigation.Portal
import Swarm.Game.Scenario.Topography.Navigation.Waypoint (Parentage (..))
import Swarm.Game.Scenario.Topography.Structure qualified as Structure
import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly
import Swarm.Game.Scenario.Topography.Structure.Named qualified as Structure
import Swarm.Game.Scenario.Topography.Structure.Overlay
import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute
import Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry (renderRedundancy)
import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
import Swarm.Game.Scenario.Topography.WorldDescription
import Swarm.Game.Terrain
import Swarm.Game.Universe
import Swarm.Game.World.Gen (Seed)
import Swarm.Game.World.Load (loadWorlds)
import Swarm.Game.World.Typecheck (WorldMap)
import Swarm.Language.Syntax (Syntax, TSyntax)
import Swarm.Language.Text.Markdown (Document)
import Swarm.Pretty (prettyText)
import Swarm.ResourceLoading (getDataFileNameSafe)
import Swarm.Util (binTuples, commaList, failT, quote)
import Swarm.Util.Effect (ignoreWarnings, throwToMaybe, withThrow)
import Swarm.Util.Lens (makeLensesNoSigs)
import Swarm.Util.Yaml
import System.Directory (doesFileExist)
import System.FilePath ((<.>), (</>))
import System.Random (randomRIO)

-- * Scenario records

-- | Authorship information about scenario not used at play-time
data ScenarioMetadata = ScenarioMetadata
  { ScenarioMetadata -> Seed
_scenarioVersion :: Int
  , ScenarioMetadata -> Text
_scenarioName :: Text
  , ScenarioMetadata -> Maybe Text
_scenarioAuthor :: Maybe Text
  }
  deriving (Seed -> ScenarioMetadata -> ShowS
[ScenarioMetadata] -> ShowS
ScenarioMetadata -> String
(Seed -> ScenarioMetadata -> ShowS)
-> (ScenarioMetadata -> String)
-> ([ScenarioMetadata] -> ShowS)
-> Show ScenarioMetadata
forall a.
(Seed -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Seed -> ScenarioMetadata -> ShowS
showsPrec :: Seed -> ScenarioMetadata -> ShowS
$cshow :: ScenarioMetadata -> String
show :: ScenarioMetadata -> String
$cshowList :: [ScenarioMetadata] -> ShowS
showList :: [ScenarioMetadata] -> ShowS
Show, (forall x. ScenarioMetadata -> Rep ScenarioMetadata x)
-> (forall x. Rep ScenarioMetadata x -> ScenarioMetadata)
-> Generic ScenarioMetadata
forall x. Rep ScenarioMetadata x -> ScenarioMetadata
forall x. ScenarioMetadata -> Rep ScenarioMetadata x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ScenarioMetadata -> Rep ScenarioMetadata x
from :: forall x. ScenarioMetadata -> Rep ScenarioMetadata x
$cto :: forall x. Rep ScenarioMetadata x -> ScenarioMetadata
to :: forall x. Rep ScenarioMetadata x -> ScenarioMetadata
Generic)

instance ToJSON ScenarioMetadata where
  toEncoding :: ScenarioMetadata -> Encoding
toEncoding =
    Options -> ScenarioMetadata -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding
      Options
defaultOptions
        { fieldLabelModifier = drop 1 -- drops leading underscore
        }

makeLensesNoSigs ''ScenarioMetadata

-- | The version number of the scenario schema.  Currently, this
--   should always be 1, but it is ignored.  In the future, this may
--   be used to convert older formats to newer ones, or simply to
--   print a nice error message when we can't read an older format.
scenarioVersion :: Lens' ScenarioMetadata Int

-- | The name of the scenario.
scenarioName :: Lens' ScenarioMetadata Text

-- | The author of the scenario.
scenarioAuthor :: Lens' ScenarioMetadata (Maybe Text)

-- | Non-structural gameplay content of the scenario;
-- how it is to be played.
data ScenarioOperation = ScenarioOperation
  { ScenarioOperation -> Bool
_scenarioCreative :: Bool
  , ScenarioOperation -> Document Syntax
_scenarioDescription :: Document Syntax
  -- ^ Note: the description is in this record instead of
  -- 'ScenarioMetadata' because it relates to the goals.
  , ScenarioOperation -> [Objective]
_scenarioObjectives :: [Objective]
  , ScenarioOperation -> Maybe TSyntax
_scenarioSolution :: Maybe TSyntax
  , ScenarioOperation -> [Recipe Entity]
_scenarioRecipes :: [Recipe Entity]
  , ScenarioOperation -> Maybe Seed
_scenarioStepsPerTick :: Maybe Int
  }
  deriving (Seed -> ScenarioOperation -> ShowS
[ScenarioOperation] -> ShowS
ScenarioOperation -> String
(Seed -> ScenarioOperation -> ShowS)
-> (ScenarioOperation -> String)
-> ([ScenarioOperation] -> ShowS)
-> Show ScenarioOperation
forall a.
(Seed -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Seed -> ScenarioOperation -> ShowS
showsPrec :: Seed -> ScenarioOperation -> ShowS
$cshow :: ScenarioOperation -> String
show :: ScenarioOperation -> String
$cshowList :: [ScenarioOperation] -> ShowS
showList :: [ScenarioOperation] -> ShowS
Show)

makeLensesNoSigs ''ScenarioOperation

-- | A high-level description of the scenario, shown /e.g./ in the
--   menu.
scenarioDescription :: Lens' ScenarioOperation (Document Syntax)

-- | Whether the scenario should start in creative mode.
scenarioCreative :: Lens' ScenarioOperation Bool

-- | Any custom recipes used in this scenario.
scenarioRecipes :: Lens' ScenarioOperation [Recipe Entity]

-- | A sequence of objectives for the scenario (if any).
scenarioObjectives :: Lens' ScenarioOperation [Objective]

-- | An optional solution of the scenario, expressed as a
--   program of type @cmd a@. This is useful for automated
--   testing of the win condition.
scenarioSolution :: Lens' ScenarioOperation (Maybe TSyntax)

-- | Optionally, specify the maximum number of steps each robot may
--   take during a single tick.
scenarioStepsPerTick :: Lens' ScenarioOperation (Maybe Int)

type RecognizableStructureContent = NonEmptyGrid (Maybe Cell)

-- | All cosmetic and structural content of the scenario.
data ScenarioLandscape = ScenarioLandscape
  { ScenarioLandscape -> Maybe Seed
_scenarioSeed :: Maybe Int
  , ScenarioLandscape -> [CustomAttr]
_scenarioAttrs :: [CustomAttr]
  , ScenarioLandscape -> TerrainEntityMaps
_scenarioTerrainAndEntities :: TerrainEntityMaps
  , ScenarioLandscape -> Map WorldAttr PreservableColor
_scenarioCosmetics :: M.Map WorldAttr PreservableColor
  , ScenarioLandscape -> Set Text
_scenarioKnown :: Set EntityName
  , ScenarioLandscape -> NonEmpty WorldDescription
_scenarioWorlds :: NonEmpty WorldDescription
  , ScenarioLandscape -> Navigation (Map SubworldName) Location
_scenarioNavigation :: Navigation (M.Map SubworldName) Location
  , ScenarioLandscape
-> StaticStructureInfo RecognizableStructureContent Entity
_scenarioStructures :: StaticStructureInfo RecognizableStructureContent Entity
  , ScenarioLandscape -> [TRobot]
_scenarioRobots :: [TRobot]
  }

makeLensesNoSigs ''ScenarioLandscape

-- | The seed used for the random number generator.  If @Nothing@, use
--   a random seed / prompt the user for the seed.
scenarioSeed :: Lens' ScenarioLandscape (Maybe Int)

-- | Custom attributes defined in the scenario.
scenarioAttrs :: Lens' ScenarioLandscape [CustomAttr]

-- | Any custom terrain and entities used for this scenario,
-- combined with the default system terrain and entities.
scenarioTerrainAndEntities :: Lens' ScenarioLandscape TerrainEntityMaps

-- | High-fidelity color map for entities
scenarioCosmetics :: Lens' ScenarioLandscape (M.Map WorldAttr PreservableColor)

-- | List of entities that should be considered "known", so robots do
--   not have to scan them.
scenarioKnown :: Lens' ScenarioLandscape (Set EntityName)

-- | The subworlds of the scenario.
-- The "root" subworld shall always be at the head of the list, by construction.
scenarioWorlds :: Lens' ScenarioLandscape (NonEmpty WorldDescription)

-- | Information required for structure recognition
scenarioStructures :: Lens' ScenarioLandscape (StaticStructureInfo RecognizableStructureContent Entity)

-- | Waypoints and inter-world portals
scenarioNavigation :: Lens' ScenarioLandscape (Navigation (M.Map SubworldName) Location)

-- | The starting robots for the scenario.  Note this should
--   include the base.
scenarioRobots :: Lens' ScenarioLandscape [TRobot]

-- | A 'Scenario' contains all the information to describe a
--   scenario.
data Scenario = Scenario
  { Scenario -> ScenarioMetadata
_scenarioMetadata :: ScenarioMetadata
  , Scenario -> ScenarioOperation
_scenarioOperation :: ScenarioOperation
  , Scenario -> ScenarioLandscape
_scenarioLandscape :: ScenarioLandscape
  }

makeLensesNoSigs ''Scenario

-- | Authorship information about scenario not used at play-time
scenarioMetadata :: Lens' Scenario ScenarioMetadata

-- | Non-structural gameplay content of the scenario;
-- how it is to be played.
scenarioOperation :: Lens' Scenario ScenarioOperation

-- | All cosmetic and structural content of the scenario.
scenarioLandscape :: Lens' Scenario ScenarioLandscape

-- * Parsing

instance FromJSONE ScenarioInputs Scenario where
  parseJSONE :: Value -> ParserE ScenarioInputs Scenario
parseJSONE = String
-> (Object -> ParserE ScenarioInputs Scenario)
-> Value
-> ParserE ScenarioInputs Scenario
forall e a.
String -> (Object -> ParserE e a) -> Value -> ParserE e a
withObjectE String
"scenario" ((Object -> ParserE ScenarioInputs Scenario)
 -> Value -> ParserE ScenarioInputs Scenario)
-> (Object -> ParserE ScenarioInputs Scenario)
-> Value
-> ParserE ScenarioInputs Scenario
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    -- parse custom terrain
    [TerrainItem]
tmRaw <- Parser [TerrainItem] -> With ScenarioInputs Parser [TerrainItem]
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v Object -> Key -> Parser (Maybe [TerrainItem])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"terrains" Parser (Maybe [TerrainItem])
-> [TerrainItem] -> Parser [TerrainItem]
forall a. Parser (Maybe a) -> a -> Parser a
.!= [])

    -- parse custom entities
    [Entity]
emRaw <- Parser [Entity] -> With ScenarioInputs Parser [Entity]
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v Object -> Key -> Parser (Maybe [Entity])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"entities" Parser (Maybe [Entity]) -> [Entity] -> Parser [Entity]
forall a. Parser (Maybe a) -> a -> Parser a
.!= [])

    [CustomAttr]
parsedAttrs <- Parser [CustomAttr] -> With ScenarioInputs Parser [CustomAttr]
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v Object -> Key -> Parser (Maybe [CustomAttr])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"attrs" Parser (Maybe [CustomAttr]) -> [CustomAttr] -> Parser [CustomAttr]
forall a. Parser (Maybe a) -> a -> Parser a
.!= [])
    let mergedCosmetics :: Map WorldAttr PreservableColor
mergedCosmetics = Map WorldAttr PreservableColor
worldAttributes Map WorldAttr PreservableColor
-> Map WorldAttr PreservableColor -> Map WorldAttr PreservableColor
forall a. Semigroup a => a -> a -> a
<> [(WorldAttr, PreservableColor)] -> Map WorldAttr PreservableColor
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ((CustomAttr -> Maybe (WorldAttr, PreservableColor))
-> [CustomAttr] -> [(WorldAttr, PreservableColor)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe CustomAttr -> Maybe (WorldAttr, PreservableColor)
toHifiPair [CustomAttr]
parsedAttrs)
        attrsUnion :: Set WorldAttr
attrsUnion = Map WorldAttr PreservableColor -> Set WorldAttr
forall k a. Map k a -> Set k
M.keysSet Map WorldAttr PreservableColor
mergedCosmetics

    [TerrainObj]
validatedTerrainObjects <- ThrowC LoadingFailure Identity [TerrainObj]
-> With ScenarioInputs Parser [TerrainObj]
forall {m :: * -> *} {a}.
MonadFail m =>
ThrowC LoadingFailure Identity a -> m a
runValidation (ThrowC LoadingFailure Identity [TerrainObj]
 -> With ScenarioInputs Parser [TerrainObj])
-> ThrowC LoadingFailure Identity [TerrainObj]
-> With ScenarioInputs Parser [TerrainObj]
forall a b. (a -> b) -> a -> b
$ Set WorldAttr
-> [TerrainItem] -> ThrowC LoadingFailure Identity [TerrainObj]
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw LoadingFailure) sig m =>
Set WorldAttr -> [TerrainItem] -> m [TerrainObj]
validateTerrainAttrRefs Set WorldAttr
attrsUnion [TerrainItem]
tmRaw

    ThrowC LoadingFailure Identity () -> With ScenarioInputs Parser ()
forall {m :: * -> *} {a}.
MonadFail m =>
ThrowC LoadingFailure Identity a -> m a
runValidation (ThrowC LoadingFailure Identity ()
 -> With ScenarioInputs Parser ())
-> ThrowC LoadingFailure Identity ()
-> With ScenarioInputs Parser ()
forall a b. (a -> b) -> a -> b
$ Set WorldAttr -> [Entity] -> ThrowC LoadingFailure Identity ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw LoadingFailure) sig m =>
Set WorldAttr -> [Entity] -> m ()
validateEntityAttrRefs Set WorldAttr
attrsUnion [Entity]
emRaw

    EntityMap
em <- ThrowC LoadingFailure Identity EntityMap
-> With ScenarioInputs Parser EntityMap
forall {m :: * -> *} {a}.
MonadFail m =>
ThrowC LoadingFailure Identity a -> m a
runValidation (ThrowC LoadingFailure Identity EntityMap
 -> With ScenarioInputs Parser EntityMap)
-> ThrowC LoadingFailure Identity EntityMap
-> With ScenarioInputs Parser EntityMap
forall a b. (a -> b) -> a -> b
$ [Entity] -> ThrowC LoadingFailure Identity EntityMap
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw LoadingFailure) sig m =>
[Entity] -> m EntityMap
buildEntityMap [Entity]
emRaw
    let tm :: TerrainMap
tm = [TerrainObj] -> TerrainMap
mkTerrainMap [TerrainObj]
validatedTerrainObjects
    let scenarioSpecificTerrainEntities :: TerrainEntityMaps
scenarioSpecificTerrainEntities = TerrainMap -> EntityMap -> TerrainEntityMaps
TerrainEntityMaps TerrainMap
tm EntityMap
em

    -- Save the passed in WorldMap for later
    WorldMap
worldMap <- ScenarioInputs -> WorldMap
initWorldMap (ScenarioInputs -> WorldMap)
-> With ScenarioInputs Parser ScenarioInputs
-> With ScenarioInputs Parser WorldMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> With ScenarioInputs Parser ScenarioInputs
forall (f :: * -> *) e. Monad f => With e f e
getE

    -- Get rid of WorldMap from context locally, and combine
    -- the default system TerrainMap and EntityMap
    -- with any custom terrain/entities parsed above
    (ScenarioInputs -> TerrainEntityMaps)
-> With TerrainEntityMaps Parser Scenario
-> ParserE ScenarioInputs Scenario
forall e' e (f :: * -> *) a. (e' -> e) -> With e f a -> With e' f a
localE ScenarioInputs -> TerrainEntityMaps
initEntityTerrain (With TerrainEntityMaps Parser Scenario
 -> ParserE ScenarioInputs Scenario)
-> With TerrainEntityMaps Parser Scenario
-> ParserE ScenarioInputs Scenario
forall a b. (a -> b) -> a -> b
$ TerrainEntityMaps
-> With TerrainEntityMaps Parser Scenario
-> With TerrainEntityMaps Parser Scenario
forall e (f :: * -> *) a.
Semigroup e =>
e -> With e f a -> With e f a
withE TerrainEntityMaps
scenarioSpecificTerrainEntities (With TerrainEntityMaps Parser Scenario
 -> With TerrainEntityMaps Parser Scenario)
-> With TerrainEntityMaps Parser Scenario
-> With TerrainEntityMaps Parser Scenario
forall a b. (a -> b) -> a -> b
$ do
      -- parse 'known' entity names and make sure they exist
      [Text]
known <- Parser [Text] -> With TerrainEntityMaps Parser [Text]
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v Object -> Key -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"known" Parser (Maybe [Text]) -> [Text] -> Parser [Text]
forall a. Parser (Maybe a) -> a -> Parser a
.!= [Text]
forall a. Monoid a => a
mempty)
      TerrainEntityMaps
combinedTEM <- With TerrainEntityMaps Parser TerrainEntityMaps
forall (f :: * -> *) e. Monad f => With e f e
getE

      let TerrainEntityMaps TerrainMap
_tm EntityMap
emCombined = TerrainEntityMaps
combinedTEM
      Maybe (NonEmpty Text)
-> (NonEmpty Text -> With TerrainEntityMaps Parser Any)
-> With TerrainEntityMaps Parser ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([Text] -> Maybe (NonEmpty Text))
-> [Text] -> Maybe (NonEmpty Text)
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Entity -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Entity -> Bool) -> (Text -> Maybe Entity) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> EntityMap -> Maybe Entity
`lookupEntityName` EntityMap
emCombined)) [Text]
known) ((NonEmpty Text -> With TerrainEntityMaps Parser Any)
 -> With TerrainEntityMaps Parser ())
-> (NonEmpty Text -> With TerrainEntityMaps Parser Any)
-> With TerrainEntityMaps Parser ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty Text
unk ->
        [Text] -> With TerrainEntityMaps Parser Any
forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT [Text
"Unknown entities in 'known' list:", Text -> [Text] -> Text
T.intercalate Text
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Text
unk]

      -- parse robots and build RobotMap
      [TRobot]
rs <- Object
v Object -> Text -> ParserE TerrainEntityMaps [TRobot]
forall e a. FromJSONE e a => Object -> Text -> ParserE e a
..: Text
"robots"
      let rsMap :: RobotMap
rsMap = [TRobot] -> RobotMap
buildRobotMap [TRobot]
rs

      -- NOTE: These have not been merged with their children yet.
      [NamedStructure (Maybe Cell)]
rootLevelSharedStructures :: InheritedStructureDefs <-
        (TerrainEntityMaps -> (TerrainEntityMaps, RobotMap))
-> With
     (TerrainEntityMaps, RobotMap) Parser [NamedStructure (Maybe Cell)]
-> With TerrainEntityMaps Parser [NamedStructure (Maybe Cell)]
forall e' e (f :: * -> *) a. (e' -> e) -> With e f a -> With e' f a
localE (,RobotMap
rsMap) (With
   (TerrainEntityMaps, RobotMap) Parser [NamedStructure (Maybe Cell)]
 -> With TerrainEntityMaps Parser [NamedStructure (Maybe Cell)])
-> With
     (TerrainEntityMaps, RobotMap) Parser [NamedStructure (Maybe Cell)]
-> With TerrainEntityMaps Parser [NamedStructure (Maybe Cell)]
forall a b. (a -> b) -> a -> b
$
          Object
v Object
-> Text
-> ParserE
     (TerrainEntityMaps, RobotMap) (Maybe [NamedStructure (Maybe Cell)])
forall e a. FromJSONE e a => Object -> Text -> ParserE e (Maybe a)
..:? Text
"structures" ParserE
  (TerrainEntityMaps, RobotMap) (Maybe [NamedStructure (Maybe Cell)])
-> [NamedStructure (Maybe Cell)]
-> With
     (TerrainEntityMaps, RobotMap) Parser [NamedStructure (Maybe Cell)]
forall (f :: * -> *) a. Functor f => f (Maybe a) -> a -> f a
..!= []

      -- TODO (#1611) This is inefficient; instead, we should
      -- form a DAG of structure references and visit deepest first,
      -- caching in a map as we go.
      -- Then, if a given sub-structure is referenced more than once, we don't
      -- have to re-assemble it.
      --
      -- We should also make use of such a pre-computed map in the
      -- invocation of 'mergeStructures' inside WorldDescription.hs.
      let structureMap :: Map StructureName (NamedStructure (Maybe Cell))
structureMap = [NamedStructure (Maybe Cell)]
-> Map StructureName (NamedStructure (Maybe Cell))
forall a.
[NamedStructure a] -> Map StructureName (NamedStructure a)
Assembly.makeStructureMap [NamedStructure (Maybe Cell)]
rootLevelSharedStructures
      [(NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))]
mergedStructures <-
        (Text
 -> With
      TerrainEntityMaps
      Parser
      [(NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))])
-> ([(NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))]
    -> With
         TerrainEntityMaps
         Parser
         [(NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))])
-> Either
     Text [(NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))]
-> With
     TerrainEntityMaps
     Parser
     [(NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String
-> With
     TerrainEntityMaps
     Parser
     [(NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))]
forall a. String -> With TerrainEntityMaps Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
 -> With
      TerrainEntityMaps
      Parser
      [(NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))])
-> (Text -> String)
-> Text
-> With
     TerrainEntityMaps
     Parser
     [(NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) [(NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))]
-> With
     TerrainEntityMaps
     Parser
     [(NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))]
forall a. a -> With TerrainEntityMaps Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   Text [(NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))]
 -> With
      TerrainEntityMaps
      Parser
      [(NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))])
-> Either
     Text [(NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))]
-> With
     TerrainEntityMaps
     Parser
     [(NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))]
forall a b. (a -> b) -> a -> b
$
          (NamedStructure (Maybe Cell)
 -> Either
      Text (NamedStructure (Maybe Cell), MergedStructure (Maybe Cell)))
-> [NamedStructure (Maybe Cell)]
-> Either
     Text [(NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
            ((NamedStructure (Maybe Cell),
 Either Text (MergedStructure (Maybe Cell)))
-> Either
     Text (NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
(NamedStructure (Maybe Cell), f a)
-> f (NamedStructure (Maybe Cell), a)
sequenceA ((NamedStructure (Maybe Cell),
  Either Text (MergedStructure (Maybe Cell)))
 -> Either
      Text (NamedStructure (Maybe Cell), MergedStructure (Maybe Cell)))
-> (NamedStructure (Maybe Cell)
    -> (NamedStructure (Maybe Cell),
        Either Text (MergedStructure (Maybe Cell))))
-> NamedStructure (Maybe Cell)
-> Either
     Text (NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedStructure (Maybe Cell) -> NamedStructure (Maybe Cell)
forall a. a -> a
id (NamedStructure (Maybe Cell) -> NamedStructure (Maybe Cell))
-> (NamedStructure (Maybe Cell)
    -> Either Text (MergedStructure (Maybe Cell)))
-> NamedStructure (Maybe Cell)
-> (NamedStructure (Maybe Cell),
    Either Text (MergedStructure (Maybe Cell)))
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Map StructureName (NamedStructure (Maybe Cell))
-> Parentage Placement
-> PStructure (Maybe Cell)
-> Either Text (MergedStructure (Maybe Cell))
forall a.
Map StructureName (NamedStructure (Maybe a))
-> Parentage Placement
-> PStructure (Maybe a)
-> Either Text (MergedStructure (Maybe a))
Assembly.mergeStructures Map StructureName (NamedStructure (Maybe Cell))
structureMap Parentage Placement
forall a. Parentage a
Root (PStructure (Maybe Cell)
 -> Either Text (MergedStructure (Maybe Cell)))
-> (NamedStructure (Maybe Cell) -> PStructure (Maybe Cell))
-> NamedStructure (Maybe Cell)
-> Either Text (MergedStructure (Maybe Cell))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedStructure (Maybe Cell) -> PStructure (Maybe Cell)
forall a. NamedArea a -> a
Structure.structure)))
            [NamedStructure (Maybe Cell)]
rootLevelSharedStructures

      NonEmpty WorldDescription
allWorlds <- (TerrainEntityMaps -> WorldParseDependencies)
-> With WorldParseDependencies Parser (NonEmpty WorldDescription)
-> With TerrainEntityMaps Parser (NonEmpty WorldDescription)
forall e' e (f :: * -> *) a. (e' -> e) -> With e f a -> With e' f a
localE (WorldMap
-> [NamedStructure (Maybe Cell)]
-> RobotMap
-> TerrainEntityMaps
-> WorldParseDependencies
WorldParseDependencies WorldMap
worldMap [NamedStructure (Maybe Cell)]
rootLevelSharedStructures RobotMap
rsMap) (With WorldParseDependencies Parser (NonEmpty WorldDescription)
 -> With TerrainEntityMaps Parser (NonEmpty WorldDescription))
-> With WorldParseDependencies Parser (NonEmpty WorldDescription)
-> With TerrainEntityMaps Parser (NonEmpty WorldDescription)
forall a b. (a -> b) -> a -> b
$ do
        WorldDescription
rootWorld <- Object
v Object -> Text -> ParserE WorldParseDependencies WorldDescription
forall e a. FromJSONE e a => Object -> Text -> ParserE e a
..: Text
"world"
        [WorldDescription]
subworlds <- Object
v Object
-> Text
-> ParserE WorldParseDependencies (Maybe [WorldDescription])
forall e a. FromJSONE e a => Object -> Text -> ParserE e (Maybe a)
..:? Text
"subworlds" ParserE WorldParseDependencies (Maybe [WorldDescription])
-> [WorldDescription]
-> With WorldParseDependencies Parser [WorldDescription]
forall (f :: * -> *) a. Functor f => f (Maybe a) -> a -> f a
..!= []
        NonEmpty WorldDescription
-> With WorldParseDependencies Parser (NonEmpty WorldDescription)
forall a. a -> With WorldParseDependencies Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty WorldDescription
 -> With WorldParseDependencies Parser (NonEmpty WorldDescription))
-> NonEmpty WorldDescription
-> With WorldParseDependencies Parser (NonEmpty WorldDescription)
forall a b. (a -> b) -> a -> b
$ WorldDescription
rootWorld WorldDescription -> [WorldDescription] -> NonEmpty WorldDescription
forall a. a -> [a] -> NonEmpty a
:| [WorldDescription]
subworlds

      let worldsByName :: Map SubworldName (NonEmpty WorldDescription)
worldsByName = [(SubworldName, WorldDescription)]
-> Map SubworldName (NonEmpty WorldDescription)
forall (t :: * -> *) a b.
(Foldable t, Ord a) =>
t (a, b) -> Map a (NonEmpty b)
binTuples ([(SubworldName, WorldDescription)]
 -> Map SubworldName (NonEmpty WorldDescription))
-> [(SubworldName, WorldDescription)]
-> Map SubworldName (NonEmpty WorldDescription)
forall a b. (a -> b) -> a -> b
$ NonEmpty (SubworldName, WorldDescription)
-> [(SubworldName, WorldDescription)]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (SubworldName, WorldDescription)
 -> [(SubworldName, WorldDescription)])
-> NonEmpty (SubworldName, WorldDescription)
-> [(SubworldName, WorldDescription)]
forall a b. (a -> b) -> a -> b
$ (WorldDescription -> (SubworldName, WorldDescription))
-> NonEmpty WorldDescription
-> NonEmpty (SubworldName, WorldDescription)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (WorldDescription -> SubworldName
forall e. PWorldDescription e -> SubworldName
worldName (WorldDescription -> SubworldName)
-> (WorldDescription -> WorldDescription)
-> WorldDescription
-> (SubworldName, WorldDescription)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& WorldDescription -> WorldDescription
forall a. a -> a
id) NonEmpty WorldDescription
allWorlds
          dupedNames :: [SubworldName]
dupedNames = Map SubworldName (NonEmpty WorldDescription) -> [SubworldName]
forall k a. Map k a -> [k]
M.keys (Map SubworldName (NonEmpty WorldDescription) -> [SubworldName])
-> Map SubworldName (NonEmpty WorldDescription) -> [SubworldName]
forall a b. (a -> b) -> a -> b
$ (NonEmpty WorldDescription -> Bool)
-> Map SubworldName (NonEmpty WorldDescription)
-> Map SubworldName (NonEmpty WorldDescription)
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter ((Seed -> Seed -> Bool
forall a. Ord a => a -> a -> Bool
> Seed
1) (Seed -> Bool)
-> (NonEmpty WorldDescription -> Seed)
-> NonEmpty WorldDescription
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty WorldDescription -> Seed
forall a. NonEmpty a -> Seed
forall (t :: * -> *) a. Foldable t => t a -> Seed
length) Map SubworldName (NonEmpty WorldDescription)
worldsByName
      Bool
-> With TerrainEntityMaps Parser ()
-> With TerrainEntityMaps Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([SubworldName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SubworldName]
dupedNames) (With TerrainEntityMaps Parser ()
 -> With TerrainEntityMaps Parser ())
-> With TerrainEntityMaps Parser ()
-> With TerrainEntityMaps Parser ()
forall a b. (a -> b) -> a -> b
$
        [Text] -> With TerrainEntityMaps Parser ()
forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT
          [ Text
"Subworld names are not unique:"
          , Text -> [Text] -> Text
T.intercalate Text
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (SubworldName -> Text) -> [SubworldName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map SubworldName -> Text
renderWorldName [SubworldName]
dupedNames
          ]

      -- Validate robot locations
      [TRobot]
-> (TRobot -> With TerrainEntityMaps Parser ())
-> With TerrainEntityMaps Parser ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TRobot]
rs ((TRobot -> With TerrainEntityMaps Parser ())
 -> With TerrainEntityMaps Parser ())
-> (TRobot -> With TerrainEntityMaps Parser ())
-> With TerrainEntityMaps Parser ()
forall a b. (a -> b) -> a -> b
$ \TRobot
r -> Maybe (Cosmic Location)
-> (Cosmic Location -> With TerrainEntityMaps Parser ())
-> With TerrainEntityMaps Parser ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (TRobot
r TRobot
-> Getting
     (Maybe (Cosmic Location)) TRobot (Maybe (Cosmic Location))
-> Maybe (Cosmic Location)
forall s a. s -> Getting a s a -> a
^. Getting (Maybe (Cosmic Location)) TRobot (Maybe (Cosmic Location))
Lens' TRobot (Maybe (Cosmic Location))
trobotLocation) ((Cosmic Location -> With TerrainEntityMaps Parser ())
 -> With TerrainEntityMaps Parser ())
-> (Cosmic Location -> With TerrainEntityMaps Parser ())
-> With TerrainEntityMaps Parser ()
forall a b. (a -> b) -> a -> b
$ \Cosmic Location
rLoc ->
        Bool
-> With TerrainEntityMaps Parser ()
-> With TerrainEntityMaps Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Cosmic Location
rLoc Cosmic Location
-> Getting SubworldName (Cosmic Location) SubworldName
-> SubworldName
forall s a. s -> Getting a s a -> a
^. Getting SubworldName (Cosmic Location) SubworldName
forall a (f :: * -> *).
Functor f =>
(SubworldName -> f SubworldName) -> Cosmic a -> f (Cosmic a)
subworld) SubworldName
-> Map SubworldName (NonEmpty WorldDescription) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map SubworldName (NonEmpty WorldDescription)
worldsByName)
          (With TerrainEntityMaps Parser ()
 -> With TerrainEntityMaps Parser ())
-> ([Text] -> With TerrainEntityMaps Parser ())
-> [Text]
-> With TerrainEntityMaps Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> With TerrainEntityMaps Parser ()
forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT
          ([Text] -> With TerrainEntityMaps Parser ())
-> [Text] -> With TerrainEntityMaps Parser ()
forall a b. (a -> b) -> a -> b
$ [ Text
"Robot"
            , Text -> Text
quote (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ TRobot
r TRobot -> Getting Text TRobot Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text TRobot Text
Lens' TRobot Text
trobotName
            , Text
"specifies location in nonexistent subworld"
            , SubworldName -> Text
renderQuotedWorldName (Cosmic Location
rLoc Cosmic Location
-> Getting SubworldName (Cosmic Location) SubworldName
-> SubworldName
forall s a. s -> Getting a s a -> a
^. Getting SubworldName (Cosmic Location) SubworldName
forall a (f :: * -> *).
Functor f =>
(SubworldName -> f SubworldName) -> Cosmic a -> f (Cosmic a)
subworld) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
            , Text
"Valid subworlds are:"
            , [Text] -> Text
commaList ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (SubworldName -> Text) -> [SubworldName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map SubworldName -> Text
renderQuotedWorldName ([SubworldName] -> [Text]) -> [SubworldName] -> [Text]
forall a b. (a -> b) -> a -> b
$ Map SubworldName (NonEmpty WorldDescription) -> [SubworldName]
forall k a. Map k a -> [k]
M.keys Map SubworldName (NonEmpty WorldDescription)
worldsByName
            ]

      let mergedWaypoints :: Map SubworldName WaypointMap
mergedWaypoints =
            [(SubworldName, WaypointMap)] -> Map SubworldName WaypointMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(SubworldName, WaypointMap)] -> Map SubworldName WaypointMap)
-> [(SubworldName, WaypointMap)] -> Map SubworldName WaypointMap
forall a b. (a -> b) -> a -> b
$
              (WorldDescription -> (SubworldName, WaypointMap))
-> [WorldDescription] -> [(SubworldName, WaypointMap)]
forall a b. (a -> b) -> [a] -> [b]
map (WorldDescription -> SubworldName
forall e. PWorldDescription e -> SubworldName
worldName (WorldDescription -> SubworldName)
-> (WorldDescription -> WaypointMap)
-> WorldDescription
-> (SubworldName, WaypointMap)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Identity WaypointMap -> WaypointMap
forall a. Identity a -> a
runIdentity (Identity WaypointMap -> WaypointMap)
-> (WorldDescription -> Identity WaypointMap)
-> WorldDescription
-> WaypointMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Navigation Identity WaypointName -> Identity WaypointMap
forall (additionalDimension :: * -> *) portalExitLoc.
Navigation additionalDimension portalExitLoc
-> additionalDimension WaypointMap
waypoints (Navigation Identity WaypointName -> Identity WaypointMap)
-> (WorldDescription -> Navigation Identity WaypointName)
-> WorldDescription
-> Identity WaypointMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorldDescription -> Navigation Identity WaypointName
forall e. PWorldDescription e -> Navigation Identity WaypointName
navigation) ([WorldDescription] -> [(SubworldName, WaypointMap)])
-> [WorldDescription] -> [(SubworldName, WaypointMap)]
forall a b. (a -> b) -> a -> b
$
                NonEmpty WorldDescription -> [WorldDescription]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty WorldDescription
allWorlds

      Map (Cosmic Location) (AnnotatedDestination Location)
mergedPortals <-
        Navigation (Map SubworldName) WaypointName
-> With
     TerrainEntityMaps
     Parser
     (Map (Cosmic Location) (AnnotatedDestination Location))
forall (m :: * -> *).
MonadFail m =>
Navigation (Map SubworldName) WaypointName
-> m (Map (Cosmic Location) (AnnotatedDestination Location))
validatePortals
          (Navigation (Map SubworldName) WaypointName
 -> With
      TerrainEntityMaps
      Parser
      (Map (Cosmic Location) (AnnotatedDestination Location)))
-> ([WorldDescription]
    -> Navigation (Map SubworldName) WaypointName)
-> [WorldDescription]
-> With
     TerrainEntityMaps
     Parser
     (Map (Cosmic Location) (AnnotatedDestination Location))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map SubworldName WaypointMap
-> Map (Cosmic Location) (AnnotatedDestination WaypointName)
-> Navigation (Map SubworldName) WaypointName
forall (additionalDimension :: * -> *) portalExitLoc.
additionalDimension WaypointMap
-> Map (Cosmic Location) (AnnotatedDestination portalExitLoc)
-> Navigation additionalDimension portalExitLoc
Navigation Map SubworldName WaypointMap
mergedWaypoints
          (Map (Cosmic Location) (AnnotatedDestination WaypointName)
 -> Navigation (Map SubworldName) WaypointName)
-> ([WorldDescription]
    -> Map (Cosmic Location) (AnnotatedDestination WaypointName))
-> [WorldDescription]
-> Navigation (Map SubworldName) WaypointName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Map (Cosmic Location) (AnnotatedDestination WaypointName)]
-> Map (Cosmic Location) (AnnotatedDestination WaypointName)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions
          ([Map (Cosmic Location) (AnnotatedDestination WaypointName)]
 -> Map (Cosmic Location) (AnnotatedDestination WaypointName))
-> ([WorldDescription]
    -> [Map (Cosmic Location) (AnnotatedDestination WaypointName)])
-> [WorldDescription]
-> Map (Cosmic Location) (AnnotatedDestination WaypointName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WorldDescription
 -> Map (Cosmic Location) (AnnotatedDestination WaypointName))
-> [WorldDescription]
-> [Map (Cosmic Location) (AnnotatedDestination WaypointName)]
forall a b. (a -> b) -> [a] -> [b]
map (Navigation Identity WaypointName
-> Map (Cosmic Location) (AnnotatedDestination WaypointName)
forall (additionalDimension :: * -> *) portalExitLoc.
Navigation additionalDimension portalExitLoc
-> Map (Cosmic Location) (AnnotatedDestination portalExitLoc)
portals (Navigation Identity WaypointName
 -> Map (Cosmic Location) (AnnotatedDestination WaypointName))
-> (WorldDescription -> Navigation Identity WaypointName)
-> WorldDescription
-> Map (Cosmic Location) (AnnotatedDestination WaypointName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorldDescription -> Navigation Identity WaypointName
forall e. PWorldDescription e -> Navigation Identity WaypointName
navigation)
          ([WorldDescription]
 -> With
      TerrainEntityMaps
      Parser
      (Map (Cosmic Location) (AnnotatedDestination Location)))
-> [WorldDescription]
-> With
     TerrainEntityMaps
     Parser
     (Map (Cosmic Location) (AnnotatedDestination Location))
forall a b. (a -> b) -> a -> b
$ NonEmpty WorldDescription -> [WorldDescription]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty WorldDescription
allWorlds

      let mergedNavigation :: Navigation (Map SubworldName) Location
mergedNavigation = Map SubworldName WaypointMap
-> Map (Cosmic Location) (AnnotatedDestination Location)
-> Navigation (Map SubworldName) Location
forall (additionalDimension :: * -> *) portalExitLoc.
additionalDimension WaypointMap
-> Map (Cosmic Location) (AnnotatedDestination portalExitLoc)
-> Navigation additionalDimension portalExitLoc
Navigation Map SubworldName WaypointMap
mergedWaypoints Map (Cosmic Location) (AnnotatedDestination Location)
mergedPortals

          stuffGrid :: (f b, MergedStructure c) -> f (Grid c)
stuffGrid (f b
ns, Structure.MergedStructure (PositionedGrid Location
_ Grid c
s) [LocatedStructure]
_ [Originated Waypoint]
_) = Grid c
s Grid c -> f b -> f (Grid c)
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f b
ns
          namedGrids :: [NamedArea (Grid (Maybe Cell))]
namedGrids = ((NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))
 -> NamedArea (Grid (Maybe Cell)))
-> [(NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))]
-> [NamedArea (Grid (Maybe Cell))]
forall a b. (a -> b) -> [a] -> [b]
map (NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))
-> NamedArea (Grid (Maybe Cell))
forall {f :: * -> *} {b} {c}.
Functor f =>
(f b, MergedStructure c) -> f (Grid c)
stuffGrid [(NamedStructure (Maybe Cell), MergedStructure (Maybe Cell))]
mergedStructures
          recognizableGrids :: [NamedArea (Grid (Maybe Cell))]
recognizableGrids = (NamedArea (Grid (Maybe Cell)) -> Bool)
-> [NamedArea (Grid (Maybe Cell))]
-> [NamedArea (Grid (Maybe Cell))]
forall a. (a -> Bool) -> [a] -> [a]
filter NamedArea (Grid (Maybe Cell)) -> Bool
forall a. NamedArea a -> Bool
Structure.isRecognizable [NamedArea (Grid (Maybe Cell))]
namedGrids

          -- We exclude empty grids from the recognition engine.
          nonEmptyRecognizableGrids :: [NamedArea RecognizableStructureContent]
nonEmptyRecognizableGrids = (NamedArea (Grid (Maybe Cell))
 -> Maybe (NamedArea RecognizableStructureContent))
-> [NamedArea (Grid (Maybe Cell))]
-> [NamedArea RecognizableStructureContent]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Grid (Maybe Cell) -> Maybe RecognizableStructureContent)
-> NamedArea (Grid (Maybe Cell))
-> Maybe (NamedArea RecognizableStructureContent)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NamedArea a -> f (NamedArea b)
traverse Grid (Maybe Cell) -> Maybe RecognizableStructureContent
forall a. Grid a -> Maybe (NonEmptyGrid a)
getNonEmptyGrid) [NamedArea (Grid (Maybe Cell))]
recognizableGrids

      RecognizerAutomatons RecognizableStructureContent Entity
myAutomatons <-
        (RedundantOrientations
 -> With
      TerrainEntityMaps
      Parser
      (RecognizerAutomatons RecognizableStructureContent Entity))
-> (RecognizerAutomatons RecognizableStructureContent Entity
    -> With
         TerrainEntityMaps
         Parser
         (RecognizerAutomatons RecognizableStructureContent Entity))
-> Either
     RedundantOrientations
     (RecognizerAutomatons RecognizableStructureContent Entity)
-> With
     TerrainEntityMaps
     Parser
     (RecognizerAutomatons RecognizableStructureContent Entity)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String
-> With
     TerrainEntityMaps
     Parser
     (RecognizerAutomatons RecognizableStructureContent Entity)
forall a. String -> With TerrainEntityMaps Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
 -> With
      TerrainEntityMaps
      Parser
      (RecognizerAutomatons RecognizableStructureContent Entity))
-> (RedundantOrientations -> String)
-> RedundantOrientations
-> With
     TerrainEntityMaps
     Parser
     (RecognizerAutomatons RecognizableStructureContent Entity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String)
-> (RedundantOrientations -> Text)
-> RedundantOrientations
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RedundantOrientations -> Text
renderRedundancy) RecognizerAutomatons RecognizableStructureContent Entity
-> With
     TerrainEntityMaps
     Parser
     (RecognizerAutomatons RecognizableStructureContent Entity)
forall a. a -> With TerrainEntityMaps Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   RedundantOrientations
   (RecognizerAutomatons RecognizableStructureContent Entity)
 -> With
      TerrainEntityMaps
      Parser
      (RecognizerAutomatons RecognizableStructureContent Entity))
-> Either
     RedundantOrientations
     (RecognizerAutomatons RecognizableStructureContent Entity)
-> With
     TerrainEntityMaps
     Parser
     (RecognizerAutomatons RecognizableStructureContent Entity)
forall a b. (a -> b) -> a -> b
$
          (RecognizableStructureContent -> NonEmptyGrid (Maybe Entity))
-> [NamedArea RecognizableStructureContent]
-> Either
     RedundantOrientations
     (RecognizerAutomatons RecognizableStructureContent Entity)
forall a b.
(Ord a, Hashable a) =>
(b -> NonEmptyGrid (AtomicKeySymbol a))
-> [NamedArea b]
-> Either RedundantOrientations (RecognizerAutomatons b a)
mkAutomatons ((Maybe Cell -> Maybe Entity)
-> RecognizableStructureContent -> NonEmptyGrid (Maybe Entity)
forall a b. (a -> b) -> NonEmptyGrid a -> NonEmptyGrid b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Cell -> Maybe Entity
cellToEntity) [NamedArea RecognizableStructureContent]
nonEmptyRecognizableGrids

      let structureInfo :: StaticStructureInfo RecognizableStructureContent Entity
structureInfo =
            RecognizerAutomatons RecognizableStructureContent Entity
-> Map SubworldName [LocatedStructure]
-> StaticStructureInfo RecognizableStructureContent Entity
forall b a.
RecognizerAutomatons b a
-> Map SubworldName [LocatedStructure] -> StaticStructureInfo b a
StaticStructureInfo RecognizerAutomatons RecognizableStructureContent Entity
myAutomatons
              (Map SubworldName [LocatedStructure]
 -> StaticStructureInfo RecognizableStructureContent Entity)
-> (NonEmpty (SubworldName, [LocatedStructure])
    -> Map SubworldName [LocatedStructure])
-> NonEmpty (SubworldName, [LocatedStructure])
-> StaticStructureInfo RecognizableStructureContent Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SubworldName, [LocatedStructure])]
-> Map SubworldName [LocatedStructure]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
              ([(SubworldName, [LocatedStructure])]
 -> Map SubworldName [LocatedStructure])
-> (NonEmpty (SubworldName, [LocatedStructure])
    -> [(SubworldName, [LocatedStructure])])
-> NonEmpty (SubworldName, [LocatedStructure])
-> Map SubworldName [LocatedStructure]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (SubworldName, [LocatedStructure])
-> [(SubworldName, [LocatedStructure])]
forall a. NonEmpty a -> [a]
NE.toList
              (NonEmpty (SubworldName, [LocatedStructure])
 -> StaticStructureInfo RecognizableStructureContent Entity)
-> NonEmpty (SubworldName, [LocatedStructure])
-> StaticStructureInfo RecognizableStructureContent Entity
forall a b. (a -> b) -> a -> b
$ (WorldDescription -> (SubworldName, [LocatedStructure]))
-> NonEmpty WorldDescription
-> NonEmpty (SubworldName, [LocatedStructure])
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (WorldDescription -> SubworldName
forall e. PWorldDescription e -> SubworldName
worldName (WorldDescription -> SubworldName)
-> (WorldDescription -> [LocatedStructure])
-> WorldDescription
-> (SubworldName, [LocatedStructure])
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& WorldDescription -> [LocatedStructure]
forall e. PWorldDescription e -> [LocatedStructure]
placedStructures) NonEmpty WorldDescription
allWorlds

      Maybe Seed
seed <- Parser (Maybe Seed) -> With TerrainEntityMaps Parser (Maybe Seed)
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v Object -> Key -> Parser (Maybe Seed)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"seed")
      let landscape :: ScenarioLandscape
landscape =
            Maybe Seed
-> [CustomAttr]
-> TerrainEntityMaps
-> Map WorldAttr PreservableColor
-> Set Text
-> NonEmpty WorldDescription
-> Navigation (Map SubworldName) Location
-> StaticStructureInfo RecognizableStructureContent Entity
-> [TRobot]
-> ScenarioLandscape
ScenarioLandscape
              Maybe Seed
seed
              [CustomAttr]
parsedAttrs
              TerrainEntityMaps
combinedTEM
              Map WorldAttr PreservableColor
mergedCosmetics
              ([Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [Text]
known)
              NonEmpty WorldDescription
allWorlds
              Navigation (Map SubworldName) Location
mergedNavigation
              StaticStructureInfo RecognizableStructureContent Entity
structureInfo
              [TRobot]
rs

      ScenarioMetadata
metadata <-
        Seed -> Text -> Maybe Text -> ScenarioMetadata
ScenarioMetadata
          (Seed -> Text -> Maybe Text -> ScenarioMetadata)
-> With TerrainEntityMaps Parser Seed
-> With
     TerrainEntityMaps Parser (Text -> Maybe Text -> ScenarioMetadata)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Seed -> With TerrainEntityMaps Parser Seed
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v Object -> Key -> Parser Seed
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"version")
          With
  TerrainEntityMaps Parser (Text -> Maybe Text -> ScenarioMetadata)
-> With TerrainEntityMaps Parser Text
-> With TerrainEntityMaps Parser (Maybe Text -> ScenarioMetadata)
forall a b.
With TerrainEntityMaps Parser (a -> b)
-> With TerrainEntityMaps Parser a
-> With TerrainEntityMaps Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text -> With TerrainEntityMaps Parser Text
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name")
          With TerrainEntityMaps Parser (Maybe Text -> ScenarioMetadata)
-> With TerrainEntityMaps Parser (Maybe Text)
-> With TerrainEntityMaps Parser ScenarioMetadata
forall a b.
With TerrainEntityMaps Parser (a -> b)
-> With TerrainEntityMaps Parser a
-> With TerrainEntityMaps Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Text) -> With TerrainEntityMaps Parser (Maybe Text)
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"author")

      ScenarioOperation
playInfo <-
        Bool
-> Document Syntax
-> [Objective]
-> Maybe TSyntax
-> [Recipe Entity]
-> Maybe Seed
-> ScenarioOperation
ScenarioOperation
          (Bool
 -> Document Syntax
 -> [Objective]
 -> Maybe TSyntax
 -> [Recipe Entity]
 -> Maybe Seed
 -> ScenarioOperation)
-> With TerrainEntityMaps Parser Bool
-> With
     TerrainEntityMaps
     Parser
     (Document Syntax
      -> [Objective]
      -> Maybe TSyntax
      -> [Recipe Entity]
      -> Maybe Seed
      -> ScenarioOperation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Bool -> With TerrainEntityMaps Parser Bool
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v Object -> Key -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"creative" Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False)
          With
  TerrainEntityMaps
  Parser
  (Document Syntax
   -> [Objective]
   -> Maybe TSyntax
   -> [Recipe Entity]
   -> Maybe Seed
   -> ScenarioOperation)
-> With TerrainEntityMaps Parser (Document Syntax)
-> With
     TerrainEntityMaps
     Parser
     ([Objective]
      -> Maybe TSyntax
      -> [Recipe Entity]
      -> Maybe Seed
      -> ScenarioOperation)
forall a b.
With TerrainEntityMaps Parser (a -> b)
-> With TerrainEntityMaps Parser a
-> With TerrainEntityMaps Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Document Syntax)
-> With TerrainEntityMaps Parser (Document Syntax)
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v Object -> Key -> Parser (Maybe (Document Syntax))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"description" Parser (Maybe (Document Syntax))
-> Document Syntax -> Parser (Document Syntax)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Document Syntax
"")
          With
  TerrainEntityMaps
  Parser
  ([Objective]
   -> Maybe TSyntax
   -> [Recipe Entity]
   -> Maybe Seed
   -> ScenarioOperation)
-> With TerrainEntityMaps Parser [Objective]
-> With
     TerrainEntityMaps
     Parser
     (Maybe TSyntax
      -> [Recipe Entity] -> Maybe Seed -> ScenarioOperation)
forall a b.
With TerrainEntityMaps Parser (a -> b)
-> With TerrainEntityMaps Parser a
-> With TerrainEntityMaps Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser [Objective] -> With TerrainEntityMaps Parser [Objective]
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v Object -> Key -> Parser (Maybe [Objective])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"objectives" Parser (Maybe [Objective]) -> [Objective] -> Parser [Objective]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []) With TerrainEntityMaps Parser [Objective]
-> ([Objective] -> With TerrainEntityMaps Parser [Objective])
-> With TerrainEntityMaps Parser [Objective]
forall a b.
With TerrainEntityMaps Parser a
-> (a -> With TerrainEntityMaps Parser b)
-> With TerrainEntityMaps Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Objective] -> With TerrainEntityMaps Parser [Objective]
forall (m :: * -> *). MonadFail m => [Objective] -> m [Objective]
validateObjectives)
          With
  TerrainEntityMaps
  Parser
  (Maybe TSyntax
   -> [Recipe Entity] -> Maybe Seed -> ScenarioOperation)
-> With TerrainEntityMaps Parser (Maybe TSyntax)
-> With
     TerrainEntityMaps
     Parser
     ([Recipe Entity] -> Maybe Seed -> ScenarioOperation)
forall a b.
With TerrainEntityMaps Parser (a -> b)
-> With TerrainEntityMaps Parser a
-> With TerrainEntityMaps Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe TSyntax)
-> With TerrainEntityMaps Parser (Maybe TSyntax)
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v Object -> Key -> Parser (Maybe TSyntax)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"solution")
          With
  TerrainEntityMaps
  Parser
  ([Recipe Entity] -> Maybe Seed -> ScenarioOperation)
-> With TerrainEntityMaps Parser [Recipe Entity]
-> With TerrainEntityMaps Parser (Maybe Seed -> ScenarioOperation)
forall a b.
With TerrainEntityMaps Parser (a -> b)
-> With TerrainEntityMaps Parser a
-> With TerrainEntityMaps Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TerrainEntityMaps -> EntityMap)
-> With EntityMap Parser [Recipe Entity]
-> With TerrainEntityMaps Parser [Recipe Entity]
forall e' e (f :: * -> *) a. (e' -> e) -> With e f a -> With e' f a
localE (Getting EntityMap TerrainEntityMaps EntityMap
-> TerrainEntityMaps -> EntityMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting EntityMap TerrainEntityMaps EntityMap
Lens' TerrainEntityMaps EntityMap
entityMap) (Object
v Object -> Text -> ParserE EntityMap (Maybe [Recipe Entity])
forall e a. FromJSONE e a => Object -> Text -> ParserE e (Maybe a)
..:? Text
"recipes" ParserE EntityMap (Maybe [Recipe Entity])
-> [Recipe Entity] -> With EntityMap Parser [Recipe Entity]
forall (f :: * -> *) a. Functor f => f (Maybe a) -> a -> f a
..!= [])
          With TerrainEntityMaps Parser (Maybe Seed -> ScenarioOperation)
-> With TerrainEntityMaps Parser (Maybe Seed)
-> With TerrainEntityMaps Parser ScenarioOperation
forall a b.
With TerrainEntityMaps Parser (a -> b)
-> With TerrainEntityMaps Parser a
-> With TerrainEntityMaps Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Seed) -> With TerrainEntityMaps Parser (Maybe Seed)
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v Object -> Key -> Parser (Maybe Seed)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"stepsPerTick")

      Scenario -> With TerrainEntityMaps Parser Scenario
forall a. a -> With TerrainEntityMaps Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Scenario -> With TerrainEntityMaps Parser Scenario)
-> Scenario -> With TerrainEntityMaps Parser Scenario
forall a b. (a -> b) -> a -> b
$ ScenarioMetadata
-> ScenarioOperation -> ScenarioLandscape -> Scenario
Scenario ScenarioMetadata
metadata ScenarioOperation
playInfo ScenarioLandscape
landscape
   where
    runValidation :: ThrowC LoadingFailure Identity a -> m a
runValidation ThrowC LoadingFailure Identity a
f = case Identity (Either LoadingFailure a) -> Either LoadingFailure a
forall a. Identity a -> a
run (Identity (Either LoadingFailure a) -> Either LoadingFailure a)
-> (ThrowC LoadingFailure Identity a
    -> Identity (Either LoadingFailure a))
-> ThrowC LoadingFailure Identity a
-> Either LoadingFailure a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThrowC LoadingFailure Identity a
-> Identity (Either LoadingFailure a)
forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow (ThrowC LoadingFailure Identity a -> Either LoadingFailure a)
-> ThrowC LoadingFailure Identity a -> Either LoadingFailure a
forall a b. (a -> b) -> a -> b
$ ThrowC LoadingFailure Identity a
f of
      Right a
x -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
      Left LoadingFailure
x -> [Text] -> m a
forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT [forall a. PrettyPrec a => a -> Text
prettyText @LoadingFailure LoadingFailure
x]

-- * Loading scenarios

getScenarioPath ::
  (Has (Lift IO) sig m) =>
  FilePath ->
  m (Maybe FilePath)
getScenarioPath :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Lift IO) sig m =>
String -> m (Maybe String)
getScenarioPath String
scenario = do
  Maybe String
libScenario <- forall e (m :: * -> *) a. Functor m => ThrowC e m a -> m (Maybe a)
throwToMaybe @SystemFailure (ThrowC SystemFailure m String -> m (Maybe String))
-> ThrowC SystemFailure m String -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ AssetData -> String -> ThrowC SystemFailure m String
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AssetData -> String -> m String
getDataFileNameSafe AssetData
Scenarios (String -> ThrowC SystemFailure m String)
-> String -> ThrowC SystemFailure m String
forall a b. (a -> b) -> a -> b
$ String
"scenarios" String -> ShowS
</> String
scenario
  Maybe String
libScenarioExt <- forall e (m :: * -> *) a. Functor m => ThrowC e m a -> m (Maybe a)
throwToMaybe @SystemFailure (ThrowC SystemFailure m String -> m (Maybe String))
-> ThrowC SystemFailure m String -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ AssetData -> String -> ThrowC SystemFailure m String
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AssetData -> String -> m String
getDataFileNameSafe AssetData
Scenarios (String -> ThrowC SystemFailure m String)
-> String -> ThrowC SystemFailure m String
forall a b. (a -> b) -> a -> b
$ String
"scenarios" String -> ShowS
</> String
scenario String -> ShowS
<.> String
"yaml"
  let candidates :: [String]
candidates = [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [String -> Maybe String
forall a. a -> Maybe a
Just String
scenario, Maybe String
libScenarioExt, Maybe String
libScenario]
  [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> Maybe String) -> m [String] -> m (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String] -> m [String]
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO ((String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [String]
candidates)

-- | Load a scenario with a given name from disk, given an entity map
--   to use.  This function is used if a specific scenario is
--   requested on the command line.
loadScenario ::
  (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
  FilePath ->
  ScenarioInputs ->
  m (Scenario, FilePath)
loadScenario :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
String -> ScenarioInputs -> m (Scenario, String)
loadScenario String
scenario ScenarioInputs
scenarioInputs = do
  Maybe String
mfileName <- String -> m (Maybe String)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Lift IO) sig m =>
String -> m (Maybe String)
getScenarioPath String
scenario
  String
fileName <- m String -> (String -> m String) -> Maybe String -> m String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SystemFailure -> m String
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError (SystemFailure -> m String) -> SystemFailure -> m String
forall a b. (a -> b) -> a -> b
$ String -> SystemFailure
ScenarioNotFound String
scenario) String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
mfileName
  (,String
fileName) (Scenario -> (Scenario, String))
-> m Scenario -> m (Scenario, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScenarioInputs -> String -> m Scenario
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
ScenarioInputs -> String -> m Scenario
loadScenarioFile ScenarioInputs
scenarioInputs String
fileName

-- | Load a scenario from a file.
loadScenarioFile ::
  (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
  ScenarioInputs ->
  FilePath ->
  m Scenario
loadScenarioFile :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
ScenarioInputs -> String -> m Scenario
loadScenarioFile ScenarioInputs
scenarioInputs String
fileName =
  ((ParseException -> SystemFailure)
-> ThrowC ParseException m Scenario -> m Scenario
forall e2 (sig :: (* -> *) -> * -> *) (m :: * -> *) e1 a.
Has (Throw e2) sig m =>
(e1 -> e2) -> ThrowC e1 m a -> m a
withThrow ParseException -> SystemFailure
adaptError (ThrowC ParseException m Scenario -> m Scenario)
-> (IO (Either ParseException Scenario)
    -> ThrowC ParseException m Scenario)
-> IO (Either ParseException Scenario)
-> m Scenario
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either ParseException Scenario -> ThrowC ParseException m Scenario
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
Either e a -> m a
liftEither (Either ParseException Scenario
 -> ThrowC ParseException m Scenario)
-> (IO (Either ParseException Scenario)
    -> ThrowC ParseException m (Either ParseException Scenario))
-> IO (Either ParseException Scenario)
-> ThrowC ParseException m Scenario
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Either ParseException Scenario)
-> ThrowC ParseException m (Either ParseException Scenario)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO)) (IO (Either ParseException Scenario) -> m Scenario)
-> IO (Either ParseException Scenario) -> m Scenario
forall a b. (a -> b) -> a -> b
$
    ScenarioInputs -> String -> IO (Either ParseException Scenario)
forall e a.
FromJSONE e a =>
e -> String -> IO (Either ParseException a)
decodeFileEitherE ScenarioInputs
scenarioInputs String
fileName
 where
  adaptError :: ParseException -> SystemFailure
adaptError = Asset -> String -> LoadingFailure -> SystemFailure
AssetNotLoaded (AssetData -> Asset
Data AssetData
Scenarios) String
fileName (LoadingFailure -> SystemFailure)
-> (ParseException -> LoadingFailure)
-> ParseException
-> SystemFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseException -> LoadingFailure
CanNotParseYaml

-- | Load a single scenario from disk, first loading needed entity +
--   recipe data.  This function should only be called in the case of
--   "peripheral" tools that need to load a scenario (for example,
--   documentation generation, scenario world rendering, etc.), not as
--   part of the normal game code path.
loadStandaloneScenario ::
  (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
  FilePath ->
  m (Scenario, GameStateInputs)
loadStandaloneScenario :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
String -> m (Scenario, GameStateInputs)
loadStandaloneScenario String
fp = do
  TerrainEntityMaps
tem <- m TerrainEntityMaps
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
m TerrainEntityMaps
loadEntitiesAndTerrain
  WorldMap
worlds <- forall e (m :: * -> *) a.
(Monoid e, Functor m) =>
AccumC e m a -> m a
ignoreWarnings @(Seq SystemFailure) (AccumC (Seq SystemFailure) m WorldMap -> m WorldMap)
-> AccumC (Seq SystemFailure) m WorldMap -> m WorldMap
forall a b. (a -> b) -> a -> b
$ TerrainEntityMaps -> AccumC (Seq SystemFailure) m WorldMap
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
TerrainEntityMaps -> m WorldMap
loadWorlds TerrainEntityMaps
tem
  let scenarioInputs :: ScenarioInputs
scenarioInputs = WorldMap -> TerrainEntityMaps -> ScenarioInputs
ScenarioInputs WorldMap
worlds TerrainEntityMaps
tem
  [Recipe Entity]
recipes <- EntityMap -> m [Recipe Entity]
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
EntityMap -> m [Recipe Entity]
loadRecipes (EntityMap -> m [Recipe Entity]) -> EntityMap -> m [Recipe Entity]
forall a b. (a -> b) -> a -> b
$ TerrainEntityMaps
tem TerrainEntityMaps
-> Getting EntityMap TerrainEntityMaps EntityMap -> EntityMap
forall s a. s -> Getting a s a -> a
^. Getting EntityMap TerrainEntityMaps EntityMap
Lens' TerrainEntityMaps EntityMap
entityMap
  Scenario
scene <- (Scenario, String) -> Scenario
forall a b. (a, b) -> a
fst ((Scenario, String) -> Scenario)
-> m (Scenario, String) -> m Scenario
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ScenarioInputs -> m (Scenario, String)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
String -> ScenarioInputs -> m (Scenario, String)
loadScenario String
fp ScenarioInputs
scenarioInputs
  (Scenario, GameStateInputs) -> m (Scenario, GameStateInputs)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Scenario
scene, ScenarioInputs -> [Recipe Entity] -> GameStateInputs
GameStateInputs ScenarioInputs
scenarioInputs [Recipe Entity]
recipes)

data ScenarioInputs = ScenarioInputs
  { ScenarioInputs -> WorldMap
initWorldMap :: WorldMap
  -- ^ A collection of typechecked world DSL terms that are available to
  --   be used in scenario definitions.
  , ScenarioInputs -> TerrainEntityMaps
initEntityTerrain :: TerrainEntityMaps
  -- ^ The standard terrain/entity maps loaded from disk.  Individual scenarios
  --   may define additional terrain/entities which will get added to this map
  --   when loading the scenario.
  }

data GameStateInputs = GameStateInputs
  { GameStateInputs -> ScenarioInputs
gsiScenarioInputs :: ScenarioInputs
  , GameStateInputs -> [Recipe Entity]
gsiRecipes :: [Recipe Entity]
  -- ^ The standard list of recipes loaded from disk.  Individual scenarios
  --   may define additional recipes which will get added to this list
  --   when loading the scenario.
  }

-- |
-- Decide on a seed.  In order of preference, we will use:
--   1. seed value provided by the user
--   2. seed value specified in the scenario description
--   3. randomly chosen seed value
arbitrateSeed :: Maybe Seed -> ScenarioLandscape -> IO Seed
arbitrateSeed :: Maybe Seed -> ScenarioLandscape -> IO Seed
arbitrateSeed Maybe Seed
userSeed ScenarioLandscape
sLandscape =
  case Maybe Seed
userSeed Maybe Seed -> Maybe Seed -> Maybe Seed
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ScenarioLandscape
sLandscape ScenarioLandscape
-> Getting (Maybe Seed) ScenarioLandscape (Maybe Seed)
-> Maybe Seed
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Seed) ScenarioLandscape (Maybe Seed)
Lens' ScenarioLandscape (Maybe Seed)
scenarioSeed of
    Just Seed
s -> Seed -> IO Seed
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Seed
s
    Maybe Seed
Nothing -> (Seed, Seed) -> IO Seed
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Seed
0, Seed
forall a. Bounded a => a
maxBound :: Int)