mirror of
https://github.com/swarm-game/swarm.git
synced 2024-10-26 17:38:34 +03:00
Refactor hierarchy of state inputs (#1799)
Towards #1797 Combines `TerrainEntityMaps` and `WorldMap` into a single record, `ScenarioInputs`. Establishes a Matroska-style arrangement of records to represent various scopes of state, eliminating several redundant fields.
This commit is contained in:
parent
6813c3bfd5
commit
326305653d
@ -38,7 +38,7 @@ import Swarm.Game.Entity qualified as E
|
||||
import Swarm.Game.Land
|
||||
import Swarm.Game.Recipe (Recipe, recipeCatalysts, recipeInputs, recipeOutputs)
|
||||
import Swarm.Game.Robot (Robot, equippedDevices, robotInventory)
|
||||
import Swarm.Game.Scenario (GameStateInputs (..), loadStandaloneScenario, scenarioLandscape)
|
||||
import Swarm.Game.Scenario (GameStateInputs (..), ScenarioInputs (..), loadStandaloneScenario, scenarioLandscape)
|
||||
import Swarm.Game.World.Gen (extractEntities)
|
||||
import Swarm.Game.World.Typecheck (Some (..), TTerm)
|
||||
import Swarm.Language.Key (specialKeyNames)
|
||||
@ -136,7 +136,7 @@ generateSpecialKeyNames =
|
||||
|
||||
generateRecipe :: IO String
|
||||
generateRecipe = simpleErrorHandle $ do
|
||||
(classic, GameStateInputs worlds (TerrainEntityMaps _ entities) recipes) <- loadStandaloneScenario "data/scenarios/classic.yaml"
|
||||
(classic, GameStateInputs (ScenarioInputs worlds (TerrainEntityMaps _ entities)) recipes) <- loadStandaloneScenario "data/scenarios/classic.yaml"
|
||||
baseRobot <- instantiateBaseRobot $ classic ^. scenarioLandscape
|
||||
return . Dot.showDot $ recipesToDot baseRobot (worlds ! "classic") entities recipes
|
||||
|
||||
|
@ -35,6 +35,7 @@ import Swarm.Game.Failure (SystemFailure)
|
||||
import Swarm.Game.Land
|
||||
import Swarm.Game.Scenario (
|
||||
Scenario,
|
||||
ScenarioInputs (..),
|
||||
scenarioDescription,
|
||||
scenarioMetadata,
|
||||
scenarioName,
|
||||
@ -181,7 +182,7 @@ loadScenarioCollection = simpleErrorHandle $ do
|
||||
-- all the scenarios via the usual code path; we do not need to do
|
||||
-- anything with them here while simply rendering pedagogy info.
|
||||
worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds tem
|
||||
ignoreWarnings @(Seq SystemFailure) $ loadScenarios tem worlds
|
||||
ignoreWarnings @(Seq SystemFailure) $ loadScenarios $ ScenarioInputs worlds tem
|
||||
|
||||
renderUsagesMarkdown :: CoverageInfo -> Text
|
||||
renderUsagesMarkdown (CoverageInfo (TutorialInfo (s, si) idx _sCmds dCmds) novelCmds) =
|
||||
|
@ -47,6 +47,8 @@ import Swarm.Game.Achievement.Persistence
|
||||
import Swarm.Game.Failure (SystemFailure)
|
||||
import Swarm.Game.Land
|
||||
import Swarm.Game.Scenario (
|
||||
ScenarioInputs (..),
|
||||
gsiScenarioInputs,
|
||||
loadScenario,
|
||||
scenarioAttrs,
|
||||
scenarioLandscape,
|
||||
@ -138,7 +140,7 @@ constructAppState ::
|
||||
AppOpts ->
|
||||
m AppState
|
||||
constructAppState rs ui opts@(AppOpts {..}) = do
|
||||
let gs = initGameState (mkGameStateConfig rs)
|
||||
let gs = initGameState $ rs ^. stdGameConfigInputs
|
||||
case skipMenu opts of
|
||||
False -> return $ AppState gs (ui & uiGameplay . uiTiming . lgTicksPerSecond .~ defaultInitLgTicksPerSecond) rs
|
||||
True -> do
|
||||
@ -146,8 +148,7 @@ constructAppState rs ui opts@(AppOpts {..}) = do
|
||||
(scenario, path) <-
|
||||
loadScenario
|
||||
(fromMaybe "classic" userScenario)
|
||||
tem
|
||||
(rs ^. worlds)
|
||||
(ScenarioInputs (initWorldMap . gsiScenarioInputs . initState $ rs ^. stdGameConfigInputs) tem)
|
||||
maybeRunScript <- traverse parseCodeFile scriptToRun
|
||||
|
||||
let maybeAutoplay = do
|
||||
@ -219,7 +220,7 @@ scenarioToAppState ::
|
||||
m ()
|
||||
scenarioToAppState siPair@(scene, _) lp = do
|
||||
rs <- use runtimeState
|
||||
gs <- liftIO $ scenarioToGameState scene lp $ mkGameStateConfig rs
|
||||
gs <- liftIO $ scenarioToGameState scene lp $ rs ^. stdGameConfigInputs
|
||||
gameState .= gs
|
||||
void $ withLensIO uiState $ scenarioToUIState isAutoplaying siPair gs
|
||||
where
|
||||
|
@ -56,12 +56,10 @@ import Data.Sequence qualified as Seq
|
||||
import Data.Text (Text)
|
||||
import Data.Yaml as Y
|
||||
import Swarm.Game.Failure
|
||||
import Swarm.Game.Land
|
||||
import Swarm.Game.ResourceLoading (getDataDirSafe, getSwarmSavePath)
|
||||
import Swarm.Game.Scenario
|
||||
import Swarm.Game.Scenario.Scoring.CodeSize
|
||||
import Swarm.Game.Scenario.Status
|
||||
import Swarm.Game.World.Typecheck (WorldMap)
|
||||
import Swarm.Util.Effect (warn, withThrow)
|
||||
import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, listDirectory)
|
||||
import System.FilePath (pathSeparator, splitDirectories, takeBaseName, takeExtensions, (-<.>), (</>))
|
||||
@ -137,16 +135,15 @@ flatten (SICollection _ c) = concatMap flatten $ scenarioCollectionToList c
|
||||
-- | Load all the scenarios from the scenarios data directory.
|
||||
loadScenarios ::
|
||||
(Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>
|
||||
TerrainEntityMaps ->
|
||||
WorldMap ->
|
||||
ScenarioInputs ->
|
||||
m ScenarioCollection
|
||||
loadScenarios tem worldMap = do
|
||||
loadScenarios scenarioInputs = do
|
||||
res <- runThrow @SystemFailure $ getDataDirSafe Scenarios "scenarios"
|
||||
case res of
|
||||
Left err -> do
|
||||
warn err
|
||||
return $ SC mempty mempty
|
||||
Right dataDir -> loadScenarioDir tem worldMap dataDir
|
||||
Right dataDir -> loadScenarioDir scenarioInputs dataDir
|
||||
|
||||
-- | The name of the special file which indicates the order of
|
||||
-- scenarios in a folder.
|
||||
@ -161,11 +158,10 @@ readOrderFile orderFile =
|
||||
-- the 00-ORDER file (if any) giving the order for the scenarios.
|
||||
loadScenarioDir ::
|
||||
(Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>
|
||||
TerrainEntityMaps ->
|
||||
WorldMap ->
|
||||
ScenarioInputs ->
|
||||
FilePath ->
|
||||
m ScenarioCollection
|
||||
loadScenarioDir tem worldMap dir = do
|
||||
loadScenarioDir scenarioInputs dir = do
|
||||
let orderFile = dir </> orderFileName
|
||||
dirName = takeBaseName dir
|
||||
orderExists <- sendIO $ doesFileExist orderFile
|
||||
@ -196,7 +192,7 @@ loadScenarioDir tem worldMap dir = do
|
||||
-- Only keep the files from 00-ORDER.txt that actually exist.
|
||||
let morder' = filter (`elem` itemPaths) <$> morder
|
||||
loadItem filepath = do
|
||||
item <- loadScenarioItem tem worldMap (dir </> filepath)
|
||||
item <- loadScenarioItem scenarioInputs (dir </> filepath)
|
||||
return (filepath, item)
|
||||
scenarios <- mapM (runThrow @SystemFailure . loadItem) itemPaths
|
||||
let (failures, successes) = partitionEithers scenarios
|
||||
@ -257,17 +253,16 @@ loadScenarioItem ::
|
||||
, Has (Accum (Seq SystemFailure)) sig m
|
||||
, Has (Lift IO) sig m
|
||||
) =>
|
||||
TerrainEntityMaps ->
|
||||
WorldMap ->
|
||||
ScenarioInputs ->
|
||||
FilePath ->
|
||||
m ScenarioItem
|
||||
loadScenarioItem tem worldMap path = do
|
||||
loadScenarioItem scenarioInputs path = do
|
||||
isDir <- sendIO $ doesDirectoryExist path
|
||||
let collectionName = into @Text . dropWhile isSpace . takeBaseName $ path
|
||||
case isDir of
|
||||
True -> SICollection collectionName <$> loadScenarioDir tem worldMap path
|
||||
True -> SICollection collectionName <$> loadScenarioDir scenarioInputs path
|
||||
False -> do
|
||||
s <- loadScenarioFile tem worldMap path
|
||||
s <- loadScenarioFile scenarioInputs path
|
||||
eitherSi <- runThrow @SystemFailure (loadScenarioInfo path)
|
||||
case eitherSi of
|
||||
Right si -> return $ SISingle (s, si)
|
||||
|
@ -207,7 +207,7 @@ initRobots gsc =
|
||||
, _robotsWatching = mempty
|
||||
, _robotNaming =
|
||||
RobotNaming
|
||||
{ _nameGenerator = initNameParts gsc
|
||||
{ _nameGenerator = nameParts gsc
|
||||
, _gensym = 0
|
||||
}
|
||||
, _viewCenterRule = VCRobot 0
|
||||
|
@ -11,16 +11,14 @@ module Swarm.Game.State.Runtime (
|
||||
webPort,
|
||||
upstreamRelease,
|
||||
eventLog,
|
||||
worlds,
|
||||
scenarios,
|
||||
stdEntityTerrainMap,
|
||||
stdRecipes,
|
||||
appData,
|
||||
nameParts,
|
||||
stdGameConfigInputs,
|
||||
|
||||
-- ** Utility
|
||||
initScenarioInputs,
|
||||
initRuntimeState,
|
||||
mkGameStateConfig,
|
||||
initGameStateConfig,
|
||||
)
|
||||
where
|
||||
|
||||
@ -32,16 +30,14 @@ import Data.Map (Map)
|
||||
import Data.Sequence (Seq)
|
||||
import Data.Text (Text)
|
||||
import Network.Wai.Handler.Warp (Port)
|
||||
import Swarm.Game.Entity (Entity)
|
||||
import Swarm.Game.Failure (SystemFailure)
|
||||
import Swarm.Game.Land
|
||||
import Swarm.Game.Recipe (Recipe, loadRecipes)
|
||||
import Swarm.Game.ResourceLoading (NameGenerator, initNameGenerator, readAppData)
|
||||
import Swarm.Game.Scenario (GameStateInputs (..))
|
||||
import Swarm.Game.Recipe (loadRecipes)
|
||||
import Swarm.Game.ResourceLoading (initNameGenerator, readAppData)
|
||||
import Swarm.Game.Scenario (GameStateInputs (..), ScenarioInputs (..))
|
||||
import Swarm.Game.ScenarioInfo (ScenarioCollection, loadScenarios)
|
||||
import Swarm.Game.State.Substate
|
||||
import Swarm.Game.World.Load (loadWorlds)
|
||||
import Swarm.Game.World.Typecheck (WorldMap)
|
||||
import Swarm.Log
|
||||
import Swarm.Util.Lens (makeLensesNoSigs)
|
||||
import Swarm.Version (NewReleaseFailure (..))
|
||||
@ -50,14 +46,45 @@ data RuntimeState = RuntimeState
|
||||
{ _webPort :: Maybe Port
|
||||
, _upstreamRelease :: Either NewReleaseFailure String
|
||||
, _eventLog :: Notifications LogEntry
|
||||
, _worlds :: WorldMap
|
||||
, _scenarios :: ScenarioCollection
|
||||
, _stdEntityTerrainMap :: TerrainEntityMaps
|
||||
, _stdRecipes :: [Recipe Entity]
|
||||
, _stdGameConfigInputs :: GameStateConfig
|
||||
, _appData :: Map Text Text
|
||||
, _nameParts :: NameGenerator
|
||||
}
|
||||
|
||||
initScenarioInputs ::
|
||||
( Has (Throw SystemFailure) sig m
|
||||
, Has (Accum (Seq SystemFailure)) sig m
|
||||
, Has (Lift IO) sig m
|
||||
) =>
|
||||
m ScenarioInputs
|
||||
initScenarioInputs = do
|
||||
tem <- loadEntitiesAndTerrain
|
||||
worlds <- loadWorlds tem
|
||||
return $ ScenarioInputs worlds tem
|
||||
|
||||
initGameStateInputs ::
|
||||
( Has (Throw SystemFailure) sig m
|
||||
, Has (Accum (Seq SystemFailure)) sig m
|
||||
, Has (Lift IO) sig m
|
||||
) =>
|
||||
m GameStateInputs
|
||||
initGameStateInputs = do
|
||||
scenarioInputs <- initScenarioInputs
|
||||
recipes <- loadRecipes $ initEntityTerrain scenarioInputs ^. entityMap
|
||||
return $ GameStateInputs scenarioInputs recipes
|
||||
|
||||
initGameStateConfig ::
|
||||
( Has (Throw SystemFailure) sig m
|
||||
, Has (Accum (Seq SystemFailure)) sig m
|
||||
, Has (Lift IO) sig m
|
||||
) =>
|
||||
m GameStateConfig
|
||||
initGameStateConfig = do
|
||||
gsi <- initGameStateInputs
|
||||
appDataMap <- readAppData
|
||||
nameGen <- initNameGenerator appDataMap
|
||||
return $ GameStateConfig appDataMap nameGen gsi
|
||||
|
||||
initRuntimeState ::
|
||||
( Has (Throw SystemFailure) sig m
|
||||
, Has (Accum (Seq SystemFailure)) sig m
|
||||
@ -65,23 +92,17 @@ initRuntimeState ::
|
||||
) =>
|
||||
m RuntimeState
|
||||
initRuntimeState = do
|
||||
tem <- loadEntitiesAndTerrain
|
||||
recipes <- loadRecipes $ tem ^. entityMap
|
||||
worlds <- loadWorlds tem
|
||||
scenarios <- loadScenarios tem worlds
|
||||
appDataMap <- readAppData
|
||||
nameGen <- initNameGenerator appDataMap
|
||||
gsc <- initGameStateConfig
|
||||
scenarios <- loadScenarios $ gsiScenarioInputs $ initState gsc
|
||||
|
||||
return $
|
||||
RuntimeState
|
||||
{ _webPort = Nothing
|
||||
, _upstreamRelease = Left (NoMainUpstreamRelease [])
|
||||
, _eventLog = mempty
|
||||
, _worlds = worlds
|
||||
, _scenarios = scenarios
|
||||
, _stdEntityTerrainMap = tem
|
||||
, _stdRecipes = recipes
|
||||
, _appData = appDataMap
|
||||
, _nameParts = nameGen
|
||||
, _appData = initAppDataMap gsc
|
||||
, _stdGameConfigInputs = gsc
|
||||
}
|
||||
|
||||
makeLensesNoSigs ''RuntimeState
|
||||
@ -99,39 +120,12 @@ upstreamRelease :: Lens' RuntimeState (Either NewReleaseFailure String)
|
||||
-- place to log it.
|
||||
eventLog :: Lens' RuntimeState (Notifications LogEntry)
|
||||
|
||||
-- | A collection of typechecked world DSL terms that are available to
|
||||
-- be used in scenario definitions.
|
||||
worlds :: Lens' RuntimeState WorldMap
|
||||
|
||||
-- | The collection of scenarios that comes with the game.
|
||||
scenarios :: Lens' RuntimeState ScenarioCollection
|
||||
|
||||
-- | 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.
|
||||
stdEntityTerrainMap :: Lens' RuntimeState TerrainEntityMaps
|
||||
|
||||
-- | 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.
|
||||
stdRecipes :: Lens' RuntimeState [Recipe Entity]
|
||||
-- | Built-in resources for loading games
|
||||
stdGameConfigInputs :: Lens' RuntimeState GameStateConfig
|
||||
|
||||
-- | Free-form data loaded from the @data@ directory, for things like
|
||||
-- the logo, about page, tutorial story, etc.
|
||||
appData :: Lens' RuntimeState (Map Text Text)
|
||||
|
||||
-- | Lists of words/adjectives for use in building random robot names.
|
||||
nameParts :: Lens' RuntimeState NameGenerator
|
||||
|
||||
-- | Create a 'GameStateConfig' record from the 'RuntimeState'.
|
||||
mkGameStateConfig :: RuntimeState -> GameStateConfig
|
||||
mkGameStateConfig rs =
|
||||
GameStateConfig
|
||||
{ initNameParts = rs ^. nameParts
|
||||
, initState =
|
||||
GameStateInputs
|
||||
{ initEntityTerrain = rs ^. stdEntityTerrainMap
|
||||
, initRecipes = rs ^. stdRecipes
|
||||
, initWorldMap = rs ^. worlds
|
||||
}
|
||||
}
|
||||
|
@ -448,4 +448,4 @@ initRecipeMaps gsc =
|
||||
, _recipesCat = catRecipeMap recipeList
|
||||
}
|
||||
where
|
||||
recipeList = initRecipes $ initState gsc
|
||||
recipeList = gsiRecipes $ initState gsc
|
||||
|
@ -56,6 +56,7 @@ module Swarm.Game.Scenario (
|
||||
getScenarioPath,
|
||||
loadStandaloneScenario,
|
||||
GameStateInputs (..),
|
||||
ScenarioInputs (..),
|
||||
|
||||
-- * Utilities
|
||||
arbitrateSeed,
|
||||
@ -265,7 +266,7 @@ scenarioLandscape :: Lens' Scenario ScenarioLandscape
|
||||
|
||||
-- * Parsing
|
||||
|
||||
instance FromJSONE (TerrainEntityMaps, WorldMap) Scenario where
|
||||
instance FromJSONE ScenarioInputs Scenario where
|
||||
parseJSONE = withObjectE "scenario" $ \v -> do
|
||||
-- parse custom terrain
|
||||
tmRaw <- liftE (v .:? "terrains" .!= [])
|
||||
@ -288,12 +289,12 @@ instance FromJSONE (TerrainEntityMaps, WorldMap) Scenario where
|
||||
let scenarioSpecificTerrainEntities = TerrainEntityMaps tm em
|
||||
|
||||
-- Save the passed in WorldMap for later
|
||||
worldMap <- snd <$> getE
|
||||
worldMap <- initWorldMap <$> getE
|
||||
|
||||
-- Get rid of WorldMap from context locally, and combine
|
||||
-- the default system TerrainMap and EntityMap
|
||||
-- with any custom terrain/entities parsed above
|
||||
localE fst $ withE scenarioSpecificTerrainEntities $ do
|
||||
localE initEntityTerrain $ withE scenarioSpecificTerrainEntities $ do
|
||||
-- parse 'known' entity names and make sure they exist
|
||||
known <- liftE (v .:? "known" .!= mempty)
|
||||
combinedTEM <- getE
|
||||
@ -416,24 +417,22 @@ getScenarioPath scenario = do
|
||||
loadScenario ::
|
||||
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
|
||||
FilePath ->
|
||||
TerrainEntityMaps ->
|
||||
WorldMap ->
|
||||
ScenarioInputs ->
|
||||
m (Scenario, FilePath)
|
||||
loadScenario scenario tem worldMap = do
|
||||
loadScenario scenario scenarioInputs = do
|
||||
mfileName <- getScenarioPath scenario
|
||||
fileName <- maybe (throwError $ ScenarioNotFound scenario) return mfileName
|
||||
(,fileName) <$> loadScenarioFile tem worldMap fileName
|
||||
(,fileName) <$> loadScenarioFile scenarioInputs fileName
|
||||
|
||||
-- | Load a scenario from a file.
|
||||
loadScenarioFile ::
|
||||
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
|
||||
TerrainEntityMaps ->
|
||||
WorldMap ->
|
||||
ScenarioInputs ->
|
||||
FilePath ->
|
||||
m Scenario
|
||||
loadScenarioFile tem worldMap fileName =
|
||||
loadScenarioFile scenarioInputs fileName =
|
||||
(withThrow adaptError . (liftEither <=< sendIO)) $
|
||||
decodeFileEitherE (tem, worldMap) fileName
|
||||
decodeFileEitherE scenarioInputs fileName
|
||||
where
|
||||
adaptError = AssetNotLoaded (Data Scenarios) fileName . CanNotParseYaml
|
||||
|
||||
@ -443,15 +442,28 @@ loadStandaloneScenario ::
|
||||
m (Scenario, GameStateInputs)
|
||||
loadStandaloneScenario fp = do
|
||||
tem <- loadEntitiesAndTerrain
|
||||
recipes <- loadRecipes $ tem ^. entityMap
|
||||
worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds tem
|
||||
scene <- fst <$> loadScenario fp tem worlds
|
||||
return (scene, GameStateInputs worlds tem recipes)
|
||||
let scenarioInputs = ScenarioInputs worlds tem
|
||||
recipes <- loadRecipes $ tem ^. entityMap
|
||||
scene <- fst <$> loadScenario fp scenarioInputs
|
||||
return (scene, GameStateInputs scenarioInputs recipes)
|
||||
|
||||
data ScenarioInputs = ScenarioInputs
|
||||
{ initWorldMap :: WorldMap
|
||||
-- ^ A collection of typechecked world DSL terms that are available to
|
||||
-- be used in scenario definitions.
|
||||
, 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
|
||||
{ initWorldMap :: WorldMap
|
||||
, initEntityTerrain :: TerrainEntityMaps
|
||||
, initRecipes :: [Recipe Entity]
|
||||
{ gsiScenarioInputs :: ScenarioInputs
|
||||
, 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.
|
||||
}
|
||||
|
||||
-- |
|
||||
|
@ -5,12 +5,16 @@
|
||||
-- 'Swarm.Game.State.GameState' record and its subrecords.
|
||||
module Swarm.Game.State.Config where
|
||||
|
||||
import Data.Map (Map)
|
||||
import Data.Text (Text)
|
||||
import Swarm.Game.ResourceLoading (NameGenerator)
|
||||
import Swarm.Game.Scenario (GameStateInputs)
|
||||
|
||||
-- | Record to pass information needed to create an initial
|
||||
-- 'GameState' record when starting a scenario.
|
||||
data GameStateConfig = GameStateConfig
|
||||
{ initNameParts :: NameGenerator
|
||||
{ initAppDataMap :: Map Text Text
|
||||
, nameParts :: NameGenerator
|
||||
-- ^ Lists of words/adjectives for use in building random robot names.
|
||||
, initState :: GameStateInputs
|
||||
}
|
||||
|
@ -83,7 +83,7 @@ initLandscape gsc =
|
||||
Landscape
|
||||
{ _worldNavigation = Navigation mempty mempty
|
||||
, _multiWorld = mempty
|
||||
, _terrainAndEntities = initEntityTerrain $ initState gsc
|
||||
, _terrainAndEntities = initEntityTerrain $ gsiScenarioInputs $ initState gsc
|
||||
, _worldScrollable = True
|
||||
}
|
||||
|
||||
|
@ -6,7 +6,7 @@
|
||||
module Main where
|
||||
|
||||
import Control.Carrier.Accum.FixedStrict (runAccum)
|
||||
import Control.Lens ((&), (.~))
|
||||
import Control.Lens (view, (&), (.~))
|
||||
import Control.Monad (replicateM_)
|
||||
import Control.Monad.State (evalStateT, execStateT)
|
||||
import Data.Map qualified as M
|
||||
@ -24,7 +24,7 @@ import Swarm.Game.Scenario (loadStandaloneScenario)
|
||||
import Swarm.Game.State (GameState, creativeMode, landscape, pureScenarioToGameState, zoomRobots)
|
||||
import Swarm.Game.State.Landscape (multiWorld)
|
||||
import Swarm.Game.State.Robot (addTRobot)
|
||||
import Swarm.Game.State.Runtime (initRuntimeState, mkGameStateConfig)
|
||||
import Swarm.Game.State.Runtime (initRuntimeState, stdGameConfigInputs)
|
||||
import Swarm.Game.Step (gameTick)
|
||||
import Swarm.Game.Terrain (blankTerrainIndex)
|
||||
import Swarm.Game.Universe (Cosmic (..), SubworldName (DefaultRootSubworld))
|
||||
@ -146,7 +146,7 @@ mkGameState prog robotMaker numRobots = do
|
||||
gs <- simpleErrorHandle $ do
|
||||
(_ :: Seq SystemFailure, initRS) <- runAccum mempty initRuntimeState
|
||||
(scenario, _) <- loadStandaloneScenario "classic"
|
||||
return $ pureScenarioToGameState scenario 0 0 Nothing $ mkGameStateConfig initRS
|
||||
return $ pureScenarioToGameState scenario 0 0 Nothing $ view stdGameConfigInputs initRS
|
||||
|
||||
execStateT
|
||||
(zoomRobots $ mapM_ (addTRobot $ initMachine prog Context.empty emptyStore) robots)
|
||||
|
@ -13,7 +13,7 @@ import Control.Carrier.Lift (runM)
|
||||
import Control.Carrier.Throw.Either (runThrow)
|
||||
import Control.Lens (Ixed (ix), at, to, use, view, (&), (.~), (<>~), (^.), (^..), (^?), (^?!))
|
||||
import Control.Monad (forM_, unless, when)
|
||||
import Control.Monad.State (StateT (runStateT), gets)
|
||||
import Control.Monad.State (StateT, execStateT, gets)
|
||||
import Data.Char (isSpace)
|
||||
import Data.Containers.ListUtils (nubOrd)
|
||||
import Data.Foldable (Foldable (toList), find)
|
||||
@ -33,12 +33,11 @@ import Swarm.Game.Achievement.Definitions (GameplayAchievement (..))
|
||||
import Swarm.Game.CESK (emptyStore, initMachine)
|
||||
import Swarm.Game.Entity (lookupByName)
|
||||
import Swarm.Game.Failure (SystemFailure)
|
||||
import Swarm.Game.Land
|
||||
import Swarm.Game.Robot (equippedDevices, systemRobot)
|
||||
import Swarm.Game.Robot.Activity (commandsHistogram, lifetimeStepCount, tangibleCommandCount)
|
||||
import Swarm.Game.Robot.Concrete (activityCounts, machine, robotContext, robotLog, waitingUntil)
|
||||
import Swarm.Game.Robot.Context (defReqs)
|
||||
import Swarm.Game.Scenario (Scenario)
|
||||
import Swarm.Game.Scenario (Scenario, ScenarioInputs (..), gsiScenarioInputs)
|
||||
import Swarm.Game.State (
|
||||
GameState,
|
||||
baseRobot,
|
||||
@ -58,13 +57,13 @@ import Swarm.Game.State.Robot (
|
||||
import Swarm.Game.State.Runtime (
|
||||
RuntimeState,
|
||||
eventLog,
|
||||
stdEntityTerrainMap,
|
||||
worlds,
|
||||
stdGameConfigInputs,
|
||||
)
|
||||
import Swarm.Game.State.Substate (
|
||||
WinCondition (WinConditions),
|
||||
WinStatus (Won),
|
||||
gameAchievements,
|
||||
initState,
|
||||
messageQueue,
|
||||
notificationsContent,
|
||||
ticks,
|
||||
@ -72,7 +71,6 @@ import Swarm.Game.State.Substate (
|
||||
import Swarm.Game.Step (gameTick)
|
||||
import Swarm.Game.Step.Path.Type
|
||||
import Swarm.Game.Tick (getTickNumber)
|
||||
import Swarm.Game.World.Typecheck (WorldMap)
|
||||
import Swarm.Language.Context qualified as Ctx
|
||||
import Swarm.Language.Pipeline (ProcessedTerm (..), processTerm)
|
||||
import Swarm.Language.Pretty (prettyString)
|
||||
@ -107,7 +105,7 @@ main = do
|
||||
(rs, ui) <- do
|
||||
out <- runM . runThrow @SystemFailure $ initPersistentState defaultAppOpts
|
||||
either (assertFailure . prettyString) return out
|
||||
let tem = rs ^. stdEntityTerrainMap
|
||||
let scenarioInputs = gsiScenarioInputs $ initState $ rs ^. stdGameConfigInputs
|
||||
rs' = rs & eventLog .~ mempty
|
||||
defaultMain $
|
||||
testGroup
|
||||
@ -115,8 +113,8 @@ main = do
|
||||
[ testNoLoadingErrors rs
|
||||
, exampleTests examplePaths
|
||||
, exampleTests scenarioPrograms
|
||||
, scenarioParseTests tem (rs ^. worlds) parseableScenarios
|
||||
, scenarioParseInvalidTests tem (rs ^. worlds) unparseableScenarios
|
||||
, scenarioParseTests scenarioInputs parseableScenarios
|
||||
, scenarioParseInvalidTests scenarioInputs unparseableScenarios
|
||||
, testScenarioSolutions rs' ui
|
||||
, testEditorFiles
|
||||
]
|
||||
@ -145,27 +143,27 @@ exampleTest (path, fileContent) =
|
||||
where
|
||||
value = processTerm $ into @Text fileContent
|
||||
|
||||
scenarioParseTests :: TerrainEntityMaps -> WorldMap -> [(FilePath, String)] -> TestTree
|
||||
scenarioParseTests tem worldMap inputs =
|
||||
scenarioParseTests :: ScenarioInputs -> [(FilePath, String)] -> TestTree
|
||||
scenarioParseTests scenarioInputs inputs =
|
||||
testGroup
|
||||
"Test scenarios parse"
|
||||
(map (scenarioTest Parsed tem worldMap) inputs)
|
||||
(map (scenarioTest Parsed scenarioInputs) inputs)
|
||||
|
||||
scenarioParseInvalidTests :: TerrainEntityMaps -> WorldMap -> [(FilePath, String)] -> TestTree
|
||||
scenarioParseInvalidTests tem worldMap inputs =
|
||||
scenarioParseInvalidTests :: ScenarioInputs -> [(FilePath, String)] -> TestTree
|
||||
scenarioParseInvalidTests scenarioInputs inputs =
|
||||
testGroup
|
||||
"Test invalid scenarios fail to parse"
|
||||
(map (scenarioTest Failed tem worldMap) inputs)
|
||||
(map (scenarioTest Failed scenarioInputs) inputs)
|
||||
|
||||
data ParseResult = Parsed | Failed
|
||||
|
||||
scenarioTest :: ParseResult -> TerrainEntityMaps -> WorldMap -> (FilePath, String) -> TestTree
|
||||
scenarioTest expRes tem worldMap (path, _) =
|
||||
testCase ("parse scenario " ++ show path) (getScenario expRes tem worldMap path)
|
||||
scenarioTest :: ParseResult -> ScenarioInputs -> (FilePath, String) -> TestTree
|
||||
scenarioTest expRes scenarioInputs (path, _) =
|
||||
testCase ("parse scenario " ++ show path) (getScenario expRes scenarioInputs path)
|
||||
|
||||
getScenario :: ParseResult -> TerrainEntityMaps -> WorldMap -> FilePath -> IO ()
|
||||
getScenario expRes tem worldMap p = do
|
||||
res <- decodeFileEitherE (tem, worldMap) p :: IO (Either ParseException Scenario)
|
||||
getScenario :: ParseResult -> ScenarioInputs -> FilePath -> IO ()
|
||||
getScenario expRes scenarioInputs p = do
|
||||
res <- decodeFileEitherE scenarioInputs p :: IO (Either ParseException Scenario)
|
||||
case expRes of
|
||||
Parsed -> case res of
|
||||
Left err -> assertFailure (prettyPrintParseException err)
|
||||
@ -497,7 +495,7 @@ testScenarioSolutions rs ui =
|
||||
-- hopefully, eventually, go away).
|
||||
& baseRobot . robotContext . defReqs <>~ reqCtx
|
||||
& baseRobot . machine .~ initMachine sol Ctx.empty emptyStore
|
||||
m <- timeout (time s) (snd <$> runStateT playUntilWin gs')
|
||||
m <- timeout (time s) (execStateT playUntilWin gs')
|
||||
case m of
|
||||
Nothing -> assertFailure "Timed out - this likely means that the solution did not work."
|
||||
Just g -> do
|
||||
|
@ -13,6 +13,8 @@ import Control.Monad.Except (runExceptT)
|
||||
import Data.List (subsequences)
|
||||
import Data.Set (Set)
|
||||
import Data.Set qualified as S
|
||||
import Swarm.Game.State.Runtime (stdGameConfigInputs)
|
||||
import Swarm.Game.State.Substate (initState)
|
||||
import Swarm.TUI.Model (AppState, gameState, runtimeState)
|
||||
import Swarm.TUI.Model.StateUpdate (classicGame0)
|
||||
import Swarm.Util (removeSupersets, smallHittingSet)
|
||||
@ -56,7 +58,7 @@ tests s =
|
||||
, testPrettyConst
|
||||
, testBoolExpr
|
||||
, testCommands
|
||||
, testDeviceRecipeCoverage (s ^. runtimeState)
|
||||
, testDeviceRecipeCoverage (initState $ s ^. runtimeState . stdGameConfigInputs)
|
||||
, testHighScores
|
||||
, testEval (s ^. gameState)
|
||||
, testModel
|
||||
|
@ -14,14 +14,14 @@ import Data.Text qualified as T
|
||||
import Swarm.Game.Entity (EntityMap (entitiesByCap), entityName)
|
||||
import Swarm.Game.Land
|
||||
import Swarm.Game.Recipe (recipeOutputs)
|
||||
import Swarm.Game.State.Runtime (RuntimeState, stdEntityTerrainMap, stdRecipes)
|
||||
import Swarm.Game.Scenario (GameStateInputs (..), initEntityTerrain)
|
||||
import Swarm.Util (commaList, quote)
|
||||
import Test.Tasty
|
||||
import Test.Tasty.ExpectedFailure (expectFailBecause)
|
||||
import Test.Tasty.HUnit
|
||||
|
||||
testDeviceRecipeCoverage :: RuntimeState -> TestTree
|
||||
testDeviceRecipeCoverage rs =
|
||||
testDeviceRecipeCoverage :: GameStateInputs -> TestTree
|
||||
testDeviceRecipeCoverage gsi =
|
||||
testGroup
|
||||
"Recipe coverage"
|
||||
[ expectFailBecause "Need to come up with more recipes" checkCoverage
|
||||
@ -44,8 +44,8 @@ testDeviceRecipeCoverage rs =
|
||||
-- Only include entities that grant a capability:
|
||||
entityNames =
|
||||
Set.fromList . map (^. entityName) . concat . M.elems . entitiesByCap $
|
||||
rs ^. stdEntityTerrainMap . entityMap
|
||||
initEntityTerrain (gsiScenarioInputs gsi) ^. entityMap
|
||||
|
||||
getOutputsForRecipe r = map ((^. entityName) . snd) $ r ^. recipeOutputs
|
||||
recipeOutputEntities = Set.fromList . concatMap getOutputsForRecipe $ rs ^. stdRecipes
|
||||
recipeOutputEntities = Set.fromList . concatMap getOutputsForRecipe $ gsiRecipes gsi
|
||||
nonCoveredEntities = Set.difference entityNames recipeOutputEntities
|
||||
|
Loading…
Reference in New Issue
Block a user