feat(gs/xanthous): Default to the current save file

When saving, default to the save file that was loaded for the game if
any. To support this, this also makes text prompts support a default,
which will be used if no value is input.

Change-Id: I72a826499d6e987b939e3465a2d29167e53416be
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3801
Reviewed-by: grfn <grfn@gws.fyi>
Tested-by: BuildkiteCI
This commit is contained in:
Griffin Smith 2021-11-06 11:44:14 -04:00 committed by grfn
parent 099f36e5ee
commit ff6c008d78
8 changed files with 93 additions and 31 deletions

View file

@ -113,9 +113,9 @@ newGame rparams = do
loadGame :: FilePath -> IO ()
loadGame saveFile = do
gameState <- maybe (die "Invalid save file!") pure
=<< Game.loadGame . fromStrict <$> readFile @IO saveFile
gameState `deepseq` runGame LoadGame gameState
gameState <- maybe (die "Invalid save file!") pure . Game.loadGame . fromStrict
=<< readFile @IO saveFile
gameState `deepseq` runGame (LoadGame saveFile) gameState
runGame :: RunType -> Game.GameState -> IO ()
runGame rt gameState = do

View file

@ -73,7 +73,7 @@ import qualified Xanthous.Generators.Level.Dungeon as Dungeon
type App = Brick.App GameState AppEvent ResourceName
data RunType = NewGame | LoadGame
data RunType = NewGame | LoadGame FilePath
deriving stock (Eq)
makeApp :: GameEnv -> RunType -> IO App
@ -83,7 +83,7 @@ makeApp env rt = pure $ Brick.App
, appHandleEvent = \game event -> runAppM (handleEvent event) env game
, appStartEvent = case rt of
NewGame -> runAppM (startEvent >> get) env
LoadGame -> pure
LoadGame save -> pure . (savefile ?~ save)
, appAttrMap = const $ attrMap defAttr []
}
@ -334,15 +334,24 @@ handleCommand Fire = do
handleCommand Save = do
-- TODO default save locations / config file?
prompt_ @'StringPrompt ["save", "location"] Cancellable
$ \(StringResult filename) -> do
exists <- liftIO . doesFileExist $ unpack filename
if exists
then confirm ["save", "overwrite"] (object ["filename" A..= filename])
$ doSave filename
else doSave filename
use savefile >>= \case
Just filepath ->
stringPromptWithDefault_
["save", "location"]
Cancellable
(pack filepath)
promptCallback
Nothing -> prompt_ @'StringPrompt ["save", "location"] Cancellable promptCallback
continue
where
promptCallback :: PromptResult 'StringPrompt -> AppM ()
promptCallback (StringResult filename) = do
sf <- use savefile
exists <- liftIO . doesFileExist $ unpack filename
if exists && sf /= Just (unpack filename)
then confirm ["save", "overwrite"] (object ["filename" A..= filename])
$ doSave filename
else doSave filename
doSave filename = do
src <- gets saveGame
lift . liftIO $ do

View file

@ -5,6 +5,8 @@ module Xanthous.App.Prompt
, clearPrompt
, prompt
, prompt_
, stringPromptWithDefault
, stringPromptWithDefault_
, confirm_
, confirm
, menu
@ -123,7 +125,7 @@ prompt msgPath params cancellable cb = do
SPointOnMap -> do
charPos <- use characterPosition
pure . Just $ mkPointOnMapPrompt cancellable charPos cb
SStringPrompt -> pure . Just $ mkPrompt cancellable pt cb
SStringPrompt -> pure . Just $ mkStringPrompt cancellable cb
SConfirm -> pure . Just $ mkPrompt cancellable pt cb
SDirectionPrompt -> pure . Just $ mkPrompt cancellable pt cb
SContinue -> pure . Just $ mkPrompt cancellable pt cb
@ -138,6 +140,27 @@ prompt_
-> AppM ()
prompt_ msg = prompt msg $ object []
stringPromptWithDefault
:: forall (params :: Type). (ToJSON params)
=> [Text] -- ^ Message key
-> params -- ^ Message params
-> PromptCancellable
-> Text -- ^ Prompt default
-> (PromptResult 'StringPrompt -> AppM ()) -- ^ Prompt promise handler
-> AppM ()
stringPromptWithDefault msgPath params cancellable def cb = do
msg <- Messages.message msgPath params
let p = mkStringPromptWithDefault cancellable def cb
promptState .= WaitingPrompt msg p
stringPromptWithDefault_
:: [Text] -- ^ Message key
-> PromptCancellable
-> Text -- ^ Prompt default
-> (PromptResult 'StringPrompt -> AppM ()) -- ^ Prompt promise handler
-> AppM ()
stringPromptWithDefault_ msg = stringPromptWithDefault msg $ object []
confirm
:: ToJSON params
=> [Text] -- ^ Message key

View file

@ -43,6 +43,7 @@ instance Arbitrary GameState where
_debugState <- arbitrary
let _autocommand = NoAutocommand
_memo <- arbitrary
_savefile <- arbitrary
pure $ GameState {..}

View file

@ -43,8 +43,12 @@ drawPromptState :: GamePromptState m -> Widget ResourceName
drawPromptState NoPrompt = emptyWidget
drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) =
case (pt, ps, pri) of
(SStringPrompt, StringPromptState edit, _) ->
txtWrap msg <+> txt " " <+> renderEditor (txt . fold) True edit
(SStringPrompt, StringPromptState edit, mDef) ->
txtWrap msg
<+> txt " "
<+> txt (maybe "" (\def -> "(default: " <> def <> ")") mDef)
<+> txt " "
<+> renderEditor (txt . fold) True edit
(SDirectionPrompt, DirectionPromptState, _) -> txtWrap msg
(SMenu, _, menuItems) ->
txtWrap msg

View file

@ -65,6 +65,7 @@ initialStateFromSeed seed =
_debugState = DebugState
{ _allRevealed = False
}
_savefile = Nothing
_autocommand = NoAutocommand
_memo = emptyMemoState
in GameState {..}

View file

@ -16,6 +16,8 @@ module Xanthous.Game.Prompt
, PromptInput
, Prompt(..)
, mkPrompt
, mkStringPrompt
, mkStringPromptWithDefault
, mkMenu
, mkPointOnMapPrompt
, mkFirePrompt
@ -215,9 +217,10 @@ instance Show (MenuOption a) where
show (MenuOption m _) = show m
type family PromptInput (pt :: PromptType) :: Type where
PromptInput ('Menu a) = Map Char (MenuOption a)
PromptInput 'PointOnMap = Position -- Character pos
PromptInput 'Fire = (Position, Tiles) -- Nearest enemy, range
PromptInput ('Menu a) = Map Char (MenuOption a)
PromptInput 'PointOnMap = Position -- Character pos
PromptInput 'Fire = (Position, Tiles) -- Nearest enemy, range
PromptInput 'StringPrompt = Maybe Text -- Default value
PromptInput _ = ()
data Prompt (m :: Type -> Type) where
@ -286,13 +289,27 @@ mkPrompt
-> SPromptType pt -- ^ The type of the prompt
-> (PromptResult pt -> m ()) -- ^ Function to call when the prompt is complete
-> Prompt m
mkPrompt c pt@SStringPrompt cb =
let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
in Prompt c pt ps () cb
mkPrompt c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState () cb
mkPrompt c pt@SContinue cb = Prompt c pt ContinuePromptState () cb
mkPrompt c pt@SConfirm cb = Prompt c pt ConfirmPromptState () cb
mkStringPrompt
:: PromptCancellable -- ^ Is the prompt cancellable or not?
-> (PromptResult 'StringPrompt -> m ()) -- ^ Function to call when the prompt is complete
-> Prompt m
mkStringPrompt c =
let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
in Prompt c SStringPrompt ps Nothing
mkStringPromptWithDefault
:: PromptCancellable -- ^ Is the prompt cancellable or not?
-> Text -- ^ Default value for the prompt
-> (PromptResult 'StringPrompt -> m ()) -- ^ Function to call when the prompt is complete
-> Prompt m
mkStringPromptWithDefault c def =
let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
in Prompt c SStringPrompt ps (Just def)
mkMenu
:: forall a m.
PromptCancellable
@ -321,19 +338,22 @@ isCancellable (Prompt Cancellable _ _ _ _) = True
isCancellable (Prompt Uncancellable _ _ _ _) = False
submitPrompt :: Applicative m => Prompt m -> m ()
submitPrompt (Prompt _ pt ps _ cb) =
case (pt, ps) of
(SStringPrompt, StringPromptState edit) ->
cb . StringResult . mconcat . getEditContents $ edit
(SDirectionPrompt, DirectionPromptState) ->
submitPrompt (Prompt _ pt ps pri cb) =
case (pt, ps, pri) of
(SStringPrompt, StringPromptState edit, mDef) ->
let inputVal = mconcat . getEditContents $ edit
val | null inputVal, Just def <- mDef = def
| otherwise = inputVal
in cb $ StringResult val
(SDirectionPrompt, DirectionPromptState, _) ->
pure () -- Don't use submit with a direction prompt
(SContinue, ContinuePromptState) ->
(SContinue, ContinuePromptState, _) ->
cb ContinueResult
(SMenu, MenuPromptState) ->
(SMenu, MenuPromptState, _) ->
pure () -- Don't use submit with a menu prompt
(SPointOnMap, PointOnMapPromptState pos) ->
(SPointOnMap, PointOnMapPromptState pos, _) ->
cb $ PointOnMapResult pos
(SConfirm, ConfirmPromptState) ->
(SConfirm, ConfirmPromptState, _) ->
cb $ ConfirmResult True
(SFire, FirePromptState pos) ->
(SFire, FirePromptState pos, _) ->
cb $ FireResult pos

View file

@ -16,6 +16,7 @@ module Xanthous.Game.State
, promptState
, characterEntityID
, autocommand
, savefile
, memo
, GamePromptState(..)
@ -512,6 +513,9 @@ data GameState = GameState
, _debugState :: !DebugState
, _autocommand :: !AutocommandState
-- | The path to the savefile that was loaded for this game, if any
, _savefile :: !(Maybe FilePath)
, _memo :: MemoState
}
deriving stock (Show, Generic)