{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Swarm.Game.Scenario (
PCell (..),
Cell,
PWorldDescription (..),
WorldDescription,
IndexedTRobot,
Scenario,
scenarioVersion,
scenarioName,
scenarioAuthor,
scenarioDescription,
scenarioCreative,
scenarioSeed,
scenarioAttrs,
scenarioEntities,
scenarioRecipes,
scenarioKnown,
scenarioWorld,
scenarioRobots,
scenarioObjectives,
scenarioSolution,
scenarioStepsPerTick,
loadScenario,
loadScenarioFile,
getScenarioPath,
) where
import Control.Algebra (Has)
import Control.Carrier.Lift (Lift, sendIO)
import Control.Carrier.Throw.Either (Throw, throwError)
import Control.Lens hiding (from, (<.>))
import Control.Monad (filterM)
import Data.Aeson
import Data.Maybe (catMaybes, isNothing, listToMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Yaml as Y
import Swarm.Game.Entity
import Swarm.Game.Recipe
import Swarm.Game.Robot (TRobot)
import Swarm.Game.Scenario.Cell
import Swarm.Game.Scenario.Objective
import Swarm.Game.Scenario.Objective.Validation
import Swarm.Game.Scenario.RobotLookup
import Swarm.Game.Scenario.Style
import Swarm.Game.Scenario.WorldDescription
import Swarm.Language.Pipeline (ProcessedTerm)
import Swarm.Util (getDataFileNameSafe)
import Swarm.Util.Yaml
import System.Directory (doesFileExist)
import System.FilePath ((<.>), (</>))
import Witch (from, into)
data Scenario = Scenario
{ Scenario -> Int
_scenarioVersion :: Int
, Scenario -> Text
_scenarioName :: Text
, Scenario -> Maybe Text
_scenarioAuthor :: Maybe Text
, Scenario -> Text
_scenarioDescription :: Text
, Scenario -> Bool
_scenarioCreative :: Bool
, Scenario -> Maybe Int
_scenarioSeed :: Maybe Int
, Scenario -> [CustomAttr]
_scenarioAttrs :: [CustomAttr]
, Scenario -> EntityMap
_scenarioEntities :: EntityMap
, Scenario -> [Recipe Entity]
_scenarioRecipes :: [Recipe Entity]
, Scenario -> [Text]
_scenarioKnown :: [Text]
, Scenario -> WorldDescription
_scenarioWorld :: WorldDescription
, Scenario -> [TRobot]
_scenarioRobots :: [TRobot]
, Scenario -> [Objective]
_scenarioObjectives :: [Objective]
, Scenario -> Maybe ProcessedTerm
_scenarioSolution :: Maybe ProcessedTerm
, Scenario -> Maybe Int
_scenarioStepsPerTick :: Maybe Int
}
deriving (Scenario -> Scenario -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Scenario -> Scenario -> Bool
$c/= :: Scenario -> Scenario -> Bool
== :: Scenario -> Scenario -> Bool
$c== :: Scenario -> Scenario -> Bool
Eq, Int -> Scenario -> ShowS
[Scenario] -> ShowS
Scenario -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Scenario] -> ShowS
$cshowList :: [Scenario] -> ShowS
show :: Scenario -> String
$cshow :: Scenario -> String
showsPrec :: Int -> Scenario -> ShowS
$cshowsPrec :: Int -> Scenario -> ShowS
Show)
makeLensesWith (lensRules & generateSignatures .~ False) ''Scenario
instance FromJSONE EntityMap Scenario where
parseJSONE :: Value -> ParserE EntityMap Scenario
parseJSONE = forall e a.
String -> (Object -> ParserE e a) -> Value -> ParserE e a
withObjectE String
"scenario" forall a b. (a -> b) -> a -> b
$ \Object
v -> do
EntityMap
em <- forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE ([Entity] -> EntityMap
buildEntityMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"entities" forall a. Parser (Maybe a) -> a -> Parser a
.!= []))
forall e (f :: * -> *) a.
Semigroup e =>
e -> With e f a -> With e f a
withE EntityMap
em forall a b. (a -> b) -> a -> b
$ do
[Text]
known <- 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
"known" forall a. Parser (Maybe a) -> a -> Parser a
.!= [])
EntityMap
em' <- forall (f :: * -> *) e. Monad f => With e f e
getE
case forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> EntityMap -> Maybe Entity
`lookupEntityName` EntityMap
em')) [Text]
known of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[Text]
unk ->
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall target source. From source target => source -> target
into @String forall a b. (a -> b) -> a -> b
$
Text
"Unknown entities in 'known' list: " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
unk
[TRobot]
rs <- Object
v forall e a. FromJSONE e a => Object -> Text -> ParserE e a
..: Text
"robots"
let rsMap :: RobotMap
rsMap = [TRobot] -> RobotMap
buildRobotMap [TRobot]
rs
Int
-> Text
-> Maybe Text
-> Text
-> Bool
-> Maybe Int
-> [CustomAttr]
-> EntityMap
-> [Recipe Entity]
-> [Text]
-> WorldDescription
-> [TRobot]
-> [Objective]
-> Maybe ProcessedTerm
-> Maybe Int
-> Scenario
Scenario
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 a
.: Key
"version")
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 a
.: Key
"name")
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
"author")
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
"description" forall a. Parser (Maybe a) -> a -> Parser a
.!= Text
"")
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
"creative" 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
"seed")
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
"attrs" forall a. Parser (Maybe a) -> a -> Parser a
.!= [])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure EntityMap
em
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall e a. FromJSONE e a => Object -> Text -> ParserE e (Maybe a)
..:? Text
"recipes" forall (f :: * -> *) a. Functor f => f (Maybe a) -> a -> f a
..!= []
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text]
known
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall e' e (f :: * -> *) a. (e' -> e) -> With e f a -> With e' f a
localE (,RobotMap
rsMap) (Object
v forall e a. FromJSONE e a => Object -> Text -> ParserE e a
..: Text
"world")
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure [TRobot]
rs
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
"objectives" forall a. Parser (Maybe a) -> a -> Parser a
.!= []) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadFail m => [Objective] -> m [Objective]
validateObjectives)
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
"solution")
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
"stepsPerTick")
scenarioVersion :: Lens' Scenario Int
scenarioName :: Lens' Scenario Text
scenarioAuthor :: Lens' Scenario (Maybe Text)
scenarioDescription :: Lens' Scenario Text
scenarioCreative :: Lens' Scenario Bool
scenarioSeed :: Lens' Scenario (Maybe Int)
scenarioAttrs :: Lens' Scenario [CustomAttr]
scenarioEntities :: Lens' Scenario EntityMap
scenarioRecipes :: Lens' Scenario [Recipe Entity]
scenarioKnown :: Lens' Scenario [Text]
scenarioWorld :: Lens' Scenario WorldDescription
scenarioRobots :: Lens' Scenario [TRobot]
scenarioObjectives :: Lens' Scenario [Objective]
scenarioSolution :: Lens' Scenario (Maybe ProcessedTerm)
scenarioStepsPerTick :: Lens' Scenario (Maybe Int)
getScenarioPath :: FilePath -> IO (Maybe FilePath)
getScenarioPath :: String -> IO (Maybe String)
getScenarioPath String
scenario = do
Maybe String
libScenario <- String -> IO (Maybe String)
getDataFileNameSafe forall a b. (a -> b) -> a -> b
$ String
"scenarios" String -> ShowS
</> String
scenario
Maybe String
libScenarioExt <- String -> IO (Maybe String)
getDataFileNameSafe forall a b. (a -> b) -> a -> b
$ String
"scenarios" String -> ShowS
</> String
scenario String -> ShowS
<.> String
"yaml"
let candidates :: [String]
candidates = forall a. [Maybe a] -> [a]
catMaybes [forall a. a -> Maybe a
Just String
scenario, Maybe String
libScenarioExt, Maybe String
libScenario]
forall a. [a] -> Maybe a
listToMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [String]
candidates
loadScenario ::
(Has (Lift IO) sig m, Has (Throw Text) sig m) =>
String ->
EntityMap ->
m (Scenario, FilePath)
loadScenario :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Text) sig m) =>
String -> EntityMap -> m (Scenario, String)
loadScenario String
scenario EntityMap
em = do
Maybe String
mfileName <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
getScenarioPath String
scenario
case Maybe String
mfileName of
Maybe String
Nothing -> forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError @Text forall a b. (a -> b) -> a -> b
$ Text
"Scenario not found: " forall a. Semigroup a => a -> a -> a
<> forall source target. From source target => source -> target
from @String String
scenario
Just String
fileName -> (,String
fileName) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Text) sig m) =>
EntityMap -> String -> m Scenario
loadScenarioFile EntityMap
em String
fileName
loadScenarioFile ::
(Has (Lift IO) sig m, Has (Throw Text) sig m) =>
EntityMap ->
FilePath ->
m Scenario
loadScenarioFile :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Text) sig m) =>
EntityMap -> String -> m Scenario
loadScenarioFile EntityMap
em String
fileName = do
Either ParseException Scenario
res <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO forall a b. (a -> b) -> a -> b
$ forall e a.
FromJSONE e a =>
e -> String -> IO (Either ParseException a)
decodeFileEitherE EntityMap
em String
fileName
case Either ParseException Scenario
res of
Left ParseException
parseExn -> forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError @Text (forall source target. From source target => source -> target
from @String (ParseException -> String
prettyPrintParseException ParseException
parseExn))
Right Scenario
c -> forall (m :: * -> *) a. Monad m => a -> m a
return Scenario
c