mirror of
https://github.com/swarm-game/swarm.git
synced 2024-09-11 14:46:33 +03:00
Save scenario completion status (#631)
- save the latest and best completion status for a scenario - scenarios are either `not started`/`in progress`/`completed` with the latter two also having time (real and in ticks) - do not save completion status for `--cheat`ers - show the completion status in the UI - closes #357 Co-authored-by: Brent Yorgey <byorgey@gmail.com>
This commit is contained in:
Ondřej Šebek
GitHub
parent
9c816cd96a
commit
68333dd70a
@ -360,7 +360,7 @@ recipeLevels recipes start = levels
|
||||
classicScenario :: ExceptT Text IO Scenario
|
||||
classicScenario = do
|
||||
entities <- loadEntities >>= guardRight "load entities"
|
||||
loadScenario "data/scenarios/classic.yaml" entities
|
||||
fst <$> loadScenario "data/scenarios/classic.yaml" entities
|
||||
|
||||
startingDevices :: Scenario -> Set Entity
|
||||
startingDevices = Set.fromList . map snd . E.elems . view installedDevices . instantiateRobot 0 . head . view scenarioRobots
|
||||
|
||||
@ -288,7 +288,7 @@ data EntityMap = EntityMap
|
||||
{ entitiesByName :: Map Text Entity
|
||||
, entitiesByCap :: Map Capability [Entity]
|
||||
}
|
||||
deriving (Generic, FromJSON, ToJSON)
|
||||
deriving (Eq, Show, Generic, FromJSON, ToJSON)
|
||||
|
||||
instance Semigroup EntityMap where
|
||||
EntityMap n1 c1 <> EntityMap n2 c2 = EntityMap (n1 <> n2) (c1 <> c2)
|
||||
|
||||
@ -123,7 +123,7 @@ data RobotContext = RobotContext
|
||||
-- definitions.
|
||||
_defStore :: Store
|
||||
}
|
||||
deriving (Show, Generic, FromJSON, ToJSON)
|
||||
deriving (Eq, Show, Generic, FromJSON, ToJSON)
|
||||
|
||||
makeLenses ''RobotContext
|
||||
|
||||
@ -199,6 +199,7 @@ data RobotR (phase :: RobotPhase) = RobotR
|
||||
deriving (Generic)
|
||||
|
||||
deriving instance (Show (RobotLocation phase), Show (RobotID phase)) => Show (RobotR phase)
|
||||
deriving instance (Eq (RobotLocation phase), Eq (RobotID phase)) => Eq (RobotR phase)
|
||||
|
||||
deriving instance (ToJSON (RobotLocation phase), ToJSON (RobotID phase)) => ToJSON (RobotR phase)
|
||||
|
||||
|
||||
@ -45,25 +45,18 @@ module Swarm.Game.Scenario (
|
||||
|
||||
-- * Loading from disk
|
||||
loadScenario,
|
||||
ScenarioCollection (..),
|
||||
scenarioCollectionToList,
|
||||
ScenarioItem (..),
|
||||
_SISingle,
|
||||
scenarioItemName,
|
||||
loadScenarios,
|
||||
loadScenarioFile,
|
||||
) where
|
||||
|
||||
import Control.Algebra (Has)
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.Carrier.Lift (Lift, sendIO)
|
||||
import Control.Carrier.Throw.Either (Throw, runThrow, throwError)
|
||||
import Control.Carrier.Throw.Either (Throw, throwError)
|
||||
import Control.Lens hiding (from, (<.>))
|
||||
import Control.Monad (filterM, unless, when)
|
||||
import Control.Monad (filterM, when)
|
||||
import Data.Aeson.Key qualified as Key
|
||||
import Data.Aeson.KeyMap (KeyMap)
|
||||
import Data.Aeson.KeyMap qualified as KeyMap
|
||||
import Data.Char (isSpace)
|
||||
import Data.List ((\\))
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as M
|
||||
import Data.Maybe (isNothing, listToMaybe)
|
||||
@ -74,7 +67,7 @@ import Data.Yaml as Y
|
||||
import GHC.Generics (Generic)
|
||||
import GHC.Int (Int64)
|
||||
import Linear.V2
|
||||
import Paths_swarm (getDataDir, getDataFileName)
|
||||
import Paths_swarm (getDataFileName)
|
||||
import Swarm.Game.Entity
|
||||
import Swarm.Game.Recipe
|
||||
import Swarm.Game.Robot (TRobot, trobotName)
|
||||
@ -82,24 +75,26 @@ import Swarm.Game.Terrain
|
||||
import Swarm.Language.Pipeline (ProcessedTerm)
|
||||
import Swarm.Util (reflow)
|
||||
import Swarm.Util.Yaml
|
||||
import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)
|
||||
import System.FilePath (takeBaseName, takeExtensions, (<.>), (</>))
|
||||
import System.Directory (doesFileExist)
|
||||
import System.FilePath ((<.>), (</>))
|
||||
import Witch (from, into)
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Scenario objectives
|
||||
------------------------------------------------------------
|
||||
|
||||
-- | An objective is a condition to be achieved by a player in a
|
||||
-- scenario.
|
||||
data Objective = Objective
|
||||
{ _objectiveGoal :: [Text]
|
||||
, _objectiveCondition :: ProcessedTerm
|
||||
}
|
||||
deriving (Show, Generic, ToJSON)
|
||||
deriving (Eq, Show, Generic, ToJSON)
|
||||
|
||||
makeLensesWith (lensRules & generateSignatures .~ False) ''Objective
|
||||
|
||||
-- | An explanation of the goal of the objective, shown to the
|
||||
-- player during play.
|
||||
-- | An explanation of the goal of the objective, shown to the player
|
||||
-- during play. It is represented as a list of paragraphs.
|
||||
objectiveGoal :: Lens' Objective [Text]
|
||||
|
||||
-- | A winning condition for the objective, expressed as a
|
||||
@ -160,6 +155,7 @@ data Cell = Cell
|
||||
, cellEntity :: Maybe Entity
|
||||
, cellRobot :: Maybe TRobot
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Parse a tuple such as @[grass, rock, base]@ into a 'Cell'. The
|
||||
-- entity and robot, if present, are immediately looked up and
|
||||
@ -193,6 +189,7 @@ instance FromJSONE (EntityMap, RobotMap) Cell where
|
||||
-- | A world palette maps characters to 'Cell' values.
|
||||
newtype WorldPalette = WorldPalette
|
||||
{unPalette :: KeyMap Cell}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance FromJSONE (EntityMap, RobotMap) WorldPalette where
|
||||
parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE
|
||||
@ -205,6 +202,7 @@ data WorldDescription = WorldDescription
|
||||
, ul :: V2 Int64
|
||||
, area :: [[Cell]]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance FromJSONE (EntityMap, RobotMap) WorldDescription where
|
||||
parseJSONE = withObjectE "world description" $ \v -> do
|
||||
@ -247,6 +245,7 @@ data Scenario = Scenario
|
||||
, _scenarioSolution :: Maybe ProcessedTerm
|
||||
, _scenarioStepsPerTick :: Maybe Int
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
makeLensesWith (lensRules & generateSignatures .~ False) ''Scenario
|
||||
|
||||
@ -340,7 +339,7 @@ loadScenario ::
|
||||
(Has (Lift IO) sig m, Has (Throw Text) sig m) =>
|
||||
String ->
|
||||
EntityMap ->
|
||||
m Scenario
|
||||
m (Scenario, FilePath)
|
||||
loadScenario scenario em = do
|
||||
libScenario <- sendIO $ getDataFileName $ "scenarios" </> scenario
|
||||
libScenarioExt <- sendIO $ getDataFileName $ "scenarios" </> scenario <.> "yaml"
|
||||
@ -351,104 +350,9 @@ loadScenario scenario em = do
|
||||
|
||||
case mfileName of
|
||||
Nothing -> throwError @Text $ "Scenario not found: " <> from @String scenario
|
||||
Just fileName -> loadScenarioFile em fileName
|
||||
Just fileName -> (,fileName) <$> loadScenarioFile em fileName
|
||||
|
||||
-- | A scenario item is either a specific scenario, or a collection of
|
||||
-- scenarios (*e.g.* the scenarios contained in a subdirectory).
|
||||
data ScenarioItem = SISingle Scenario | SICollection Text ScenarioCollection
|
||||
|
||||
-- | Retrieve the name of a scenario item.
|
||||
scenarioItemName :: ScenarioItem -> Text
|
||||
scenarioItemName (SISingle s) = s ^. scenarioName
|
||||
scenarioItemName (SICollection name _) = name
|
||||
|
||||
-- | A scenario collection is a tree of scenarios, keyed by name,
|
||||
-- together with an optional order. Invariant: every item in the
|
||||
-- scOrder exists as a key in the scMap.
|
||||
data ScenarioCollection = SC
|
||||
{ scOrder :: Maybe [FilePath]
|
||||
, scMap :: Map FilePath ScenarioItem
|
||||
}
|
||||
|
||||
-- | Convert a scenario collection to a list of scenario items.
|
||||
scenarioCollectionToList :: ScenarioCollection -> [ScenarioItem]
|
||||
scenarioCollectionToList (SC Nothing m) = M.elems m
|
||||
scenarioCollectionToList (SC (Just order) m) = (m M.!) <$> order
|
||||
|
||||
-- | Load all the scenarios from the scenarios data directory.
|
||||
loadScenarios :: (Has (Lift IO) sig m) => EntityMap -> m (Either Text ScenarioCollection)
|
||||
loadScenarios em = runThrow $ do
|
||||
dataDir <- sendIO getDataDir
|
||||
loadScenarioDir em (dataDir </> "scenarios")
|
||||
|
||||
orderFileName :: FilePath
|
||||
orderFileName = "00-ORDER.txt"
|
||||
|
||||
-- | Recursively load all scenarios from a particular directory, and also load
|
||||
-- the 00-ORDER file (if any) giving the order for the scenarios.
|
||||
loadScenarioDir ::
|
||||
(Has (Lift IO) sig m, Has (Throw Text) sig m) =>
|
||||
EntityMap ->
|
||||
FilePath ->
|
||||
m ScenarioCollection
|
||||
loadScenarioDir em dir = do
|
||||
let orderFile = dir </> orderFileName
|
||||
dirName = takeBaseName dir
|
||||
orderExists <- sendIO $ doesFileExist orderFile
|
||||
morder <- case orderExists of
|
||||
False -> do
|
||||
when (dirName /= "Testing") $
|
||||
sendIO . putStrLn $
|
||||
"Warning: no " <> orderFileName <> " file found in " <> dirName
|
||||
<> ", using alphabetical order"
|
||||
return Nothing
|
||||
True -> Just . filter (not . null) . lines <$> sendIO (readFile orderFile)
|
||||
fs <- sendIO $ keepYamlOrDirectory <$> listDirectory dir
|
||||
|
||||
case morder of
|
||||
Just order -> do
|
||||
let missing = fs \\ order
|
||||
dangling = order \\ fs
|
||||
|
||||
unless (null missing) $
|
||||
sendIO . putStr . unlines $
|
||||
( "Warning: while processing " <> (dirName </> orderFileName) <> ": files not listed in "
|
||||
<> orderFileName
|
||||
<> " will be ignored"
|
||||
) :
|
||||
map (" - " <>) missing
|
||||
|
||||
unless (null dangling) $
|
||||
sendIO . putStr . unlines $
|
||||
( "Warning: while processing " <> (dirName </> orderFileName)
|
||||
<> ": nonexistent files will be ignored"
|
||||
) :
|
||||
map (" - " <>) dangling
|
||||
Nothing -> pure ()
|
||||
|
||||
-- Only keep the files from 00-ORDER.txt that actually exist.
|
||||
let morder' = filter (`elem` fs) <$> morder
|
||||
SC morder' . M.fromList <$> mapM (\item -> (item,) <$> loadScenarioItem em (dir </> item)) fs
|
||||
where
|
||||
keepYamlOrDirectory = filter (\f -> takeExtensions f `elem` ["", ".yaml"])
|
||||
|
||||
-- | Load a scenario item (either a scenario, or a subdirectory
|
||||
-- containing a collection of scenarios) from a particular path.
|
||||
loadScenarioItem ::
|
||||
(Has (Lift IO) sig m, Has (Throw Text) sig m) =>
|
||||
EntityMap ->
|
||||
FilePath ->
|
||||
m ScenarioItem
|
||||
loadScenarioItem em path = do
|
||||
isDir <- sendIO $ doesDirectoryExist path
|
||||
let collectionName = into @Text . dropWhile isSpace . takeBaseName $ path
|
||||
case isDir of
|
||||
True -> SICollection collectionName <$> loadScenarioDir em path
|
||||
False -> SISingle <$> loadScenarioFile em path
|
||||
|
||||
-- | Load a scenario from a file. The @Maybe Seed@ argument is a
|
||||
-- seed provided by the user (either on the command line, or
|
||||
-- specified through the UI), if any.
|
||||
-- | Load a scenario from a file.
|
||||
loadScenarioFile ::
|
||||
(Has (Lift IO) sig m, Has (Throw Text) sig m) =>
|
||||
EntityMap ->
|
||||
@ -459,9 +363,3 @@ loadScenarioFile em fileName = do
|
||||
case res of
|
||||
Left parseExn -> throwError @Text (from @String (prettyPrintParseException parseExn))
|
||||
Right c -> return c
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Some lenses + prisms
|
||||
------------------------------------------------------------
|
||||
|
||||
makePrisms ''ScenarioItem
|
||||
|
||||
337
src/Swarm/Game/ScenarioInfo.hs
Normal file
337
src/Swarm/Game/ScenarioInfo.hs
Normal file
@ -0,0 +1,337 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# OPTIONS_GHC -Wno-partial-fields #-}
|
||||
|
||||
-- -Wno-orphans is for the Eq/Ord Time instances
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Game.ScenarioStatus
|
||||
-- Copyright : Brent Yorgey
|
||||
-- Maintainer : byorgey@gmail.com
|
||||
--
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- Saving and loading info about scenarios (status, path, etc.) as
|
||||
-- well as loading recursive scenario collections.
|
||||
module Swarm.Game.ScenarioInfo (
|
||||
-- * Scenario info
|
||||
ScenarioStatus (..),
|
||||
_NotStarted,
|
||||
_InProgress,
|
||||
_Complete,
|
||||
ScenarioInfo (..),
|
||||
scenarioPath,
|
||||
scenarioStatus,
|
||||
scenarioBestTime,
|
||||
scenarioBestTicks,
|
||||
updateScenarioInfoOnQuit,
|
||||
|
||||
-- * Scenario collection
|
||||
ScenarioCollection (..),
|
||||
scenarioCollectionToList,
|
||||
scenarioItemByPath,
|
||||
normalizeScenarioPath,
|
||||
ScenarioItem (..),
|
||||
scenarioItemName,
|
||||
_SISingle,
|
||||
|
||||
-- * Loading and saving scenarios
|
||||
loadScenarios,
|
||||
loadScenarioInfo,
|
||||
saveScenarioInfo,
|
||||
|
||||
-- * Re-exports
|
||||
module Swarm.Game.Scenario,
|
||||
) where
|
||||
|
||||
import Control.Algebra (Has)
|
||||
import Control.Carrier.Lift (Lift, sendIO)
|
||||
import Control.Carrier.Throw.Either (Throw, runThrow, throwError)
|
||||
import Control.Lens hiding (from, (<.>))
|
||||
import Control.Monad (unless, when)
|
||||
import Data.Aeson (
|
||||
Options (..),
|
||||
defaultOptions,
|
||||
genericParseJSON,
|
||||
genericToEncoding,
|
||||
genericToJSON,
|
||||
)
|
||||
import Data.Char (isSpace, toLower)
|
||||
import Data.Function (on)
|
||||
import Data.List (intercalate, stripPrefix, (\\))
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as M
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Text (Text, pack)
|
||||
import Data.Time (NominalDiffTime, ZonedTime, diffUTCTime, zonedTimeToUTC)
|
||||
import Data.Yaml as Y
|
||||
import GHC.Generics (Generic)
|
||||
import Paths_swarm (getDataDir)
|
||||
import Swarm.Game.Entity
|
||||
import Swarm.Game.Scenario
|
||||
import Swarm.Util (getSwarmSavePath)
|
||||
import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, listDirectory)
|
||||
import System.FilePath (pathSeparator, splitDirectories, takeBaseName, takeExtensions, (-<.>), (</>))
|
||||
import Witch (into)
|
||||
|
||||
-- Some orphan ZonedTime instances
|
||||
|
||||
instance Eq ZonedTime where
|
||||
(==) = (==) `on` zonedTimeToUTC
|
||||
|
||||
instance Ord ZonedTime where
|
||||
(<=) = (<=) `on` zonedTimeToUTC
|
||||
|
||||
-- | A @ScenarioStatus@ stores the status of a scenario along with
|
||||
-- appropriate metadata: not started, in progress, or complete.
|
||||
-- Note that "in progress" is currently a bit of a misnomer since
|
||||
-- games cannot be saved; at the moment it really means more like
|
||||
-- "you played this scenario before but didn't win".
|
||||
data ScenarioStatus
|
||||
= NotStarted
|
||||
| InProgress
|
||||
{ -- | Time when the scenario was started including time zone.
|
||||
_scenarioStarted :: ZonedTime
|
||||
, -- | Time elapsed until quitting the scenario.
|
||||
_scenarioElapsed :: NominalDiffTime
|
||||
, -- | Ticks elapsed until quitting the scenario.
|
||||
_scenarioElapsedTicks :: Integer
|
||||
}
|
||||
| Complete
|
||||
{ -- | Time when the scenario was started including time zone.
|
||||
_scenarioStarted :: ZonedTime
|
||||
, -- | Time elapsed until quitting the scenario.
|
||||
_scenarioElapsed :: NominalDiffTime
|
||||
, -- | Ticks elapsed until quitting the scenario.
|
||||
_scenarioElapsedTicks :: Integer
|
||||
}
|
||||
deriving (Eq, Ord, Show, Read, Generic)
|
||||
|
||||
instance FromJSON ScenarioStatus where
|
||||
parseJSON = genericParseJSON scenarioOptions
|
||||
|
||||
instance ToJSON ScenarioStatus where
|
||||
toEncoding = genericToEncoding scenarioOptions
|
||||
toJSON = genericToJSON scenarioOptions
|
||||
|
||||
-- | A @ScenarioInfo@ record stores metadata about a scenario: its
|
||||
-- canonical path, most recent status, and best-ever status.
|
||||
data ScenarioInfo = ScenarioInfo
|
||||
{ _scenarioPath :: FilePath
|
||||
, _scenarioStatus :: ScenarioStatus
|
||||
, _scenarioBestTime :: ScenarioStatus
|
||||
, _scenarioBestTicks :: ScenarioStatus
|
||||
}
|
||||
deriving (Eq, Ord, Show, Read, Generic)
|
||||
|
||||
instance FromJSON ScenarioInfo where
|
||||
parseJSON = genericParseJSON scenarioOptions
|
||||
|
||||
instance ToJSON ScenarioInfo where
|
||||
toEncoding = genericToEncoding scenarioOptions
|
||||
toJSON = genericToJSON scenarioOptions
|
||||
|
||||
scenarioOptions :: Options
|
||||
scenarioOptions =
|
||||
defaultOptions
|
||||
{ fieldLabelModifier = map toLower . drop (length "_scenario")
|
||||
}
|
||||
|
||||
makeLensesWith (lensRules & generateSignatures .~ False) ''ScenarioInfo
|
||||
|
||||
-- | The path of the scenario, relative to @data/scenarios@.
|
||||
scenarioPath :: Lens' ScenarioInfo FilePath
|
||||
|
||||
-- | The status of the scenario.
|
||||
scenarioStatus :: Lens' ScenarioInfo ScenarioStatus
|
||||
|
||||
-- | The best status of the scenario, measured in real world time.
|
||||
scenarioBestTime :: Lens' ScenarioInfo ScenarioStatus
|
||||
|
||||
-- | The best status of the scenario, measured in game ticks.
|
||||
scenarioBestTicks :: Lens' ScenarioInfo ScenarioStatus
|
||||
|
||||
-- | Update the current @ScenarioInfo@ record when quitting a game.
|
||||
--
|
||||
-- Note that when comparing "best" times, shorter is not always better!
|
||||
-- As long as the scenario is not completed (e.g. some do not have win condition)
|
||||
-- we consider having fun _longer_ to be better.
|
||||
updateScenarioInfoOnQuit :: ZonedTime -> Integer -> Bool -> ScenarioInfo -> ScenarioInfo
|
||||
updateScenarioInfoOnQuit z ticks completed (ScenarioInfo p s bTime bTicks) = case s of
|
||||
InProgress start _ _ ->
|
||||
let el = (diffUTCTime `on` zonedTimeToUTC) z start
|
||||
cur = (if completed then Complete else InProgress) start el ticks
|
||||
best f b = case b of
|
||||
Complete {} | not completed || f b <= f cur -> b -- keep faster completed
|
||||
InProgress {} | not completed && f b > f cur -> b -- keep longer progress (fun!)
|
||||
_ -> cur -- otherwise update with current
|
||||
in ScenarioInfo p cur (best _scenarioElapsed bTime) (best _scenarioElapsedTicks bTicks)
|
||||
_ -> error "Logical error: trying to quit scenario which is not in progress!"
|
||||
|
||||
-- ----------------------------------------------------------------------------
|
||||
-- Scenario Item
|
||||
-- ----------------------------------------------------------------------------
|
||||
|
||||
-- | A scenario item is either a specific scenario, or a collection of
|
||||
-- scenarios (*e.g.* the scenarios contained in a subdirectory).
|
||||
data ScenarioItem = SISingle Scenario ScenarioInfo | SICollection Text ScenarioCollection
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Retrieve the name of a scenario item.
|
||||
scenarioItemName :: ScenarioItem -> Text
|
||||
scenarioItemName (SISingle s _ss) = s ^. scenarioName
|
||||
scenarioItemName (SICollection name _) = name
|
||||
|
||||
-- | A scenario collection is a tree of scenarios, keyed by name,
|
||||
-- together with an optional order. Invariant: every item in the
|
||||
-- scOrder exists as a key in the scMap.
|
||||
data ScenarioCollection = SC
|
||||
{ scOrder :: Maybe [FilePath]
|
||||
, scMap :: Map FilePath ScenarioItem
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Access and modify ScenarioItems in collection based on their path.
|
||||
scenarioItemByPath :: FilePath -> Traversal' ScenarioCollection ScenarioItem
|
||||
scenarioItemByPath path = ixp ps
|
||||
where
|
||||
ps = splitDirectories path
|
||||
ixp :: Applicative f => [String] -> (ScenarioItem -> f ScenarioItem) -> ScenarioCollection -> f ScenarioCollection
|
||||
ixp [] _ col = pure col
|
||||
ixp [s] f (SC n m) = SC n <$> ix s f m
|
||||
ixp (d : xs) f (SC n m) = SC n <$> ix d inner m
|
||||
where
|
||||
inner si = case si of
|
||||
SISingle {} -> pure si
|
||||
SICollection n' col -> SICollection n' <$> ixp xs f col
|
||||
|
||||
-- | Canonicalize a scenario path, making it usable as a unique key.
|
||||
normalizeScenarioPath :: ScenarioCollection -> FilePath -> IO FilePath
|
||||
normalizeScenarioPath col p =
|
||||
let path = p -<.> "yaml"
|
||||
in if isJust $ col ^? scenarioItemByPath path
|
||||
then return path
|
||||
else do
|
||||
canonPath <- canonicalizePath path
|
||||
d <- getDataDir >>= canonicalizePath
|
||||
let n =
|
||||
stripPrefix (d </> "scenarios") canonPath
|
||||
& maybe canonPath (dropWhile (== pathSeparator))
|
||||
return n
|
||||
|
||||
-- | Convert a scenario collection to a list of scenario items.
|
||||
scenarioCollectionToList :: ScenarioCollection -> [ScenarioItem]
|
||||
scenarioCollectionToList (SC Nothing m) = M.elems m
|
||||
scenarioCollectionToList (SC (Just order) m) = (m M.!) <$> order
|
||||
|
||||
-- | Load all the scenarios from the scenarios data directory.
|
||||
loadScenarios :: (Has (Lift IO) sig m) => EntityMap -> m (Either Text ScenarioCollection)
|
||||
loadScenarios em = runThrow $ do
|
||||
dataDir <- sendIO getDataDir
|
||||
loadScenarioDir em (dataDir </> "scenarios")
|
||||
|
||||
-- | The name of the special file which indicates the order of
|
||||
-- scenarios in a folder.
|
||||
orderFileName :: FilePath
|
||||
orderFileName = "00-ORDER.txt"
|
||||
|
||||
-- | Recursively load all scenarios from a particular directory, and also load
|
||||
-- the 00-ORDER file (if any) giving the order for the scenarios.
|
||||
loadScenarioDir ::
|
||||
(Has (Lift IO) sig m, Has (Throw Text) sig m) =>
|
||||
EntityMap ->
|
||||
FilePath ->
|
||||
m ScenarioCollection
|
||||
loadScenarioDir em dir = do
|
||||
let orderFile = dir </> orderFileName
|
||||
dirName = takeBaseName dir
|
||||
orderExists <- sendIO $ doesFileExist orderFile
|
||||
morder <- case orderExists of
|
||||
False -> do
|
||||
when (dirName /= "Testing") $
|
||||
sendIO . putStrLn $
|
||||
"Warning: no " <> orderFileName <> " file found in " <> dirName
|
||||
<> ", using alphabetical order"
|
||||
return Nothing
|
||||
True -> Just . filter (not . null) . lines <$> sendIO (readFile orderFile)
|
||||
fs <- sendIO $ keepYamlOrDirectory <$> listDirectory dir
|
||||
|
||||
case morder of
|
||||
Just order -> do
|
||||
let missing = fs \\ order
|
||||
dangling = order \\ fs
|
||||
|
||||
unless (null missing) $
|
||||
sendIO . putStr . unlines $
|
||||
( "Warning: while processing " <> (dirName </> orderFileName) <> ": files not listed in "
|
||||
<> orderFileName
|
||||
<> " will be ignored"
|
||||
) :
|
||||
map (" - " <>) missing
|
||||
|
||||
unless (null dangling) $
|
||||
sendIO . putStr . unlines $
|
||||
( "Warning: while processing " <> (dirName </> orderFileName)
|
||||
<> ": nonexistent files will be ignored"
|
||||
) :
|
||||
map (" - " <>) dangling
|
||||
Nothing -> pure ()
|
||||
|
||||
-- Only keep the files from 00-ORDER.txt that actually exist.
|
||||
let morder' = filter (`elem` fs) <$> morder
|
||||
SC morder' . M.fromList <$> mapM (\item -> (item,) <$> loadScenarioItem em (dir </> item)) fs
|
||||
where
|
||||
keepYamlOrDirectory = filter (\f -> takeExtensions f `elem` ["", ".yaml"])
|
||||
|
||||
-- | How to transform scenario path to save path.
|
||||
scenarioPathToSavePath :: FilePath -> FilePath -> FilePath
|
||||
scenarioPathToSavePath path swarmData = swarmData </> Data.List.intercalate "_" (splitDirectories path)
|
||||
|
||||
-- | Load saved info about played scenario from XDG data directory.
|
||||
loadScenarioInfo ::
|
||||
(Has (Lift IO) sig m, Has (Throw Text) sig m) =>
|
||||
FilePath ->
|
||||
m ScenarioInfo
|
||||
loadScenarioInfo p = do
|
||||
path <- sendIO $ normalizeScenarioPath (SC Nothing mempty) p
|
||||
infoPath <- sendIO $ scenarioPathToSavePath path <$> getSwarmSavePath False
|
||||
hasInfo <- sendIO $ doesFileExist infoPath
|
||||
if not hasInfo
|
||||
then do
|
||||
return $ ScenarioInfo path NotStarted NotStarted NotStarted
|
||||
else
|
||||
sendIO (decodeFileEither infoPath)
|
||||
>>= either (throwError . pack . prettyPrintParseException) return
|
||||
|
||||
-- | Save info about played scenario to XDG data directory.
|
||||
saveScenarioInfo ::
|
||||
FilePath ->
|
||||
ScenarioInfo ->
|
||||
IO ()
|
||||
saveScenarioInfo path si = do
|
||||
infoPath <- scenarioPathToSavePath path <$> getSwarmSavePath True
|
||||
encodeFile infoPath si
|
||||
|
||||
-- | Load a scenario item (either a scenario, or a subdirectory
|
||||
-- containing a collection of scenarios) from a particular path.
|
||||
loadScenarioItem ::
|
||||
(Has (Lift IO) sig m, Has (Throw Text) sig m) =>
|
||||
EntityMap ->
|
||||
FilePath ->
|
||||
m ScenarioItem
|
||||
loadScenarioItem em path = do
|
||||
isDir <- sendIO $ doesDirectoryExist path
|
||||
let collectionName = into @Text . dropWhile isSpace . takeBaseName $ path
|
||||
case isDir of
|
||||
True -> SICollection collectionName <$> loadScenarioDir em path
|
||||
False -> do
|
||||
s <- loadScenarioFile em path
|
||||
si <- loadScenarioInfo path
|
||||
return $ SISingle s si
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Some lenses + prisms
|
||||
------------------------------------------------------------
|
||||
|
||||
makePrisms ''ScenarioItem
|
||||
makePrisms ''ScenarioStatus
|
||||
@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
@ -53,6 +54,7 @@ module Swarm.Game.State (
|
||||
recipesIn,
|
||||
recipesReq,
|
||||
scenarios,
|
||||
currentScenarioPath,
|
||||
knownEntities,
|
||||
world,
|
||||
viewCenterRule,
|
||||
@ -126,6 +128,7 @@ import Data.Set qualified as S
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T (lines)
|
||||
import Data.Text.IO qualified as T (readFile)
|
||||
import Data.Time (getZonedTime)
|
||||
import GHC.Generics (Generic)
|
||||
import Linear
|
||||
import Paths_swarm (getDataFileName)
|
||||
@ -139,7 +142,7 @@ import Swarm.Game.Recipe (
|
||||
reqRecipeMap,
|
||||
)
|
||||
import Swarm.Game.Robot
|
||||
import Swarm.Game.Scenario
|
||||
import Swarm.Game.ScenarioInfo
|
||||
import Swarm.Game.Terrain (TerrainType (..))
|
||||
import Swarm.Game.Value (Value)
|
||||
import Swarm.Game.World (Coords (..), WorldFun (..), locToCoords, worldFunFromArray)
|
||||
@ -274,6 +277,7 @@ data GameState = GameState
|
||||
, _recipesIn :: IntMap [Recipe Entity]
|
||||
, _recipesReq :: IntMap [Recipe Entity]
|
||||
, _scenarios :: ScenarioCollection
|
||||
, _currentScenarioPath :: Maybe FilePath
|
||||
, _knownEntities :: [Text]
|
||||
, _world :: W.World Int Entity
|
||||
, _viewCenterRule :: ViewCenterRule
|
||||
@ -408,6 +412,12 @@ recipesReq :: Lens' GameState (IntMap [Recipe Entity])
|
||||
-- | The collection of scenarios that comes with the game.
|
||||
scenarios :: Lens' GameState ScenarioCollection
|
||||
|
||||
-- | The filepath of the currently running scenario.
|
||||
--
|
||||
-- This is useful as an index to 'scenarios' collection,
|
||||
-- see 'Swarm.Game.ScenarioInfo.scenarioItemByPath'.
|
||||
currentScenarioPath :: Lens' GameState (Maybe FilePath)
|
||||
|
||||
-- | The names of entities that should be considered "known", that is,
|
||||
-- robots know what they are without having to scan them.
|
||||
knownEntities :: Lens' GameState [Text]
|
||||
@ -687,6 +697,7 @@ initGameState = do
|
||||
, _recipesIn = inRecipeMap recipes
|
||||
, _recipesReq = reqRecipeMap recipes
|
||||
, _scenarios = loadedScenarios
|
||||
, _currentScenarioPath = Nothing
|
||||
, _knownEntities = []
|
||||
, _world = W.emptyWorld (fromEnum StoneT)
|
||||
, _viewCenterRule = VCRobot 0
|
||||
@ -818,7 +829,7 @@ buildWorld em (WorldDescription {..}) = (robots, first fromEnum . wf)
|
||||
robots :: [TRobot]
|
||||
robots =
|
||||
area
|
||||
& traversed <.> traversed %@~ (,) -- add (r,c) indices
|
||||
& traversed Control.Lens.<.> traversed %@~ (,) -- add (r,c) indices
|
||||
& concat
|
||||
& mapMaybe
|
||||
( \((fromIntegral -> r, fromIntegral -> c), Cell _ _ robot) ->
|
||||
@ -831,8 +842,14 @@ buildWorld em (WorldDescription {..}) = (robots, first fromEnum . wf)
|
||||
initGameStateForScenario :: String -> Maybe Seed -> Maybe String -> ExceptT Text IO GameState
|
||||
initGameStateForScenario sceneName userSeed toRun = do
|
||||
g <- initGameState
|
||||
scene <- loadScenario sceneName (g ^. entityMap)
|
||||
liftIO $ scenarioToGameState scene userSeed toRun g
|
||||
(scene, path) <- loadScenario sceneName (g ^. entityMap)
|
||||
gs <- liftIO $ scenarioToGameState scene userSeed toRun g
|
||||
normalPath <- liftIO $ normalizeScenarioPath (gs ^. scenarios) path
|
||||
t <- liftIO getZonedTime
|
||||
return $
|
||||
gs
|
||||
& currentScenarioPath ?~ normalPath
|
||||
& scenarios . scenarioItemByPath normalPath . _SISingle . _2 . scenarioStatus .~ InProgress t 0 0
|
||||
|
||||
-- | For convenience, the 'GameState' corresponding to the classic
|
||||
-- game with seed 0.
|
||||
|
||||
@ -38,6 +38,8 @@ module Swarm.TUI.Attr (
|
||||
highlightAttr,
|
||||
notifAttr,
|
||||
infoAttr,
|
||||
boldAttr,
|
||||
cyanAttr,
|
||||
yellowAttr,
|
||||
blueAttr,
|
||||
greenAttr,
|
||||
@ -72,11 +74,13 @@ swarmAttrMap =
|
||||
, (infoAttr, fg (V.rgbColor @Int 50 50 50))
|
||||
, (buttonSelectedAttr, bg V.blue)
|
||||
, (notifAttr, fg V.yellow `V.withStyle` V.bold)
|
||||
, (boldAttr, V.defAttr `V.withStyle` V.bold)
|
||||
, -- Basic colors
|
||||
(redAttr, fg V.red)
|
||||
, (greenAttr, fg V.green)
|
||||
, (blueAttr, fg V.blue)
|
||||
, (yellowAttr, fg V.yellow)
|
||||
, (cyanAttr, fg V.cyan)
|
||||
, -- Default attribute
|
||||
(defAttr, V.defAttr)
|
||||
]
|
||||
@ -143,19 +147,22 @@ plantAttr = worldPrefix <> attrName "plant"
|
||||
highlightAttr
|
||||
, notifAttr
|
||||
, infoAttr
|
||||
, boldAttr
|
||||
, defAttr ::
|
||||
AttrName
|
||||
highlightAttr = attrName "highlight"
|
||||
notifAttr = attrName "notif"
|
||||
infoAttr = attrName "info"
|
||||
boldAttr = attrName "bold"
|
||||
defAttr = attrName "def"
|
||||
|
||||
-- | Some basic colors used in TUI.
|
||||
redAttr, greenAttr, blueAttr, yellowAttr :: AttrName
|
||||
redAttr, greenAttr, blueAttr, yellowAttr, cyanAttr :: AttrName
|
||||
redAttr = attrName "red"
|
||||
greenAttr = attrName "green"
|
||||
blueAttr = attrName "blue"
|
||||
yellowAttr = attrName "yellow"
|
||||
cyanAttr = attrName "cyan"
|
||||
|
||||
instance ToJSON AttrName where
|
||||
toJSON = toJSON . head . attrNameComponents
|
||||
|
||||
@ -59,13 +59,13 @@ import Data.Map qualified as M
|
||||
import Data.Maybe (fromMaybe, isJust, mapMaybe)
|
||||
import Data.Text qualified as T
|
||||
import Data.Text.IO qualified as T
|
||||
import Data.Vector qualified as V
|
||||
import Data.Time (getZonedTime)
|
||||
import Graphics.Vty qualified as V
|
||||
import Linear
|
||||
import Swarm.Game.CESK (cancel, emptyStore, initMachine)
|
||||
import Swarm.Game.Entity hiding (empty)
|
||||
import Swarm.Game.Robot
|
||||
import Swarm.Game.Scenario (Scenario, ScenarioCollection, ScenarioItem (..), objectiveGoal, scMap, scOrder, scenarioCollectionToList, scenarioItemName, _SISingle)
|
||||
import Swarm.Game.ScenarioInfo
|
||||
import Swarm.Game.State
|
||||
import Swarm.Game.Step (gameTick)
|
||||
import Swarm.Game.Value (Value (VUnit), prettyValue)
|
||||
@ -144,10 +144,10 @@ handleMainMenuEvent menu = \case
|
||||
-- Extract the first tutorial challenge and run it
|
||||
let firstTutorial = case scOrder tutorialCollection of
|
||||
Just (t : _) -> case M.lookup t (scMap tutorialCollection) of
|
||||
Just (SISingle scene) -> scene
|
||||
Just (SISingle scene si) -> (scene, si)
|
||||
_ -> error "No first tutorial found!"
|
||||
_ -> error "No first tutorial found!"
|
||||
startGame firstTutorial
|
||||
uncurry startGame firstTutorial Nothing
|
||||
About -> uiState . uiMenu .= AboutMenu
|
||||
Quit -> halt
|
||||
CharKey 'q' -> halt
|
||||
@ -162,22 +162,6 @@ getTutorials sc = case M.lookup "Tutorials" (scMap sc) of
|
||||
Just (SICollection _ c) -> c
|
||||
_ -> error "No tutorials exist!"
|
||||
|
||||
-- | Load a 'Scenario' and start playing the game.
|
||||
startGame :: Scenario -> EventM Name AppState ()
|
||||
startGame scene = do
|
||||
menu <- use $ uiState . uiMenu
|
||||
case menu of
|
||||
NewGameMenu (curMenu :| _) ->
|
||||
let nextMenuList = BL.listMoveDown curMenu
|
||||
isLastScenario = BL.listSelected curMenu == Just (length (BL.listElements curMenu) - 1)
|
||||
nextScenario =
|
||||
if isLastScenario
|
||||
then Nothing
|
||||
else BL.listSelectedElement nextMenuList >>= preview _SISingle . snd
|
||||
in uiState . uiNextScenario .= nextScenario
|
||||
_ -> uiState . uiNextScenario .= Nothing
|
||||
scenarioToAppState scene Nothing Nothing
|
||||
|
||||
-- | If we are in a New Game menu, advance the menu to the next item in order.
|
||||
advanceMenu :: Menu -> Menu
|
||||
advanceMenu = _NewGameMenu . lens NE.head (\(_ :| t) a -> a :| t) %~ BL.listMoveDown
|
||||
@ -187,7 +171,7 @@ handleNewGameMenuEvent scenarioStack@(curMenu :| rest) = \case
|
||||
Key V.KEnter ->
|
||||
case snd <$> BL.listSelectedElement curMenu of
|
||||
Nothing -> continueWithoutRedraw
|
||||
Just (SISingle scene) -> startGame scene
|
||||
Just (SISingle scene si) -> startGame scene si Nothing
|
||||
Just (SICollection _ c) -> do
|
||||
cheat <- use $ uiState . uiCheatMode
|
||||
uiState . uiMenu .= NewGameMenu (NE.cons (mkScenarioList cheat c) scenarioStack)
|
||||
@ -199,11 +183,6 @@ handleNewGameMenuEvent scenarioStack@(curMenu :| rest) = \case
|
||||
uiState . uiMenu .= NewGameMenu (menu' :| rest)
|
||||
_ -> continueWithoutRedraw
|
||||
|
||||
mkScenarioList :: Bool -> ScenarioCollection -> BL.List Name ScenarioItem
|
||||
mkScenarioList cheat = flip (BL.list ScenarioList) 1 . V.fromList . filterTest . scenarioCollectionToList
|
||||
where
|
||||
filterTest = if cheat then id else filter (\case SICollection n _ -> n /= "Testing"; _ -> True)
|
||||
|
||||
exitNewGameMenu :: NonEmpty (BL.List Name ScenarioItem) -> EventM Name AppState ()
|
||||
exitNewGameMenu stk = do
|
||||
uiState . uiMenu
|
||||
@ -367,7 +346,7 @@ handleModalEvent = \case
|
||||
toggleModal QuitModal
|
||||
case dialogSelection <$> mdialog of
|
||||
Just (Just QuitButton) -> quitGame
|
||||
Just (Just (NextButton scene)) -> startGame scene
|
||||
Just (Just (NextButton scene)) -> saveScenarioInfoOnQuit >> uncurry startGame scene Nothing
|
||||
_ -> return ()
|
||||
ev -> do
|
||||
Brick.zoom (uiState . uiModal . _Just . modalDialog) (handleDialogEvent ev)
|
||||
@ -376,13 +355,45 @@ handleModalEvent = \case
|
||||
Just _ -> handleInfoPanelEvent modalScroll (VtyEvent ev)
|
||||
_ -> return ()
|
||||
|
||||
-- | Quit a game. Currently all it does is write out the updated REPL
|
||||
-- history to a @.swarm_history@ file, and return to the previous menu.
|
||||
-- | Write the @ScenarioInfo@ out to disk when exiting a game.
|
||||
saveScenarioInfoOnQuit :: (MonadIO m, MonadState AppState m) => m ()
|
||||
saveScenarioInfoOnQuit = do
|
||||
-- Don't save progress if we are in cheat mode
|
||||
cheat <- use $ uiState . uiCheatMode
|
||||
unless cheat $ do
|
||||
-- the path should be normalized and good to search in scenario collection
|
||||
mp' <- use $ gameState . currentScenarioPath
|
||||
case mp' of
|
||||
Nothing -> return ()
|
||||
Just p' -> do
|
||||
gs <- use $ gameState . scenarios
|
||||
p <- liftIO $ normalizeScenarioPath gs p'
|
||||
t <- liftIO getZonedTime
|
||||
won <- isJust <$> preuse (gameState . winCondition . _Won)
|
||||
ts <- use $ gameState . ticks
|
||||
let currentScenarioInfo :: Traversal' AppState ScenarioInfo
|
||||
currentScenarioInfo = gameState . scenarios . scenarioItemByPath p . _SISingle . _2
|
||||
currentScenarioInfo %= updateScenarioInfoOnQuit t ts won
|
||||
status <- preuse currentScenarioInfo
|
||||
case status of
|
||||
Nothing -> return ()
|
||||
Just si -> liftIO $ saveScenarioInfo p si
|
||||
|
||||
-- rebuild the NewGameMenu so it gets the updated ScenarioInfo
|
||||
sc <- use $ gameState . scenarios
|
||||
forM_ (mkNewGameMenu cheat sc p) (uiState . uiMenu .=)
|
||||
|
||||
-- | Quit a game.
|
||||
--
|
||||
-- * writes out the updated REPL history to a @.swarm_history@ file
|
||||
-- * saves current scenario status (InProgress/Completed)
|
||||
-- * returns to the previous menu
|
||||
quitGame :: EventM Name AppState ()
|
||||
quitGame = do
|
||||
history <- use $ uiState . uiReplHistory
|
||||
let hist = mapMaybe getREPLEntry $ getLatestREPLHistoryItems maxBound history
|
||||
liftIO $ (`T.appendFile` T.unlines hist) =<< getSwarmHistoryPath True
|
||||
saveScenarioInfoOnQuit
|
||||
menu <- use $ uiState . uiMenu
|
||||
case menu of
|
||||
NoMenu -> halt
|
||||
|
||||
@ -27,6 +27,8 @@ module Swarm.TUI.Model (
|
||||
mainMenu,
|
||||
Menu (..),
|
||||
_NewGameMenu,
|
||||
mkScenarioList,
|
||||
mkNewGameMenu,
|
||||
|
||||
-- * UI state
|
||||
|
||||
@ -69,7 +71,6 @@ module Swarm.TUI.Model (
|
||||
uiPort,
|
||||
uiMenu,
|
||||
uiPlaying,
|
||||
uiNextScenario,
|
||||
uiCheatMode,
|
||||
uiFocusRing,
|
||||
uiWorldCursor,
|
||||
@ -120,12 +121,14 @@ module Swarm.TUI.Model (
|
||||
|
||||
-- ** Initialization
|
||||
initAppState,
|
||||
startGame,
|
||||
scenarioToAppState,
|
||||
Seed,
|
||||
|
||||
-- ** Utility
|
||||
focusedItem,
|
||||
focusedEntity,
|
||||
nextScenario,
|
||||
) where
|
||||
|
||||
import Brick
|
||||
@ -141,22 +144,40 @@ import Data.Bits (FiniteBits (finiteBitSize))
|
||||
import Data.Foldable (toList)
|
||||
import Data.List (findIndex, sortOn)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as M
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import Data.Sequence (Seq)
|
||||
import Data.Sequence qualified as Seq
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Data.Time (getZonedTime)
|
||||
import Data.Vector qualified as V
|
||||
import Network.Wai.Handler.Warp (Port)
|
||||
import Swarm.Game.Entity as E
|
||||
import Swarm.Game.Robot
|
||||
import Swarm.Game.Scenario (Scenario, ScenarioItem, loadScenario)
|
||||
import Swarm.Game.Scenario (Scenario, loadScenario)
|
||||
import Swarm.Game.ScenarioInfo (
|
||||
ScenarioCollection,
|
||||
ScenarioInfo (..),
|
||||
ScenarioItem (..),
|
||||
ScenarioStatus (..),
|
||||
normalizeScenarioPath,
|
||||
scMap,
|
||||
scenarioCollectionToList,
|
||||
scenarioItemByPath,
|
||||
scenarioPath,
|
||||
scenarioStatus,
|
||||
_SISingle,
|
||||
)
|
||||
import Swarm.Game.State
|
||||
import Swarm.Game.World qualified as W
|
||||
import Swarm.Language.Types
|
||||
import Swarm.Util
|
||||
import System.Clock
|
||||
import System.FilePath (dropTrailingPathSeparator, splitPath, takeFileName)
|
||||
import Witch (into)
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Custom UI label types
|
||||
@ -406,7 +427,7 @@ data ModalType
|
||||
| GoalModal [Text]
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ButtonSelection = CancelButton | QuitButton | NextButton Scenario
|
||||
data ButtonSelection = CancelButton | QuitButton | NextButton (Scenario, ScenarioInfo)
|
||||
|
||||
data Modal = Modal
|
||||
{ _modalType :: ModalType
|
||||
@ -429,6 +450,33 @@ mainMenu e = BL.list MenuList (V.fromList [minBound .. maxBound]) 1 & BL.listMov
|
||||
|
||||
makePrisms ''Menu
|
||||
|
||||
-- | Create a brick 'BL.List' of scenario items from a 'ScenarioCollection'.
|
||||
mkScenarioList :: Bool -> ScenarioCollection -> BL.List Name ScenarioItem
|
||||
mkScenarioList cheat = flip (BL.list ScenarioList) 1 . V.fromList . filterTest . scenarioCollectionToList
|
||||
where
|
||||
filterTest = if cheat then id else filter (\case SICollection n _ -> n /= "Testing"; _ -> True)
|
||||
|
||||
-- | Given a 'ScenarioCollection' and a 'FilePath' which is the canonical
|
||||
-- path to some folder or scenario, construct a 'NewGameMenu' stack
|
||||
-- focused on the given item, if possible.
|
||||
mkNewGameMenu :: Bool -> ScenarioCollection -> FilePath -> Maybe Menu
|
||||
mkNewGameMenu cheat sc path = NewGameMenu . NE.fromList <$> go (Just sc) (splitPath path) []
|
||||
where
|
||||
go :: Maybe ScenarioCollection -> [FilePath] -> [BL.List Name ScenarioItem] -> Maybe [BL.List Name ScenarioItem]
|
||||
go _ [] stk = Just stk
|
||||
go Nothing _ _ = Nothing
|
||||
go (Just curSC) (thing : rest) stk = go nextSC rest (lst : stk)
|
||||
where
|
||||
hasName :: ScenarioItem -> Bool
|
||||
hasName (SISingle _ (ScenarioInfo pth _ _ _)) = takeFileName pth == thing
|
||||
hasName (SICollection nm _) = nm == into @Text (dropTrailingPathSeparator thing)
|
||||
|
||||
lst = BL.listFindBy hasName (mkScenarioList cheat curSC)
|
||||
|
||||
nextSC = case M.lookup (dropTrailingPathSeparator thing) (scMap curSC) of
|
||||
Just (SICollection _ c) -> Just c
|
||||
_ -> Nothing
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Inventory list entries
|
||||
------------------------------------------------------------
|
||||
@ -456,7 +504,6 @@ data UIState = UIState
|
||||
{ _uiPort :: Maybe Port
|
||||
, _uiMenu :: Menu
|
||||
, _uiPlaying :: Bool
|
||||
, _uiNextScenario :: Maybe Scenario
|
||||
, _uiCheatMode :: Bool
|
||||
, _uiFocusRing :: FocusRing Name
|
||||
, _uiWorldCursor :: Maybe W.Coords
|
||||
@ -515,9 +562,6 @@ uiMenu :: Lens' UIState Menu
|
||||
-- display the current menu.
|
||||
uiPlaying :: Lens' UIState Bool
|
||||
|
||||
-- | The next scenario after the current one, if any.
|
||||
uiNextScenario :: Lens' UIState (Maybe Scenario)
|
||||
|
||||
-- | Cheat mode, i.e. are we allowed to turn creative mode on and off?
|
||||
uiCheatMode :: Lens' UIState Bool
|
||||
|
||||
@ -713,7 +757,6 @@ initUIState showMainMenu cheatMode = liftIO $ do
|
||||
{ _uiPort = Nothing
|
||||
, _uiMenu = if showMainMenu then MainMenu (mainMenu NewGame) else NoMenu
|
||||
, _uiPlaying = not showMainMenu
|
||||
, _uiNextScenario = Nothing
|
||||
, _uiCheatMode = cheatMode
|
||||
, _uiFocusRing = initFocusRing
|
||||
, _uiWorldCursor = Nothing
|
||||
@ -815,8 +858,34 @@ initAppState userSeed scenarioName toRun cheatMode = do
|
||||
case skipMenu of
|
||||
False -> return $ AppState gs ui
|
||||
True -> do
|
||||
scenario <- loadScenario (fromMaybe "classic" scenarioName) (gs ^. entityMap)
|
||||
liftIO $ execStateT (scenarioToAppState scenario userSeed toRun) (AppState gs ui)
|
||||
(scenario, path) <- loadScenario (fromMaybe "classic" scenarioName) (gs ^. entityMap)
|
||||
execStateT
|
||||
(startGame scenario (ScenarioInfo path NotStarted NotStarted NotStarted) toRun)
|
||||
(AppState gs ui)
|
||||
|
||||
-- | Load a 'Scenario' and start playing the game.
|
||||
startGame :: (MonadIO m, MonadState AppState m) => Scenario -> ScenarioInfo -> Maybe FilePath -> m ()
|
||||
startGame scene si toRun = do
|
||||
t <- liftIO getZonedTime
|
||||
ss <- use $ gameState . scenarios
|
||||
p <- liftIO $ normalizeScenarioPath ss (si ^. scenarioPath)
|
||||
gameState . currentScenarioPath .= Just p
|
||||
gameState . scenarios . scenarioItemByPath p . _SISingle . _2 . scenarioStatus .= InProgress t 0 0
|
||||
scenarioToAppState scene Nothing toRun
|
||||
|
||||
-- | Extract the scenario which would come next in the menu from the
|
||||
-- currently selected scenario (if any). Can return @Nothing@ if
|
||||
-- either we are not in the @NewGameMenu@, or the current scenario
|
||||
-- is the last among its siblings.
|
||||
nextScenario :: Menu -> Maybe (Scenario, ScenarioInfo)
|
||||
nextScenario = \case
|
||||
NewGameMenu (curMenu :| _) ->
|
||||
let nextMenuList = BL.listMoveDown curMenu
|
||||
isLastScenario = BL.listSelected curMenu == Just (length (BL.listElements curMenu) - 1)
|
||||
in if isLastScenario
|
||||
then Nothing
|
||||
else BL.listSelectedElement nextMenuList >>= preview _SISingle . snd
|
||||
_ -> Nothing
|
||||
|
||||
-- XXX do we need to keep an old entity map around???
|
||||
|
||||
|
||||
@ -47,10 +47,12 @@ import Brick.Widgets.Dialog
|
||||
import Brick.Widgets.List qualified as BL
|
||||
import Brick.Widgets.Table qualified as BT
|
||||
import Control.Lens hiding (Const, from)
|
||||
import Control.Monad (guard)
|
||||
import Control.Monad.Reader (withReaderT)
|
||||
import Data.Array (range)
|
||||
import Data.Bits (shiftL, shiftR, (.&.))
|
||||
import Data.Foldable qualified as F
|
||||
import Data.Functor (($>))
|
||||
import Data.IntMap qualified as IM
|
||||
import Data.List (intersperse)
|
||||
import Data.List qualified as L
|
||||
@ -64,6 +66,7 @@ import Data.Sequence qualified as Seq
|
||||
import Data.String (fromString)
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Data.Time (NominalDiffTime, defaultTimeLocale, formatTime)
|
||||
import Graphics.Vty qualified as V
|
||||
import Linear
|
||||
import Network.Wai.Handler.Warp (Port)
|
||||
@ -72,7 +75,15 @@ import Swarm.Game.Display
|
||||
import Swarm.Game.Entity as E
|
||||
import Swarm.Game.Recipe
|
||||
import Swarm.Game.Robot
|
||||
import Swarm.Game.Scenario (ScenarioItem (..), scenarioDescription, scenarioItemName, scenarioName)
|
||||
import Swarm.Game.Scenario (scenarioDescription, scenarioName, scenarioObjectives)
|
||||
import Swarm.Game.ScenarioInfo (
|
||||
ScenarioItem (..),
|
||||
ScenarioStatus (..),
|
||||
scenarioBestTicks,
|
||||
scenarioBestTime,
|
||||
scenarioItemName,
|
||||
scenarioStatus,
|
||||
)
|
||||
import Swarm.Game.State
|
||||
import Swarm.Game.Terrain (terrainMap)
|
||||
import Swarm.Game.World qualified as W
|
||||
@ -132,17 +143,43 @@ drawNewGameMenuUI (l :| ls) =
|
||||
. centerLayer
|
||||
$ hBox
|
||||
[ vBox
|
||||
[ withAttr robotAttr . txt $ breadcrumbs ls
|
||||
[ withAttr boldAttr . txt $ breadcrumbs ls
|
||||
, txt " "
|
||||
, vLimit 20 . hLimit 35
|
||||
. BL.renderList (const drawScenarioItem) True
|
||||
. BL.renderList (const $ padRight Max . drawScenarioItem) True
|
||||
$ l
|
||||
]
|
||||
, padLeft (Pad 5) (maybe (txt "") (drawDescription . snd) (BL.listSelectedElement l))
|
||||
]
|
||||
where
|
||||
drawScenarioItem (SISingle s) = padRight Max . txt $ s ^. scenarioName
|
||||
drawScenarioItem (SICollection nm _) = padRight Max (txt nm) <+> withAttr robotAttr (txt ">")
|
||||
drawScenarioItem (SISingle s si) = padRight (Pad 1) (drawStatusInfo s si) <+> txt (s ^. scenarioName)
|
||||
drawScenarioItem (SICollection nm _) = padRight (Pad 1) (withAttr boldAttr $ txt " > ") <+> txt nm
|
||||
drawStatusInfo s si = case si ^. scenarioBestTime of
|
||||
NotStarted -> txt " ○ "
|
||||
InProgress {} -> case s ^. scenarioObjectives of
|
||||
[] -> withAttr cyanAttr $ txt " ◉ "
|
||||
_ -> withAttr yellowAttr $ txt " ◎ "
|
||||
Complete {} -> withAttr greenAttr $ txt " ● "
|
||||
|
||||
describeStatus = \case
|
||||
NotStarted -> txt "none"
|
||||
InProgress _s e _t ->
|
||||
withAttr yellowAttr . vBox $
|
||||
[ txt "in progress"
|
||||
, txt $ "(played for " <> formatTimeDiff e <> ")"
|
||||
]
|
||||
Complete _s e t ->
|
||||
withAttr greenAttr . vBox $
|
||||
[ txt $ "completed in " <> formatTimeDiff e
|
||||
, hBox
|
||||
[ txt "("
|
||||
, drawTime t True
|
||||
, txt " ticks)"
|
||||
]
|
||||
]
|
||||
|
||||
formatTimeDiff :: NominalDiffTime -> Text
|
||||
formatTimeDiff = T.pack . formatTime defaultTimeLocale "%hh %mm %ss"
|
||||
|
||||
breadcrumbs :: [BL.List Name ScenarioItem] -> Text
|
||||
breadcrumbs =
|
||||
@ -152,8 +189,24 @@ drawNewGameMenuUI (l :| ls) =
|
||||
. mapMaybe (fmap (scenarioItemName . snd) . BL.listSelectedElement)
|
||||
|
||||
drawDescription :: ScenarioItem -> Widget Name
|
||||
drawDescription (SISingle s) = txtWrap (nonBlank (s ^. scenarioDescription))
|
||||
drawDescription (SICollection _ _) = txtWrap " "
|
||||
drawDescription (SISingle s si) = do
|
||||
let oneBest = si ^. scenarioBestTime == si ^. scenarioBestTicks
|
||||
let bestRealTime = if oneBest then "best:" else "best real time:"
|
||||
let noSame = if oneBest then const Nothing else Just
|
||||
let lastText = let la = "last:" in padRight (Pad $ T.length bestRealTime - T.length la) (txt la)
|
||||
vBox . catMaybes $
|
||||
[ Just $ txtWrap (nonBlank (s ^. scenarioDescription))
|
||||
, Just $
|
||||
padTop (Pad 3) $
|
||||
padRight (Pad 1) (txt bestRealTime) <+> describeStatus (si ^. scenarioBestTime)
|
||||
, noSame $ -- hide best game time if it is same as best real time
|
||||
padTop (Pad 1) $
|
||||
padRight (Pad 1) (txt "best game time:") <+> describeStatus (si ^. scenarioBestTicks)
|
||||
, Just $
|
||||
padTop (Pad 1) $
|
||||
padRight (Pad 1) lastText <+> describeStatus (si ^. scenarioStatus)
|
||||
]
|
||||
|
||||
nonBlank "" = " "
|
||||
nonBlank t = t
|
||||
@ -239,15 +292,27 @@ drawWorldCursorInfo :: GameState -> W.Coords -> Widget Name
|
||||
drawWorldCursorInfo g i@(W.Coords (y, x)) =
|
||||
hBox [drawLoc g i, txt $ " at " <> from (show x) <> " " <> from (show (y * (-1)))]
|
||||
|
||||
-- | Format the clock display to be shown in the upper right of the
|
||||
-- world panel.
|
||||
drawClockDisplay :: GameState -> Widget n
|
||||
drawClockDisplay gs = hBox . intersperse (txt " ") $ catMaybes [clockWidget, pauseWidget]
|
||||
where
|
||||
clockWidget = drawTime (gs ^. ticks) (gs ^. paused) gs
|
||||
pauseWidget = if gs ^. paused then Just $ txt "(PAUSED)" else Nothing
|
||||
clockWidget = maybeDrawTime (gs ^. ticks) (gs ^. paused) gs
|
||||
pauseWidget = guard (gs ^. paused) $> txt "(PAUSED)"
|
||||
|
||||
drawTime :: Integer -> Bool -> GameState -> Maybe (Widget n)
|
||||
drawTime t showTicks gs =
|
||||
justClock . str . mconcat $
|
||||
-- | Check whether the currently focused robot (if any) has a clock
|
||||
-- device installed.
|
||||
clockInstalled :: GameState -> Bool
|
||||
clockInstalled gs = case focusedRobot gs of
|
||||
Nothing -> False
|
||||
Just r
|
||||
| countByName "clock" (r ^. installedDevices) > 0 -> True
|
||||
| otherwise -> False
|
||||
|
||||
-- | Format a ticks count as a hexadecimal clock.
|
||||
drawTime :: Integer -> Bool -> Widget n
|
||||
drawTime t showTicks =
|
||||
str . mconcat $
|
||||
[ printf "%x" (t `shiftR` 20)
|
||||
, ":"
|
||||
, printf "%02x" ((t `shiftR` 12) .&. ((1 `shiftL` 8) - 1))
|
||||
@ -255,13 +320,14 @@ drawTime t showTicks gs =
|
||||
, printf "%02x" ((t `shiftR` 4) .&. ((1 `shiftL` 8) - 1))
|
||||
]
|
||||
++ if showTicks then [".", printf "%x" (t .&. ((1 `shiftL` 4) - 1))] else []
|
||||
where
|
||||
justClock = if clockInstalled then Just else const Nothing
|
||||
clockInstalled = case focusedRobot gs of
|
||||
Nothing -> False
|
||||
Just r
|
||||
| countByName "clock" (r ^. installedDevices) > 0 -> True
|
||||
| otherwise -> False
|
||||
|
||||
-- | Return a possible time display, if the currently focused robot
|
||||
-- has a clock device installed. The first argument is the number
|
||||
-- of ticks (e.g. 943 = 0x3af), and the second argument indicates
|
||||
-- whether the time should be shown down to single-tick resolution
|
||||
-- (e.g. 0:00:3a.f) or not (e.g. 0:00:3a).
|
||||
maybeDrawTime :: Integer -> Bool -> GameState -> Maybe (Widget n)
|
||||
maybeDrawTime t showTicks gs = guard (clockInstalled gs) $> drawTime t showTicks
|
||||
|
||||
-- | Render the type of the current REPL input to be shown to the user.
|
||||
drawType :: Polytype -> Widget Name
|
||||
@ -375,10 +441,12 @@ generateModal s mt = Modal mt (dialog (Just title) buttons (maxModalWindowWidth
|
||||
in ( ""
|
||||
, Just
|
||||
( 0
|
||||
, [(nextMsg, NextButton scene) | Just scene <- [s ^. uiState . uiNextScenario]]
|
||||
++ [ (stopMsg, QuitButton)
|
||||
, (continueMsg, CancelButton)
|
||||
]
|
||||
, [ (nextMsg, NextButton scene)
|
||||
| Just scene <- [nextScenario (s ^. uiState . uiMenu)]
|
||||
]
|
||||
++ [ (stopMsg, QuitButton)
|
||||
, (continueMsg, CancelButton)
|
||||
]
|
||||
)
|
||||
, sum (map length [nextMsg, stopMsg, continueMsg]) + 32
|
||||
)
|
||||
@ -575,7 +643,7 @@ messagesWidget gs = widgetList
|
||||
drawLogEntry' e =
|
||||
withAttr (colorLogs e) $
|
||||
hBox
|
||||
[ fromMaybe (txt "") $ drawTime (e ^. leTime) True gs
|
||||
[ fromMaybe (txt "") $ maybeDrawTime (e ^. leTime) True gs
|
||||
, padLeft (Pad 2) . txt $ "[" <> e ^. leRobotName <> "]"
|
||||
, padLeft (Pad 1) . txt2 $ e ^. leText
|
||||
]
|
||||
|
||||
@ -25,6 +25,7 @@ module Swarm.Util (
|
||||
readFileMay,
|
||||
readFileMayT,
|
||||
getSwarmDataPath,
|
||||
getSwarmSavePath,
|
||||
getSwarmHistoryPath,
|
||||
readAppData,
|
||||
|
||||
@ -217,6 +218,14 @@ getSwarmDataPath createDirs = do
|
||||
when createDirs (createDirectoryIfMissing True swarmData)
|
||||
pure swarmData
|
||||
|
||||
-- | Get path to swarm saves, optionally creating necessary
|
||||
-- directories.
|
||||
getSwarmSavePath :: Bool -> IO FilePath
|
||||
getSwarmSavePath createDirs = do
|
||||
swarmSave <- getXdgDirectory XdgData ("swarm" </> "saves")
|
||||
when createDirs (createDirectoryIfMissing True swarmSave)
|
||||
pure swarmSave
|
||||
|
||||
-- | Get path to swarm history, optionally creating necessary
|
||||
-- directories. This could fail if user has bad permissions
|
||||
-- on his own $HOME or $XDG_DATA_HOME which is unlikely.
|
||||
|
||||
@ -96,6 +96,7 @@ library
|
||||
Swarm.Language.Pipeline.QQ
|
||||
Swarm.Game.CESK
|
||||
Swarm.Game.Scenario
|
||||
Swarm.Game.ScenarioInfo
|
||||
Swarm.Game.Display
|
||||
Swarm.Game.Entity
|
||||
Swarm.Game.Exception
|
||||
@ -154,6 +155,7 @@ library
|
||||
syb >= 0.7 && < 0.8,
|
||||
template-haskell >= 2.16 && < 2.19,
|
||||
text >= 1.2.4 && < 2.1,
|
||||
time >= 1.9 && < 1.14,
|
||||
unification-fd >= 0.11 && < 0.12,
|
||||
unordered-containers >= 0.2.14 && < 0.3,
|
||||
vector >= 0.12 && < 0.13,
|
||||
|
||||
Loading…
Reference in New Issue
Block a user