LambdaHack-0.11.0.1: engine-src/Game/LambdaHack/Client/UI/HandleHumanGlobalM.hs
-- | Semantics of "Game.LambdaHack.Client.UI.HumanCmd"
-- client commands that return server requests.
-- A couple of them do not take time, the rest does.
-- Here prompts and menus are displayed, but any feedback resulting
-- from the commands (e.g., from inventory manipulation) is generated later on,
-- by the server, for all clients that witness the results of the commands.
module Game.LambdaHack.Client.UI.HandleHumanGlobalM
( -- * Meta commands
byAreaHuman, byAimModeHuman
, composeIfLocalHuman, composeUnlessErrorHuman, compose2ndLocalHuman
, loopOnNothingHuman, executeIfClearHuman
-- * Global commands that usually take time
, waitHuman, waitHuman10, yellHuman, moveRunHuman
, runOnceAheadHuman, moveOnceToXhairHuman
, runOnceToXhairHuman, continueToXhairHuman
, moveItemHuman, projectHuman, applyHuman
, alterDirHuman, alterWithPointerHuman, closeDirHuman
, helpHuman, hintHuman, dashboardHuman, itemMenuHuman, chooseItemMenuHuman
, mainMenuHuman, mainMenuAutoOnHuman, mainMenuAutoOffHuman
, settingsMenuHuman, challengeMenuHuman, gameDifficultyIncr
, gameFishToggle, gameGoodsToggle, gameWolfToggle, gameKeeperToggle
, gameScenarioIncr
-- * Global commands that never take time
, gameExitWithHuman, ExitStrategy(..), gameDropHuman, gameExitHuman
, gameSaveHuman, doctrineHuman, automateHuman, automateToggleHuman
, automateBackHuman
#ifdef EXPOSE_INTERNAL
-- * Internal operations
, areaToRectangles, meleeAid, displaceAid, moveSearchAlter, alterCommon
, goToXhair, goToXhairExplorationMode, goToXhairGoTo
, multiActorGoTo, moveOrSelectItem, selectItemsToMove, moveItems
, projectItem, applyItem, alterTileAtPos, verifyAlters, processTileActions
, verifyEscape, verifyToolEffect, closeTileAtPos, msgAddDone, pickPoint
, generateMenu
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import qualified Data.Char as Char
import Data.Either
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import Data.Version
import qualified NLP.Miniutter.English as MU
import Game.LambdaHack.Client.Bfs
import Game.LambdaHack.Client.BfsM
import Game.LambdaHack.Client.CommonM
import Game.LambdaHack.Client.MonadClient
import Game.LambdaHack.Client.Request
import Game.LambdaHack.Client.State
import Game.LambdaHack.Client.UI.ActorUI
import Game.LambdaHack.Client.UI.Content.Input
import Game.LambdaHack.Client.UI.Content.Screen
import Game.LambdaHack.Client.UI.ContentClientUI
import Game.LambdaHack.Client.UI.Frame
import Game.LambdaHack.Client.UI.FrameM
import Game.LambdaHack.Client.UI.HandleHelperM
import Game.LambdaHack.Client.UI.HandleHumanLocalM
import Game.LambdaHack.Client.UI.HumanCmd
import Game.LambdaHack.Client.UI.InventoryM
import Game.LambdaHack.Client.UI.ItemDescription
import qualified Game.LambdaHack.Client.UI.Key as K
import Game.LambdaHack.Client.UI.KeyBindings
import Game.LambdaHack.Client.UI.MonadClientUI
import Game.LambdaHack.Client.UI.Msg
import Game.LambdaHack.Client.UI.MsgM
import Game.LambdaHack.Client.UI.Overlay
import Game.LambdaHack.Client.UI.PointUI
import Game.LambdaHack.Client.UI.RunM
import Game.LambdaHack.Client.UI.SessionUI
import Game.LambdaHack.Client.UI.Slideshow
import Game.LambdaHack.Client.UI.SlideshowM
import Game.LambdaHack.Client.UI.UIOptions
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Area
import Game.LambdaHack.Common.ClientOptions
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.ItemAspect as IA
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.ReqFailure
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Common.Vector
import qualified Game.LambdaHack.Content.FactionKind as FK
import qualified Game.LambdaHack.Content.ItemKind as IK
import qualified Game.LambdaHack.Content.ModeKind as MK
import Game.LambdaHack.Content.RuleKind
import qualified Game.LambdaHack.Content.TileKind as TK
import qualified Game.LambdaHack.Core.Dice as Dice
import Game.LambdaHack.Core.Random
import qualified Game.LambdaHack.Definition.Ability as Ability
import qualified Game.LambdaHack.Definition.Color as Color
import Game.LambdaHack.Definition.Defs
import qualified Game.LambdaHack.Definition.DefsInternal as DefsInternal
-- * ByArea
-- | Pick command depending on area the mouse pointer is in.
-- The first matching area is chosen. If none match, only interrupt.
byAreaHuman :: MonadClientUI m
=> (K.KM -> HumanCmd -> m (Either MError ReqUI))
-> [(CmdArea, HumanCmd)]
-> m (Either MError ReqUI)
byAreaHuman cmdSemInCxtOfKM l = do
CCUI{coinput=InputContent{brevMap}} <- getsSession sccui
pUI <- getsSession spointer
let PointSquare px py = uiToSquare pUI
p = Point {..} -- abuse of convention: @Point@, not @PointSquare@ used
-- for the whole UI screen in square font coordinates
pointerInArea a = do
rs <- areaToRectangles a
return $! any (`inside` p) $ catMaybes rs
cmds <- filterM (pointerInArea . fst) l
case cmds of
[] -> do
stopPlayBack
return $ Left Nothing
(_, cmd) : _ -> do
let kmFound = case M.lookup cmd brevMap of
Just (km : _) -> km
_ -> K.escKM
cmdSemInCxtOfKM kmFound cmd
-- Many values here are shared with "Game.LambdaHack.Client.UI.DrawM".
areaToRectangles :: MonadClientUI m => CmdArea -> m [Maybe Area]
areaToRectangles ca = map toArea <$> do
CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui
case ca of
CaMessage -> return [(0, 0, rwidth - 1, 0)]
CaMapLeader -> do -- takes preference over @CaMapParty@ and @CaMap@
mleader <- getsClient sleader
case mleader of
Nothing -> return []
Just leader -> do
b <- getsState $ getActorBody leader
let PointSquare x y = mapToSquare $ bpos b
return [(x, y, x, y)]
CaMapParty -> do -- takes preference over @CaMap@
lidV <- viewedLevelUI
side <- getsClient sside
ours <- getsState $ filter (not . bproj) . map snd
. actorAssocs (== side) lidV
let rectFromB p = let PointSquare x y = mapToSquare p
in (x, y, x, y)
return $! map (rectFromB . bpos) ours
CaMap ->
let PointSquare xo yo = mapToSquare originPoint
PointSquare xe ye = mapToSquare $ Point (rwidth - 1) (rheight - 4)
in return [(xo, yo, xe, ye)]
CaLevelNumber -> let y = rheight - 2
in return [(0, y, 1, y)]
CaArenaName -> let y = rheight - 2
x = (rwidth - 1) `div` 2 - 11
in return [(3, y, x, y)]
CaPercentSeen -> let y = rheight - 2
x = (rwidth - 1) `div` 2
in return [(x - 9, y, x, y)]
CaXhairDesc -> let y = rheight - 2
x = (rwidth - 1) `div` 2 + 2
in return [(x, y, rwidth - 1, y)]
CaSelected -> let y = rheight - 1
x = (rwidth - 1) `div` 2
in return [(0, y, x - 24, y)]
CaCalmGauge -> let y = rheight - 1
x = (rwidth - 1) `div` 2
in return [(x - 22, y, x - 18, y)]
CaCalmValue -> let y = rheight - 1
x = (rwidth - 1) `div` 2
in return [(x - 17, y, x - 11, y)]
CaHPGauge -> let y = rheight - 1
x = (rwidth - 1) `div` 2
in return [(x - 9, y, x - 6, y)]
CaHPValue -> let y = rheight - 1
x = (rwidth - 1) `div` 2
in return [(x - 6, y, x, y)]
CaLeaderDesc -> let y = rheight - 1
x = (rwidth - 1) `div` 2 + 2
in return [(x, y, rwidth - 1, y)]
-- * ByAimMode
byAimModeHuman :: MonadClientUI m
=> m (Either MError ReqUI) -> m (Either MError ReqUI)
-> m (Either MError ReqUI)
byAimModeHuman cmdNotAimingM cmdAimingM = do
aimMode <- getsSession saimMode
if isNothing aimMode then cmdNotAimingM else cmdAimingM
-- * ComposeIfLocal
composeIfLocalHuman :: MonadClientUI m
=> m (Either MError ReqUI) -> m (Either MError ReqUI)
-> m (Either MError ReqUI)
composeIfLocalHuman c1 c2 = do
slideOrCmd1 <- c1
case slideOrCmd1 of
Left merr1 -> do
slideOrCmd2 <- c2
case slideOrCmd2 of
Left merr2 -> return $ Left $ mergeMError merr1 merr2
_ -> return slideOrCmd2
_ -> return slideOrCmd1
-- * ComposeUnlessError
composeUnlessErrorHuman :: MonadClientUI m
=> m (Either MError ReqUI) -> m (Either MError ReqUI)
-> m (Either MError ReqUI)
composeUnlessErrorHuman c1 c2 = do
slideOrCmd1 <- c1
case slideOrCmd1 of
Left Nothing -> c2
_ -> return slideOrCmd1
-- * Compose2ndLocal
compose2ndLocalHuman :: MonadClientUI m
=> m (Either MError ReqUI) -> m (Either MError ReqUI)
-> m (Either MError ReqUI)
compose2ndLocalHuman c1 c2 = do
slideOrCmd1 <- c1
case slideOrCmd1 of
Left merr1 -> do
slideOrCmd2 <- c2
case slideOrCmd2 of
Left merr2 -> return $ Left $ mergeMError merr1 merr2
_ -> return slideOrCmd1 -- ignore second request, keep effect
req -> do
void c2 -- ignore second request, keep effect
return req
-- * LoopOnNothing
loopOnNothingHuman :: MonadClientUI m
=> m (Either MError ReqUI)
-> m (Either MError ReqUI)
loopOnNothingHuman cmd = do
res <- cmd
case res of
Left Nothing -> loopOnNothingHuman cmd
_ -> return res
-- * ExecuteIfClear
executeIfClearHuman :: MonadClientUI m
=> m (Either MError ReqUI)
-> m (Either MError ReqUI)
executeIfClearHuman c1 = do
sreportNull <- getsSession sreportNull
sreqDelay <- getsSession sreqDelay
-- When server query delay is handled, don't complicate things by clearing
-- screen instead of running the command.
if sreportNull || sreqDelay == ReqDelayHandled
then c1
else return $ Left Nothing
-- * Wait
-- | Leader waits a turn (and blocks, etc.).
waitHuman :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)
waitHuman leader = do
actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
if Ability.getSk Ability.SkWait actorCurAndMaxSk > 0 then do
modifySession $ \sess -> sess {swaitTimes = abs (swaitTimes sess) + 1}
return $ Right ReqWait
else failSer WaitUnskilled
-- * Wait10
-- | Leader waits a 1/10th of a turn (and doesn't block, etc.).
waitHuman10 :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)
waitHuman10 leader = do
actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
if Ability.getSk Ability.SkWait actorCurAndMaxSk >= 4 then do
modifySession $ \sess -> sess {swaitTimes = abs (swaitTimes sess) + 1}
return $ Right ReqWait10
else failSer WaitUnskilled
-- * Yell
-- | Leader yells or yawns, if sleeping.
yellHuman :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)
yellHuman leader = do
actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
if Ability.getSk Ability.SkWait actorCurAndMaxSk > 0
-- If waiting drained and really, potentially, no other possible action,
-- still allow yelling.
|| Ability.getSk Ability.SkMove actorCurAndMaxSk <= 0
|| Ability.getSk Ability.SkDisplace actorCurAndMaxSk <= 0
|| Ability.getSk Ability.SkMelee actorCurAndMaxSk <= 0
then return $ Right ReqYell
else failSer WaitUnskilled
-- * MoveDir and RunDir
moveRunHuman :: (MonadClient m, MonadClientUI m)
=> ActorId -> Bool -> Bool -> Bool -> Bool -> Vector
-> m (FailOrCmd RequestTimed)
moveRunHuman leader initialStep finalGoal run runAhead dir = do
actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
arena <- getArenaUI
sb <- getsState $ getActorBody leader
fact <- getsState $ (EM.! bfid sb) . sfactionD
-- Start running in the given direction. The first turn of running
-- succeeds much more often than subsequent turns, because we ignore
-- most of the disturbances, since the player is mostly aware of them
-- and still explicitly requests a run, knowing how it behaves.
sel <- getsSession sselected
let runMembers = if runAhead || noRunWithMulti fact
then [leader]
else ES.elems (ES.delete leader sel) ++ [leader]
runParams = RunParams { runLeader = leader
, runMembers
, runInitial = True
, runStopMsg = Nothing
, runWaiting = 0 }
initRunning = when (initialStep && run) $ do
modifySession $ \sess ->
sess {srunning = Just runParams}
when runAhead $ macroHuman macroRun25
-- When running, the invisible actor is hit (not displaced!),
-- so that running in the presence of roving invisible
-- actors is equivalent to moving (with visible actors
-- this is not a problem, since runnning stops early enough).
let tpos = bpos sb `shift` dir
-- We start by checking actors at the target position,
-- which gives a partial information (actors can be invisible),
-- as opposed to accessibility (and items) which are always accurate
-- (tiles can't be invisible).
tgts <- getsState $ posToAidAssocs tpos arena
case tgts of
[] -> do -- move or search or alter
runStopOrCmd <- moveSearchAlter leader run dir
case runStopOrCmd of
Left stopMsg -> return $ Left stopMsg
Right runCmd -> do
-- Don't check @initialStep@ and @finalGoal@
-- and don't stop going to target: door opening is mundane enough.
initRunning
return $ Right runCmd
[(target, _)] | run
&& initialStep
&& Ability.getSk Ability.SkDisplace actorCurAndMaxSk > 0 ->
-- No @stopPlayBack@: initial displace is benign enough.
-- Displacing requires accessibility, but it's checked later on.
displaceAid leader target
_ : _ : _ | run
&& initialStep
&& Ability.getSk Ability.SkDisplace actorCurAndMaxSk > 0 ->
failSer DisplaceMultiple
(target, tb) : _ | not run
&& initialStep && finalGoal
&& bfid tb == bfid sb && not (bproj tb) -> do
stopPlayBack -- don't ever auto-repeat leader choice
-- We always see actors from our own faction.
-- Select one of adjacent actors by bumping into him. Takes no time.
success <- pickLeader True target
let !_A = assert (success `blame` "bump self"
`swith` (leader, target, tb)) ()
failWith "the pointman switched by bumping"
(target, tb) : _ | not run
&& initialStep && finalGoal
&& (bfid tb /= bfid sb || bproj tb) -> do
stopPlayBack -- don't ever auto-repeat melee
if Ability.getSk Ability.SkMelee actorCurAndMaxSk > 0
then -- No problem if there are many projectiles at the spot. We just
-- attack the first one.
meleeAid leader target
else failSer MeleeUnskilled
_ : _ -> failWith "actor in the way"
-- | Actor attacks an enemy actor or his own projectile.
meleeAid :: (MonadClient m, MonadClientUI m)
=> ActorId -> ActorId -> m (FailOrCmd RequestTimed)
meleeAid leader target = do
side <- getsClient sside
tb <- getsState $ getActorBody target
sfact <- getsState $ (EM.! side) . sfactionD
mel <- pickWeaponClient leader target
case mel of
Nothing -> failWith "nothing to melee with"
Just wp -> do
let returnCmd = do
-- Set personal target to enemy, so that AI, if it takes over
-- the actor, is likely to continue the fight even if the foe flees.
modifyClient $ updateTarget leader $ const $ Just $ TEnemy target
-- Also set xhair to see the foe's HP, because it's automatically
-- set to any new spotted actor, so it needs to be reset
-- and also it's not useful as permanent ranged target anyway.
modifySession $ \sess -> sess {sxhair = Just $ TEnemy target}
return $ Right wp
res | bproj tb || isFoe side sfact (bfid tb) = returnCmd
| isFriend side sfact (bfid tb) = do
let !_A = assert (side /= bfid tb) ()
go1 <- displayYesNo ColorBW
"You are bound by an alliance. Really attack?"
if not go1 then failWith "attack canceled" else returnCmd
| otherwise = do
go2 <- displayYesNo ColorBW
"This attack will start a war. Are you sure?"
if not go2 then failWith "attack canceled" else returnCmd
res
-- Seeing the actor prevents altering a tile under it, but that
-- does not limit the player, he just doesn't waste a turn
-- on a failed altering.
-- | Actor swaps position with another.
displaceAid :: MonadClientUI m
=> ActorId -> ActorId -> m (FailOrCmd RequestTimed)
displaceAid leader target = do
COps{coTileSpeedup} <- getsState scops
sb <- getsState $ getActorBody leader
tb <- getsState $ getActorBody target
tfact <- getsState $ (EM.! bfid tb) . sfactionD
actorMaxSk <- getsState $ getActorMaxSkills target
dEnemy <- getsState $ dispEnemy leader target actorMaxSk
let immobile = Ability.getSk Ability.SkMove actorMaxSk <= 0
tpos = bpos tb
adj = checkAdjacent sb tb
atWar = isFoe (bfid tb) tfact (bfid sb)
if | not adj -> failSer DisplaceDistant
| not (bproj tb) && atWar
&& actorDying tb -> -- checked separately for a better message
failSer DisplaceDying
| not (bproj tb) && atWar
&& actorWaits tb -> -- checked separately for a better message
failSer DisplaceBraced
| not (bproj tb) && atWar
&& immobile -> -- checked separately for a better message
failSer DisplaceImmobile
| not dEnemy && atWar ->
failSer DisplaceSupported
| otherwise -> do
let lid = blid sb
lvl <- getLevel lid
-- Displacing requires full access.
if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then
case posToAidsLvl tpos lvl of
[] -> error $ "" `showFailure` (leader, sb, target, tb)
[_] -> return $ Right $ ReqDisplace target
_ -> failSer DisplaceMultiple
else failSer DisplaceAccess
-- | Leader moves or searches or alters. No visible actor at the position.
moveSearchAlter :: MonadClientUI m
=> ActorId -> Bool -> Vector -> m (FailOrCmd RequestTimed)
moveSearchAlter leader run dir = do
COps{coTileSpeedup} <- getsState scops
actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
sb <- getsState $ getActorBody leader
let moveSkill = Ability.getSk Ability.SkMove actorCurAndMaxSk
spos = bpos sb -- source position
tpos = spos `shift` dir -- target position
alterable <- getsState $ tileAlterable (blid sb) tpos
lvl <- getLevel $ blid sb
let t = lvl `at` tpos
runStopOrCmd <-
if Tile.isWalkable coTileSpeedup t then -- Movement requires full access.
if | moveSkill > 0 ->
-- A potential invisible actor is hit. War started without asking.
return $ Right $ ReqMove dir
| bwatch sb == WSleep -> failSer MoveUnskilledAsleep
| otherwise -> failSer MoveUnskilled
else do -- Not walkable, so search and/or alter the tile.
let sxhair = Just $ TPoint TUnknown (blid sb) tpos
-- Point xhair to see details with `~`.
setXHairFromGUI sxhair
if run then do
-- Explicit request to examine the terrain.
blurb <- lookAtPosition tpos (blid sb)
mapM_ (uncurry msgAdd) blurb
failWith $ "the terrain is" <+>
if | Tile.isModifiable coTileSpeedup t -> "potentially modifiable"
| alterable -> "potentially triggerable"
| otherwise -> "completely inert"
else alterCommon leader True tpos
return $! runStopOrCmd
alterCommon :: MonadClientUI m
=> ActorId -> Bool -> Point -> m (FailOrCmd RequestTimed)
alterCommon leader bumping tpos = do
CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui
cops@COps{cotile, coTileSpeedup} <- getsState scops
side <- getsClient sside
factionD <- getsState sfactionD
actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
sb <- getsState $ getActorBody leader
let alterSkill = Ability.getSk Ability.SkAlter actorCurAndMaxSk
spos = bpos sb
alterable <- getsState $ tileAlterable (blid sb) tpos
lvl <- getLevel $ blid sb
localTime <- getsState $ getLocalTime (blid sb)
embeds <- getsState $ getEmbedBag (blid sb) tpos
itemToF <- getsState $ flip itemToFull
getKind <- getsState $ flip getIidKind
let t = lvl `at` tpos
underFeet = tpos == spos -- if enter and alter, be more permissive
modificationFailureHint = msgAdd MsgTutorialHint "Some doors can be opened, stairs unbarred, treasures recovered, only if you find tools that increase your terrain modification ability and act as keys to the puzzle. To gather clues about the keys, listen to what's around you, examine items, inspect terrain, trigger, bump and harass. Once you uncover a likely tool, wield it, return and try to break through again."
if | not alterable -> do
let name = MU.Text $ TK.tname $ okind cotile t
itemLook (iid, kit@(k, _)) =
let itemFull = itemToF iid
in partItemWsShort rwidth side factionD k localTime itemFull kit
embedKindList =
map (\(iid, kit) -> (getKind iid, (iid, kit))) (EM.assocs embeds)
ilooks = map itemLook $ sortEmbeds cops t embedKindList
failWith $ makePhrase $
["there is no way to activate or modify", MU.AW name]
++ if EM.null embeds
then []
else ["with", MU.WWandW ilooks]
-- misclick? related to AlterNothing but no searching possible;
-- this also rules out activating embeds that only cause
-- raw damage, with no chance of altering the tile
| Tile.isSuspect coTileSpeedup t
&& not underFeet
&& alterSkill <= 1 -> do
modificationFailureHint
failSer AlterUnskilled
| not (Tile.isSuspect coTileSpeedup t)
&& not underFeet
&& alterSkill < Tile.alterMinSkill coTileSpeedup t -> do
-- Rather rare (requires high skill), so describe the tile.
blurb <- lookAtPosition tpos (blid sb)
mapM_ (uncurry msgAdd) blurb
modificationFailureHint
failSer AlterUnwalked
| chessDist tpos (bpos sb) > 1 ->
-- Checked late to give useful info about distant tiles.
failSer AlterDistant
| not underFeet
&& (occupiedBigLvl tpos lvl || occupiedProjLvl tpos lvl) ->
-- Don't mislead describing terrain, if other actor is to blame.
failSer AlterBlockActor
| otherwise -> do -- promising
verAlters <- verifyAlters leader bumping tpos
case verAlters of
Right () ->
if bumping then
return $ Right $ ReqMove $ vectorToFrom tpos spos
else do
msgAddDone False leader tpos "modify"
return $ Right $ ReqAlter tpos
Left err -> return $ Left err
-- Even when bumping, we don't use ReqMove, because we don't want
-- to hit invisible actors, e.g., hidden in a wall.
-- If server performed an attack for free
-- on the invisible actor anyway, the player (or AI)
-- would be tempted to repeatedly hit random walls
-- in hopes of killing a monster residing within.
-- If the action had a cost, misclicks would incur the cost, too.
-- Right now the player may repeatedly alter tiles trying to learn
-- about invisible pass-wall actors, but when an actor detected,
-- it costs a turn and does not harm the invisible actors,
-- so it's not so tempting.
-- * RunOnceAhead
runOnceAheadHuman :: MonadClientUI m
=> ActorId -> m (Either MError RequestTimed)
runOnceAheadHuman leader = do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
keyPressed <- anyKeyPressed
srunning <- getsSession srunning
-- When running, stop if disturbed. If not running, stop at once.
case srunning of
Nothing -> do
msgAdd MsgRunStopReason "run stop: nothing to do"
return $ Left Nothing
Just RunParams{runMembers}
| noRunWithMulti fact && runMembers /= [leader] -> do
msgAdd MsgRunStopReason "run stop: automatic pointman change"
return $ Left Nothing
Just _runParams | keyPressed -> do
discardPressedKey
msgAdd MsgRunStopReason "run stop: key pressed"
weaveJust <$> failWith "interrupted"
Just runParams -> do
arena <- getArenaUI
runOutcome <- continueRun arena runParams
case runOutcome of
Left stopMsg -> do
msgAdd MsgRunStopReason ("run stop:" <+> stopMsg)
return $ Left Nothing
Right runCmd ->
return $ Right runCmd
-- * MoveOnceToXhair
moveOnceToXhairHuman :: (MonadClient m, MonadClientUI m)
=> ActorId -> m (FailOrCmd RequestTimed)
moveOnceToXhairHuman leader = goToXhair leader True False
goToXhair :: (MonadClient m, MonadClientUI m)
=> ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhair leader initialStep run = do
aimMode <- getsSession saimMode
-- Movement is legal only outside aiming mode.
if isJust aimMode
then failWith "cannot move in aiming mode"
else goToXhairExplorationMode leader initialStep run
goToXhairExplorationMode :: (MonadClient m, MonadClientUI m)
=> ActorId -> Bool -> Bool
-> m (FailOrCmd RequestTimed)
goToXhairExplorationMode leader initialStep run = do
actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
sb <- getsState $ getActorBody leader
let moveSkill = Ability.getSk Ability.SkMove actorCurAndMaxSk
-- If skill is too low, no path in @Bfs@ is going to be found,
-- but we check the skill (and sleep) to give a more accurate message.
if | moveSkill > 0 -> do
xhair <- getsSession sxhair
xhairGoTo <- getsSession sxhairGoTo
mfail <-
if isJust xhairGoTo && xhairGoTo /= xhair
then failWith "crosshair position changed"
else do
when (isNothing xhairGoTo) $ -- set it up for next steps
modifySession $ \sess -> sess {sxhairGoTo = xhair}
goToXhairGoTo leader initialStep run
when (isLeft mfail) $
modifySession $ \sess -> sess {sxhairGoTo = Nothing}
return mfail
| bwatch sb == WSleep -> failSer MoveUnskilledAsleep
| otherwise -> failSer MoveUnskilled
goToXhairGoTo :: (MonadClient m, MonadClientUI m)
=> ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhairGoTo leader initialStep run = do
b <- getsState $ getActorBody leader
mxhairPos <- mxhairToPos
case mxhairPos of
Nothing -> failWith "crosshair position invalid"
Just c -> do
running <- getsSession srunning
case running of
-- Don't use running params from previous run or goto-xhair.
Just paramOld | not initialStep -> do
arena <- getArenaUI
runOutcome <- multiActorGoTo arena c paramOld
case runOutcome of
Left stopMsg -> return $ Left stopMsg
Right (finalGoal, dir) ->
moveRunHuman leader initialStep finalGoal run False dir
_ | c == bpos b -> failWith "position reached"
_ -> do
let !_A = assert (initialStep || not run) ()
(bfs, mpath) <- getCacheBfsAndPath leader c
xhairMoused <- getsSession sxhairMoused
case mpath of
_ | xhairMoused && isNothing (accessBfs bfs c) ->
failWith
"no route to crosshair (press again to go there anyway)"
_ | initialStep && adjacent (bpos b) c -> do
let dir = towards (bpos b) c
moveRunHuman leader initialStep True run False dir
Nothing -> failWith "no route to crosshair"
Just AndPath{pathList=[]} -> failWith "almost there"
Just AndPath{pathList = p1 : _} -> do
let finalGoal = p1 == c
dir = towards (bpos b) p1
moveRunHuman leader initialStep finalGoal run False dir
multiActorGoTo :: (MonadClient m, MonadClientUI m)
=> LevelId -> Point -> RunParams -> m (FailOrCmd (Bool, Vector))
multiActorGoTo arena c paramOld =
case paramOld of
RunParams{runMembers = []} -> failWith "selected actors no longer there"
RunParams{runMembers = r : rs, runWaiting} -> do
onLevel <- getsState $ memActor r arena
b <- getsState $ getActorBody r
mxhairPos <- mxhairToPos
if not onLevel || mxhairPos == Just (bpos b) then do
let paramNew = paramOld {runMembers = rs}
multiActorGoTo arena c paramNew
else do
sL <- getState
modifyClient $ updateLeader r sL
let runMembersNew = rs ++ [r]
paramNew = paramOld { runMembers = runMembersNew
, runWaiting = 0}
(bfs, mpath) <- getCacheBfsAndPath r c
xhairMoused <- getsSession sxhairMoused
case mpath of
_ | xhairMoused && isNothing (accessBfs bfs c) ->
failWith "no route to crosshair (press again to go there anyway)"
Nothing -> failWith "no route to crosshair"
Just AndPath{pathList=[]} -> failWith "almost there"
Just AndPath{pathList = p1 : _} -> do
let finalGoal = p1 == c
dir = towards (bpos b) p1
tgts <- getsState $ posToAids p1 arena
case tgts of
[] -> do
modifySession $ \sess -> sess {srunning = Just paramNew}
return $ Right (finalGoal, dir)
[target] | target `elem` rs || runWaiting <= length rs ->
-- Let r wait until all others move. Mark it in runWaiting
-- to avoid cycles. When all wait for each other, fail.
multiActorGoTo arena c paramNew{runWaiting=runWaiting + 1}
_ ->
failWith "collective running finished" -- usually OK
-- * RunOnceToXhair
runOnceToXhairHuman :: (MonadClient m, MonadClientUI m)
=> ActorId -> m (FailOrCmd RequestTimed)
runOnceToXhairHuman leader = goToXhair leader True True
-- * ContinueToXhair
continueToXhairHuman :: (MonadClient m, MonadClientUI m)
=> ActorId -> m (FailOrCmd RequestTimed)
continueToXhairHuman leader = goToXhair leader False False{-irrelevant-}
-- * MoveItem
moveItemHuman :: forall m. MonadClientUI m
=> ActorId -> [CStore] -> CStore -> Maybe Text -> Bool
-> m (FailOrCmd RequestTimed)
moveItemHuman leader stores destCStore mverb auto = do
let !_A = assert (destCStore `notElem` stores) ()
actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
if Ability.getSk Ability.SkMoveItem actorCurAndMaxSk > 0
then moveOrSelectItem leader stores destCStore mverb auto
else failSer MoveItemUnskilled
-- This cannot be structured as projecting or applying, with @ByItemMode@
-- and @ChooseItemToMove@, because at least in case of grabbing items,
-- more than one item is chosen, which doesn't fit @sitemSel@. Separating
-- grabbing of multiple items as a distinct command is too high a price.
moveOrSelectItem :: forall m. MonadClientUI m
=> ActorId -> [CStore] -> CStore -> Maybe Text -> Bool
-> m (FailOrCmd RequestTimed)
moveOrSelectItem leader storesRaw destCStore mverb auto = do
b <- getsState $ getActorBody leader
actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b
let calmE = calmEnough b actorCurAndMaxSk
overStash = mstash == Just (blid b, bpos b)
stores = case storesRaw of
CEqp : rest@(_ : _) | not calmE -> rest ++ [CEqp]
CGround : rest@(_ : _) | overStash -> rest ++ [CGround]
_ -> storesRaw
itemSel <- getsSession sitemSel
modifySession $ \sess -> sess {sitemSel = Nothing} -- prevent surprise
case itemSel of
_ | stores == [CGround] && overStash ->
failWith "you can't loot items from your own stash"
Just (_, fromCStore@CEqp, _) | fromCStore /= destCStore
&& fromCStore `elem` stores
&& not calmE ->
failWith "neither the selected item nor any other can be unequipped"
Just (_, fromCStore@CGround, _) | fromCStore /= destCStore
&& fromCStore `elem` stores
&& overStash ->
failWith "you vainly paw through your own hoard"
Just (iid, fromCStore, _) | fromCStore /= destCStore
&& fromCStore `elem` stores -> do
bag <- getsState $ getBodyStoreBag b fromCStore
case iid `EM.lookup` bag of
Nothing -> -- the case of old selection or selection from another actor
moveOrSelectItem leader stores destCStore mverb auto
Just (k, it) -> assert (k > 0) $ do
let eqpFree = eqpFreeN b
kToPick | destCStore == CEqp = min eqpFree k
| otherwise = k
if | destCStore == CEqp && not calmE -> failSer ItemNotCalm
| destCStore == CGround && overStash -> failSer ItemOverStash
| kToPick == 0 -> failWith "no more items can be equipped"
| otherwise -> do
socK <- pickNumber (not auto) kToPick
case socK of
Left Nothing ->
moveOrSelectItem leader stores destCStore mverb auto
Left (Just err) -> return $ Left err
Right kChosen ->
let is = (fromCStore, [(iid, (kChosen, take kChosen it))])
in Right <$> moveItems leader stores is destCStore
_ -> do
mis <- selectItemsToMove leader stores destCStore mverb auto
case mis of
Left err -> return $ Left err
Right (fromCStore, [(iid, _)]) | stores /= [CGround] -> do
modifySession $ \sess ->
sess {sitemSel = Just (iid, fromCStore, False)}
moveOrSelectItem leader stores destCStore mverb auto
Right is@(fromCStore, _) ->
if | fromCStore == CEqp && not calmE -> failSer ItemNotCalm
| fromCStore == CGround && overStash -> failSer ItemOverStash
| otherwise -> Right <$> moveItems leader stores is destCStore
selectItemsToMove :: forall m. MonadClientUI m
=> ActorId -> [CStore] -> CStore -> Maybe Text -> Bool
-> m (FailOrCmd (CStore, [(ItemId, ItemQuant)]))
selectItemsToMove leader stores destCStore mverb auto = do
let verb = fromMaybe (verbCStore destCStore) mverb
actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
b <- getsState $ getActorBody leader
mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b
lastItemMove <- getsSession slastItemMove
-- This calmE is outdated when one of the items increases max Calm
-- (e.g., in pickup, which handles many items at once), but this is OK,
-- the server accepts item movement based on calm at the start, not end
-- or in the middle.
-- The calmE is inaccurate also if an item not IDed, but that's intended
-- and the server will ignore and warn (and content may avoid that,
-- e.g., making all rings identified)
let calmE = calmEnough b actorCurAndMaxSk
overStash = mstash == Just (blid b, bpos b)
if | destCStore == CEqp && not calmE -> failSer ItemNotCalm
| destCStore == CGround && overStash -> failSer ItemOverStash
| destCStore == CEqp && eqpOverfull b 1 -> failSer EqpOverfull
| otherwise -> do
let storesLast = case lastItemMove of
Just (lastFrom, lastDest) | lastDest == destCStore
&& lastFrom `elem` stores ->
lastFrom : delete lastFrom stores
_ -> stores
prompt = "What to"
promptEqp = "What consumable to"
eqpItemsN body =
let n = sum $ map fst $ EM.elems $ beqp body
in "(" <> makePhrase [MU.CarWs n "item"]
ppItemDialogBody body actorSk cCur = case cCur of
MStore CEqp | not $ calmEnough body actorSk ->
"distractedly paw at" <+> ppItemDialogModeIn cCur
MStore CGround | mstash == Just (blid body, bpos body) ->
"greedily fondle" <+> ppItemDialogModeIn cCur
_ -> case destCStore of
CEqp | not $ calmEnough body actorSk ->
"distractedly attempt to" <+> verb
<+> ppItemDialogModeFrom cCur
CEqp | eqpOverfull body 1 ->
"attempt to fit into equipment" <+> ppItemDialogModeFrom cCur
CGround | mstash == Just (blid body, bpos body) ->
"greedily attempt to" <+> verb <+> ppItemDialogModeFrom cCur
CEqp -> verb
<+> eqpItemsN body <+> "so far)"
<+> ppItemDialogModeFrom cCur
_ -> verb <+> ppItemDialogModeFrom cCur
<+> if cCur == MStore CEqp
then eqpItemsN body <+> "now)"
else ""
(promptGeneric, psuit) =
-- We prune item list only for eqp, because other stores don't have
-- so clear cut heuristics. So when picking up a stash, either grab
-- it to auto-store things, or equip first using the pruning
-- and then stash the rest selectively or en masse.
if destCStore == CEqp
then (promptEqp, return $ SuitsSomething $ \_ itemFull _kit ->
IA.goesIntoEqp $ aspectRecordFull itemFull)
else (prompt, return SuitsEverything)
ggi <-
getFull leader psuit
(\body _ actorSk cCur _ ->
prompt <+> ppItemDialogBody body actorSk cCur)
(\body _ actorSk cCur _ ->
promptGeneric <+> ppItemDialogBody body actorSk cCur)
storesLast (not auto) True
case ggi of
Right (fromCStore, l) -> do
modifySession $ \sess ->
sess {slastItemMove = Just (fromCStore, destCStore)}
return $ Right (fromCStore, l)
Left err -> failWith err
moveItems :: forall m. MonadClientUI m
=> ActorId -> [CStore] -> (CStore, [(ItemId, ItemQuant)]) -> CStore
-> m RequestTimed
moveItems leader stores (fromCStore, l) destCStore = do
let !_A = assert (fromCStore /= destCStore && fromCStore `elem` stores) ()
actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
b <- getsState $ getActorBody leader
discoBenefit <- getsClient sdiscoBenefit
let calmE = calmEnough b actorCurAndMaxSk
ret4 :: [(ItemId, ItemQuant)] -> Int -> m [(ItemId, Int, CStore, CStore)]
ret4 [] _ = return []
ret4 ((iid, (k, _)) : rest) oldN = do
let !_A = assert (k > 0) ()
retRec toCStore = do
let n = oldN + if toCStore == CEqp then k else 0
l4 <- ret4 rest n
return $ (iid, k, fromCStore, toCStore) : l4
if stores == [CGround] && destCStore == CStash -- normal pickup
then -- @CStash@ is the implicit default; refine:
if | not $ benInEqp $ discoBenefit EM.! iid -> retRec CStash
| eqpOverfull b (oldN + 1) -> do
-- Action goes through, but changed, so keep in history.
msgAdd MsgActionWarning $
"Warning:" <+> showReqFailure EqpOverfull <> "."
retRec CStash
| eqpOverfull b (oldN + k) -> do
-- If this stack doesn't fit, we don't equip any part of it,
-- but we may equip a smaller stack later of other items
-- in the same pickup.
msgAdd MsgActionWarning $
"Warning:" <+> showReqFailure EqpStackFull <> "."
retRec CStash
| not calmE -> do
msgAdd MsgActionWarning $
"Warning:" <+> showReqFailure ItemNotCalm <> "."
retRec CStash
| otherwise ->
-- Prefer @CEqp@ if all conditions hold:
retRec CEqp
else case destCStore of -- player forces store, so @benInEqp@ ignored
CEqp | eqpOverfull b (oldN + 1) -> do
-- Action aborted, so different colour and not in history.
msgAdd MsgPromptItems $
"Failure:" <+> showReqFailure EqpOverfull <> "."
-- No recursive call here, we exit item manipulation,
-- but something is moved or else outer functions would not call us.
return []
CEqp | eqpOverfull b (oldN + k) -> do
msgAdd MsgPromptItems $
"Failure:" <+> showReqFailure EqpStackFull <> "."
return []
_ -> retRec destCStore
l4 <- ret4 l 0
if null l4
then error $ "" `showFailure` (stores, fromCStore, l, destCStore)
else return $! ReqMoveItems l4
-- * Project
projectHuman :: (MonadClient m, MonadClientUI m)
=> ActorId -> m (FailOrCmd RequestTimed)
projectHuman leader = do
curChal <- getsClient scurChal
actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
if | ckeeper curChal ->
failSer ProjectFinderKeeper
| Ability.getSk Ability.SkProject actorCurAndMaxSk <= 0 ->
-- Detailed are check later.
failSer ProjectUnskilled
| otherwise -> do
itemSel <- getsSession sitemSel
case itemSel of
Just (_, COrgan, _) -> failWith "can't fling an organ"
Just (iid, fromCStore, _) -> do
b <- getsState $ getActorBody leader
bag <- getsState $ getBodyStoreBag b fromCStore
case iid `EM.lookup` bag of
Nothing -> failWith "no item to fling"
Just _kit -> do
itemFull <- getsState $ itemToFull iid
let i = (fromCStore, (iid, itemFull))
projectItem leader i
Nothing -> failWith "no item to fling"
projectItem :: (MonadClient m, MonadClientUI m)
=> ActorId -> (CStore, (ItemId, ItemFull))
-> m (FailOrCmd RequestTimed)
projectItem leader (fromCStore, (iid, itemFull)) = do
actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
b <- getsState $ getActorBody leader
let calmE = calmEnough b actorCurAndMaxSk
if fromCStore == CEqp && not calmE then failSer ItemNotCalm
else do
mpsuitReq <- psuitReq leader
case mpsuitReq of
Left err -> failWith err
Right psuitReqFun ->
case psuitReqFun itemFull of
Left reqFail -> failSer reqFail
Right (pos, _) -> do
Benefit{benFling} <- getsClient $ (EM.! iid) . sdiscoBenefit
go <- if benFling >= 0
then displayYesNo ColorFull
"The item may be beneficial. Do you really want to fling it?"
else return True
if go then do
-- Set personal target to enemy, so that AI, if it takes over
-- the actor, is likely to continue the fight even if the foe
-- flees. Similarly if the crosshair points at position, etc.
sxhair <- getsSession sxhair
modifyClient $ updateTarget leader (const sxhair)
-- Project.
eps <- getsClient seps
return $ Right $ ReqProject pos eps iid fromCStore
else do
modifySession $ \sess -> sess {sitemSel = Nothing}
failWith "never mind"
-- * Apply
applyHuman :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)
applyHuman leader = do
actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
if Ability.getSk Ability.SkApply
actorCurAndMaxSk <= 0 then -- detailed check later
failSer ApplyUnskilled
else do
itemSel <- getsSession sitemSel
case itemSel of
Just (iid, fromCStore, _) -> do
b <- getsState $ getActorBody leader
bag <- getsState $ getBodyStoreBag b fromCStore
case iid `EM.lookup` bag of
Nothing -> failWith "no item to trigger"
Just kit -> do
itemFull <- getsState $ itemToFull iid
applyItem leader (fromCStore, (iid, (itemFull, kit)))
Nothing -> failWith "no item to trigger"
applyItem :: MonadClientUI m
=> ActorId -> (CStore, (ItemId, ItemFullKit))
-> m (FailOrCmd RequestTimed)
applyItem leader (fromCStore, (iid, (itemFull, kit))) = do
COps{corule} <- getsState scops
actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
b <- getsState $ getActorBody leader
localTime <- getsState $ getLocalTime (blid b)
let skill = Ability.getSk Ability.SkApply actorCurAndMaxSk
calmE = calmEnough b actorCurAndMaxSk
arItem = aspectRecordFull itemFull
if fromCStore == CEqp && not calmE then failSer ItemNotCalm
else case permittedApply corule localTime skill calmE (Just fromCStore)
itemFull kit of
Left reqFail -> failSer reqFail
Right _ -> do
Benefit{benApply} <- getsClient $ (EM.! iid) . sdiscoBenefit
go <-
if | IA.checkFlag Ability.Periodic arItem
&& not (IA.checkFlag Ability.Durable arItem) ->
-- No warning if item durable, because activation weak,
-- but price low, due to no destruction.
displayYesNo ColorFull
"Triggering this periodic item may not produce all its effects (check item description) and moreover, because it's not durable, will destroy it. Are you sure?"
| benApply < 0 ->
displayYesNo ColorFull
"The item appears harmful. Do you really want to trigger it?"
| otherwise -> return True
if go
then return $ Right $ ReqApply iid fromCStore
else do
modifySession $ \sess -> sess {sitemSel = Nothing}
failWith "never mind"
-- * AlterDir
-- | Ask for a direction and alter a tile, if possible.
alterDirHuman :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)
alterDirHuman leader = pickPoint leader "modify" >>= \case
Just p -> alterTileAtPos leader p
Nothing -> failWith "never mind"
-- | Try to alter a tile using a feature at the given position.
--
-- We don't check if the tile is interesting, e.g., if any embedded
-- item can be triggered, because the player explicitely requested
-- the action. Consequently, even if all embedded items are recharching,
-- the time will be wasted and the server will describe the failure in detail.
alterTileAtPos :: MonadClientUI m
=> ActorId -> Point -> m (FailOrCmd RequestTimed)
alterTileAtPos leader pos = do
sb <- getsState $ getActorBody leader
let sxhair = Just $ TPoint TUnknown (blid sb) pos
-- Point xhair to see details with `~`.
setXHairFromGUI sxhair
alterCommon leader False pos
-- | Verify that the tile can be transformed or any embedded item effect
-- triggered and the player is aware if the effect is dangerous or grave,
-- such as ending the game.
verifyAlters :: forall m. MonadClientUI m
=> ActorId -> Bool -> Point -> m (FailOrCmd ())
verifyAlters leader bumping tpos = do
COps{cotile, coTileSpeedup} <- getsState scops
sb <- getsState $ getActorBody leader
arItem <- getsState $ aspectRecordFromIid $ btrunk sb
embeds <- getsState $ getEmbedBag (blid sb) tpos
lvl <- getLevel $ blid sb
getKind <- getsState $ flip getIidKind
let embedKindList =
if IA.checkFlag Ability.Blast arItem
then [] -- prevent embeds triggering each other in a loop
else map (\(iid, kit) -> (getKind iid, (iid, kit))) (EM.assocs embeds)
underFeet = tpos == bpos sb -- if enter and alter, be more permissive
blockedByItem = EM.member tpos (lfloor lvl)
tile = lvl `at` tpos
feats = TK.tfeature $ okind cotile tile
tileActions =
mapMaybe (parseTileAction
(bproj sb)
(underFeet || blockedByItem) -- avoids AlterBlockItem
embedKindList)
feats
if null tileActions
&& blockedByItem
&& not underFeet
&& Tile.isModifiable coTileSpeedup tile
then failSer AlterBlockItem
else processTileActions leader bumping tpos tileActions
processTileActions :: forall m. MonadClientUI m
=> ActorId -> Bool -> Point -> [TileAction]
-> m (FailOrCmd ())
processTileActions leader bumping tpos tas = do
COps{coTileSpeedup} <- getsState scops
getKind <- getsState $ flip getIidKind
sb <- getsState $ getActorBody leader
lvl <- getLevel $ blid sb
sar <- getsState $ aspectRecordFromIid $ btrunk sb
let leaderIsMist = IA.checkFlag Ability.Blast sar
&& Dice.infDice (IK.idamage $ getKind $ btrunk sb) <= 0
tileMinSkill = Tile.alterMinSkill coTileSpeedup $ lvl `at` tpos
processTA :: Maybe Bool -> [TileAction] -> Bool
-> m (FailOrCmd (Maybe (Bool, Bool)))
processTA museResult [] bumpFailed = do
let useResult = fromMaybe False museResult
-- No warning will be generated if during explicit modification
-- an embed is activated but there is not enough tools
-- for a subsequent transformation. This is fine. Bumping would
-- produce the warning and S-dir also displays the tool info.
-- We can't rule out the embed is the main feature and the tool
-- transformation is not important despite following it.
-- We don't want spam in such a case.
return $ Right $ if Tile.isSuspect coTileSpeedup (lvl `at` tpos)
|| useResult && not bumpFailed
then Nothing -- success of some kind
else Just (useResult, bumpFailed) -- not quite
processTA museResult (ta : rest) bumpFailed = case ta of
EmbedAction (iid, _) -> do
-- Embeds are activated in the order in tile definition
-- and never after the tile is changed.
-- We assume the item would trigger and we let the player
-- take the risk of wasted turn to verify the assumption.
-- If the item recharges, the wasted turns let the player wait.
let useResult = fromMaybe False museResult
if | leaderIsMist
|| bproj sb && tileMinSkill > 0 -> -- local skill check
processTA (Just useResult) rest bumpFailed
-- embed won't fire; try others
| (not . any IK.isEffEscape) (IK.ieffects $ getKind iid) ->
processTA (Just True) rest False
-- no escape checking needed, effect found;
-- also bumpFailed reset, because must have been
-- marginal if an embed was following it
| otherwise -> do
mfail <- verifyEscape
case mfail of
Left err -> return $ Left err
Right () -> processTA (Just True) rest False
-- effect found, bumpFailed reset
ToAction{} ->
if fromMaybe True museResult
&& not (bproj sb && tileMinSkill > 0) -- local skill check
then return $ Right Nothing -- tile changed, no more activations
else processTA museResult rest bumpFailed
-- failed, but not due to bumping
WithAction tools0 _ ->
if not bumping || null tools0 then
if fromMaybe True museResult then do
-- UI requested, so this is voluntary, so item loss is fine.
kitAssG <- getsState $ kitAssocs leader [CGround]
kitAssE <- getsState $ kitAssocs leader [CEqp]
let kitAss = listToolsToConsume kitAssG kitAssE
grps0 = map (\(x, y) -> (False, x, y)) tools0
-- apply if durable
(_, iidsToApply, grps) =
foldl' subtractIidfromGrps (EM.empty, [], grps0) kitAss
if null grps then do
let hasEffectOrDmg (_, (_, ItemFull{itemKind})) =
IK.idamage itemKind /= 0
|| any IK.forApplyEffect (IK.ieffects itemKind)
mfail <- case filter hasEffectOrDmg iidsToApply of
[] -> return $ Right ()
(store, (_, itemFull)) : _ ->
verifyToolEffect (blid sb) store itemFull
case mfail of
Left err -> return $ Left err
Right () -> return $ Right Nothing -- tile changed, done
else processTA museResult rest bumpFailed -- not enough tools
else processTA museResult rest bumpFailed -- embeds failed
else processTA museResult rest True -- failed due to bumping
mfail <- processTA Nothing tas False
case mfail of
Left err -> return $ Left err
Right Nothing -> return $ Right ()
Right (Just (useResult, bumpFailed)) -> do
let !_A = assert (not useResult || bumpFailed) ()
blurb <- lookAtPosition tpos (blid sb)
mapM_ (uncurry msgAdd) blurb
if bumpFailed then do
revCmd <- revCmdMap
let km = revCmd AlterDir
msg = "bumping is not enough to transform this terrain; modify with the '"
<> T.pack (K.showKM km)
<> "' command instead"
if useResult then do
merr <- failMsg msg
msgAdd MsgPromptAction $ showFailError $ fromJust merr
return $ Right () -- effect the embed activation, though
else failWith msg
else failWith "unable to activate nor modify at this time"
-- related to, among others, @SfxNoItemsForTile@ on the server
verifyEscape :: MonadClientUI m => m (FailOrCmd ())
verifyEscape = do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
if not (FK.fcanEscape $ gkind fact)
then failWith
"This is the way out, but where would you go in this alien world?"
-- exceptionally a full sentence, because a real question
else do
(_, total) <- getsState $ calculateTotal side
dungeonTotal <- getsState sgold
let prompt | dungeonTotal == 0 =
"You finally reached your goal. Really leave now?"
| total == 0 =
"Afraid of the challenge? Leaving so soon and without any treasure? Are you sure?"
| total < dungeonTotal =
"You've finally found the way out, but you didn't gather all valuables rumoured to be laying around. Really leave already?"
| otherwise =
"This is the way out and you collected all treasure there is to find. Really leave now?"
-- The player can back off, but we never insist,
-- because possibly the score formula doesn't reward treasure
-- or he is focused on winning only.
go <- displayYesNo ColorBW prompt
if not go
then failWith "here's your chance"
else return $ Right ()
verifyToolEffect :: MonadClientUI m
=> LevelId -> CStore -> ItemFull -> m (FailOrCmd ())
verifyToolEffect lid store itemFull = do
CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui
side <- getsClient sside
localTime <- getsState $ getLocalTime lid
factionD <- getsState sfactionD
let (name1, powers) = partItemShort rwidth side factionD localTime
itemFull quantSingle
objectA = makePhrase [MU.AW name1, powers]
-- "Potentially", because an unidentified items on the ground can take
-- precedence (perhaps placed there in order to get identified!).
prompt = "Do you really want to transform the terrain potentially using"
<+> objectA <+> ppCStoreIn store
<+> "that may cause substantial side-effects?"
objectThe = makePhrase ["the", name1]
go <- displayYesNo ColorBW prompt
if not go
then failWith $ "replace" <+> objectThe <+> "and try again"
-- question capitalized and ended with a dot, answer neither
else return $ Right ()
-- * AlterWithPointer
-- | Try to alter a tile using a feature under the pointer.
alterWithPointerHuman :: MonadClientUI m
=> ActorId -> m (FailOrCmd RequestTimed)
alterWithPointerHuman leader = do
COps{corule=RuleContent{rWidthMax, rHeightMax}} <- getsState scops
pUI <- getsSession spointer
let p = squareToMap $ uiToSquare pUI
if insideP (0, 0, rWidthMax - 1, rHeightMax - 1) p
then alterTileAtPos leader p
else failWith "never mind"
-- * CloseDir
-- | Close nearby open tile; ask for direction, if there is more than one.
closeDirHuman :: MonadClientUI m
=> ActorId -> m (FailOrCmd RequestTimed)
closeDirHuman leader = do
COps{coTileSpeedup} <- getsState scops
b <- getsState $ getActorBody leader
lvl <- getLevel $ blid b
let vPts = vicinityUnsafe $ bpos b
openPts = filter (Tile.isClosable coTileSpeedup . at lvl) vPts
case openPts of
[] -> failSer CloseNothing
[o] -> closeTileAtPos leader o
_ -> pickPoint leader "close" >>= \case
Nothing -> failWith "never mind"
Just p -> closeTileAtPos leader p
-- | Close tile at given position.
closeTileAtPos :: MonadClientUI m
=> ActorId -> Point -> m (FailOrCmd RequestTimed)
closeTileAtPos leader tpos = do
COps{coTileSpeedup} <- getsState scops
actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
b <- getsState $ getActorBody leader
alterable <- getsState $ tileAlterable (blid b) tpos
lvl <- getLevel $ blid b
let alterSkill = Ability.getSk Ability.SkAlter actorCurAndMaxSk
t = lvl `at` tpos
isOpen = Tile.isClosable coTileSpeedup t
isClosed = Tile.isOpenable coTileSpeedup t
case (alterable, isClosed, isOpen) of
(False, _, _) -> failSer CloseNothing
(True, False, False) -> failSer CloseNonClosable
(True, True, False) -> failSer CloseClosed
(True, True, True) -> error "TileKind content validation"
(True, False, True) ->
if | tpos `chessDist` bpos b > 1
-> failSer CloseDistant
| alterSkill <= 1
-> failSer AlterUnskilled
| EM.member tpos $ lfloor lvl
-> failSer AlterBlockItem
| occupiedBigLvl tpos lvl || occupiedProjLvl tpos lvl
-> failSer AlterBlockActor
| otherwise
-> do
msgAddDone True leader tpos "close"
return $ Right (ReqAlter tpos)
-- | Adds message with proper names.
msgAddDone :: MonadClientUI m => Bool -> ActorId -> Point -> Text -> m ()
msgAddDone mentionTile leader p verb = do
COps{cotile} <- getsState scops
b <- getsState $ getActorBody leader
lvl <- getLevel $ blid b
let tname = TK.tname $ okind cotile $ lvl `at` p
s = case T.words tname of
[] -> "thing"
("open" : xs) -> T.unwords xs
_ -> tname
object | mentionTile = "the" <+> s
| otherwise = ""
v = p `vectorToFrom` bpos b
dir | v == Vector 0 0 = "underneath"
| otherwise = compassText v
msgAdd MsgActionComplete $ "You" <+> verb <+> object <+> dir <> "."
-- | Prompts user to pick a point.
pickPoint :: MonadClientUI m => ActorId -> Text -> m (Maybe Point)
pickPoint leader verb = do
b <- getsState $ getActorBody leader
UIOptions{uVi, uLeftHand} <- getsSession sUIOptions
let dirKeys = K.dirAllKey uVi uLeftHand
keys = K.escKM
: K.leftButtonReleaseKM
: map (K.KM K.NoModifier) dirKeys
msgAdd MsgPromptGeneric $ "Where to" <+> verb <> "? [movement key] [pointer]"
slides <- reportToSlideshow [K.escKM]
km <- getConfirms ColorFull keys slides
case K.key km of
K.LeftButtonRelease -> do
pUI <- getsSession spointer
let p = squareToMap $ uiToSquare pUI
return $ Just p
_ -> return $ shift (bpos b) <$> K.handleDir dirKeys km
-- * Help
-- | Display command help.
helpHuman :: MonadClientUI m
=> (K.KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
helpHuman cmdSemInCxtOfKM = do
ccui@CCUI{coinput, coscreen=ScreenContent{rwidth, rheight, rintroScreen}}
<- getsSession sccui
fontSetup@FontSetup{..} <- getFontSetup
gameModeId <- getsState sgameModeId
modeOv <- describeMode True gameModeId
curTutorial <- getsSession scurTutorial
overrideTut <- getsSession soverrideTut
let displayTutorialHints = fromMaybe curTutorial overrideTut
modeH = ( "Press SPACE or PGDN to advance or ESC to see the map again."
, (modeOv, []) )
keyH = keyHelp ccui fontSetup
-- This takes a list of paragraphs and returns a list of screens.
-- Both paragraph and screen is a list of lines.
--
-- This would be faster, but less clear, if paragraphs were stored
-- reversed in content. Not worth it, until we have huge manuals
-- or run on weak mobiles. Even then, precomputation during
-- compilation may be better.
--
-- Empty lines may appear at the end of pages, but it's fine,
-- it means there is a new section on the next page.
packIntoScreens :: [[String]] -> [[String]] -> Int -> [[String]]
packIntoScreens [] acc _ = [intercalate [""] (reverse acc)]
packIntoScreens ([] : ls) [] _ =
-- Ignore empty paragraphs at the start of screen.
packIntoScreens ls [] 0
packIntoScreens (l : ls) [] h = assert (h == 0) $
-- If a paragraph, even alone, is longer than screen height, it's split.
if length l <= rheight - 3
then packIntoScreens ls [l] (length l)
else let (screen, rest) = splitAt (rheight - 3) l
in screen : packIntoScreens (rest : ls) [] 0
packIntoScreens (l : ls) acc h =
-- The extra @+ 1@ comes from the empty line separating paragraphs,
-- as added in @intercalate@.
if length l + 1 + h <= rheight - 3
then packIntoScreens ls (l : acc) (length l + 1 + h)
else intercalate [""] (reverse acc) : packIntoScreens (l : ls) [] 0
manualScreens = packIntoScreens (snd rintroScreen) [] 0
sideBySide =
if isSquareFont monoFont
then \(screen1, screen2) -> -- single column, two screens
map offsetOverlay $ filter (not . null) [screen1, screen2]
else \(screen1, screen2) -> -- two columns, single screen
[offsetOverlay screen1
++ xtranslateOverlay rwidth (offsetOverlay screen2)]
listPairs (a : b : rest) = (a, b) : listPairs rest
listPairs [a] = [(a, [])]
listPairs [] = []
-- Each screen begins with an empty line, to separate the header.
manualOvs = map (EM.singleton monoFont)
$ concatMap sideBySide $ listPairs
$ map ((emptyAttrLine :) . map stringToAL) manualScreens
addMnualHeader ov =
( "Showing PLAYING.md (best viewed in the browser)."
, (ov, []) )
manualH = map addMnualHeader manualOvs
splitHelp (t, okx) =
splitOKX fontSetup True rwidth rheight rwidth (textToAS t)
[K.spaceKM, K.returnKM, K.escKM] okx
sli = toSlideshow fontSetup displayTutorialHints
$ concatMap splitHelp $ modeH : keyH ++ manualH
-- Thus, the whole help menu corresponds to a single menu of item or lore,
-- e.g., shared stash menu. This is especially clear when the shared stash
-- menu contains many pages.
ekm <- displayChoiceScreen "help" ColorFull True sli
[K.spaceKM, K.returnKM, K.escKM]
case ekm of
Left km | km `elem` [K.escKM, K.spaceKM] -> return $ Left Nothing
Left km | km == K.returnKM -> do
msgAdd MsgPromptGeneric "Press RET when a command help text is selected to invoke the command."
return $ Left Nothing
Left km -> case km `M.lookup` bcmdMap coinput of
Just (_desc, _cats, cmd) -> cmdSemInCxtOfKM km cmd
Nothing -> weaveJust <$> failWith "never mind"
Right _slot -> error $ "" `showFailure` ekm
-- * Hint
-- | Display hint or, if already displayed, display help.
hintHuman :: MonadClientUI m
=> (K.KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
hintHuman cmdSemInCxtOfKM = do
sreportNull <- getsSession sreportNull
if sreportNull then do
promptMainKeys
return $ Left Nothing
else
helpHuman cmdSemInCxtOfKM
-- * Dashboard
-- | Display the dashboard.
dashboardHuman :: MonadClientUI m
=> (K.KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
dashboardHuman cmdSemInCxtOfKM = do
CCUI{coinput, coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui
fontSetup@FontSetup{..} <- getFontSetup
curTutorial <- getsSession scurTutorial
overrideTut <- getsSession soverrideTut
let displayTutorialHints = fromMaybe curTutorial overrideTut
offsetCol2 = 3
(ov0, kxs0) = okxsN coinput monoFont propFont offsetCol2 (const False)
False CmdDashboard ([], [], []) ([], [])
al1 = textToAS "Dashboard"
splitHelp (al, okx) = splitOKX fontSetup False rwidth (rheight - 2) rwidth
al [K.returnKM, K.escKM] okx
sli = toSlideshow fontSetup displayTutorialHints
$ splitHelp (al1, (ov0, kxs0))
extraKeys = [K.returnKM, K.escKM]
ekm <- displayChoiceScreen "dashboard" ColorFull False sli extraKeys
case ekm of
Left km -> case km `M.lookup` bcmdMap coinput of
_ | km == K.escKM -> weaveJust <$> failWith "never mind"
_ | km == K.returnKM -> do
msgAdd MsgPromptGeneric "Press RET when a menu name is selected to browse the menu."
return $ Left Nothing
Just (_desc, _cats, cmd) -> cmdSemInCxtOfKM km cmd
Nothing -> weaveJust <$> failWith "never mind"
Right _slot -> error $ "" `showFailure` ekm
-- * ItemMenu
itemMenuHuman :: MonadClientUI m
=> ActorId
-> (K.KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
itemMenuHuman leader cmdSemInCxtOfKM = do
COps{corule} <- getsState scops
itemSel <- getsSession sitemSel
fontSetup@FontSetup{..} <- getFontSetup
case itemSel of
Just (iid, fromCStore, _) -> do
side <- getsClient sside
b <- getsState $ getActorBody leader
bUI <- getsSession $ getActorUI leader
bag <- getsState $ getBodyStoreBag b fromCStore
case iid `EM.lookup` bag of
Nothing -> weaveJust <$> failWith "no item to open item menu for"
Just kit -> do
CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui
actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
itemFull <- getsState $ itemToFull iid
localTime <- getsState $ getLocalTime (blid b)
found <- getsState $ findIid leader side iid
let !_A = assert (not (null found) || fromCStore == CGround
`blame` (iid, leader)) ()
fAlt (aid, (_, store)) = aid /= leader || store /= fromCStore
foundAlt = filter fAlt found
markParagraphs = rheight >= 45
meleeSkill = Ability.getSk Ability.SkHurtMelee actorCurAndMaxSk
partRawActor aid = getsSession (partActor . getActorUI aid)
ppLoc aid store = do
parts <- ppContainerWownW partRawActor
False
(CActor aid store)
return $! "[" ++ T.unpack (makePhrase parts) ++ "]"
dmode = MStore fromCStore
foundTexts <- mapM (\(aid, (_, store)) -> ppLoc aid store) foundAlt
(ovLab, ovDesc) <-
itemDescOverlays markParagraphs meleeSkill dmode iid kit
itemFull rwidth
let foundPrefix = textToAS $
if null foundTexts then "" else "The item is also in:"
ovPrefix = ytranslateOverlay (length ovDesc)
$ offsetOverlay
$ splitAttrString rwidth rwidth foundPrefix
ystart = length ovDesc + length ovPrefix - 1
xstart = textSize monoFont (Color.spaceAttrW32
: attrLine (snd $ last ovPrefix))
foundKeys = map (K.KM K.NoModifier . K.Fun)
[1 .. length foundAlt] -- starting from 1!
let ks = zip foundKeys foundTexts
width = if isSquareFont monoFont then 2 * rwidth else rwidth
(ovFoundRaw, kxsFound) = wrapOKX monoFont ystart xstart width ks
ovFound = ovPrefix ++ ovFoundRaw
report <- getReportUI True
CCUI{coinput} <- getsSession sccui
mstash <- getsState $ \s -> gstash $ sfactionD s EM.! side
curTutorial <- getsSession scurTutorial
overrideTut <- getsSession soverrideTut
let displayTutorialHints = fromMaybe curTutorial overrideTut
calmE = calmEnough b actorCurAndMaxSk
greyedOut cmd = not calmE && fromCStore == CEqp
|| mstash == Just (blid b, bpos b)
&& fromCStore == CGround
|| case cmd of
ByAimMode AimModeCmd{..} ->
greyedOut exploration || greyedOut aiming
ComposeIfLocal cmd1 cmd2 -> greyedOut cmd1 || greyedOut cmd2
ComposeUnlessError cmd1 cmd2 -> greyedOut cmd1 || greyedOut cmd2
Compose2ndLocal cmd1 cmd2 -> greyedOut cmd1 || greyedOut cmd2
MoveItem stores destCStore _ _ ->
fromCStore `notElem` stores
|| destCStore == CEqp && (not calmE || eqpOverfull b 1)
|| destCStore == CGround && mstash == Just (blid b, bpos b)
Apply{} ->
let skill = Ability.getSk Ability.SkApply actorCurAndMaxSk
in not $ fromRight False
$ permittedApply corule localTime skill calmE
(Just fromCStore) itemFull kit
Project{} ->
let skill = Ability.getSk Ability.SkProject actorCurAndMaxSk
in not $ fromRight False
$ permittedProject False skill calmE itemFull
_ -> False
fmt n k h = " " <> T.justifyLeft n ' ' k <> " " <> h
offsetCol2 = 11
keyCaption = fmt offsetCol2 "keys" "command"
offset = 1 + maxYofOverlay (ovDesc ++ ovFound)
(ov0, kxs0) = xytranslateOKX 0 offset $
okxsN coinput monoFont propFont offsetCol2 greyedOut
True CmdItemMenu ([], [], ["", keyCaption]) ([], [])
t0 = makeSentence [ MU.SubjectVerbSg (partActor bUI) "choose"
, "an item", MU.Text $ ppCStoreIn fromCStore ]
alRep = foldr (<+:>) [] $ renderReport True report
al1 | null alRep = textToAS t0
| otherwise = alRep ++ stringToAS "\n" ++ textToAS t0
splitHelp (al, okx) =
splitOKX fontSetup False rwidth (rheight - 2) rwidth al
[K.spaceKM, K.escKM] okx
sli = toSlideshow fontSetup displayTutorialHints
$ splitHelp ( al1
, ( EM.insertWith (++) squareFont ovLab
$ EM.insertWith (++) propFont ovDesc
$ EM.insertWith (++) monoFont ovFound ov0
-- mono font, because there are buttons
, kxsFound ++ kxs0 ))
extraKeys = [K.spaceKM, K.escKM] ++ foundKeys
recordHistory -- report shown (e.g., leader switch), save to history
ekm <- displayChoiceScreen "item menu" ColorFull False sli extraKeys
case ekm of
Left km -> case km `M.lookup` bcmdMap coinput of
_ | km == K.escKM -> weaveJust <$> failWith "never mind"
_ | km == K.spaceKM ->
chooseItemMenuHuman leader cmdSemInCxtOfKM dmode
_ | km `elem` foundKeys -> case km of
K.KM{key=K.Fun n} -> do
let (newAid, (bNew, newCStore)) = foundAlt !! (n - 1)
fact <- getsState $ (EM.! side) . sfactionD
let banned = bannedPointmanSwitchBetweenLevels fact
if blid bNew /= blid b && banned
then weaveJust <$> failSer NoChangeDunLeader
else do
-- Verbosity not necessary to notice the switch
-- and it's explicitly requested, so no surprise.
void $ pickLeader False newAid
modifySession $ \sess ->
sess {sitemSel = Just (iid, newCStore, False)}
itemMenuHuman newAid cmdSemInCxtOfKM
_ -> error $ "" `showFailure` km
Just (_desc, _cats, cmd) -> do
modifySession $ \sess ->
sess {sitemSel = Just (iid, fromCStore, True)}
cmdSemInCxtOfKM km cmd
Nothing -> weaveJust <$> failWith "never mind"
Right _slot -> error $ "" `showFailure` ekm
Nothing -> weaveJust <$> failWith "no item to open item menu for"
-- * ChooseItemMenu
chooseItemMenuHuman :: MonadClientUI m
=> ActorId
-> (K.KM -> HumanCmd -> m (Either MError ReqUI))
-> ItemDialogMode
-> m (Either MError ReqUI)
chooseItemMenuHuman leader1 cmdSemInCxtOfKM c1 = do
res2 <- chooseItemDialogMode leader1 True c1
case res2 of
Right leader2 -> itemMenuHuman leader2 cmdSemInCxtOfKM
Left err -> return $ Left $ Just err
-- * MainMenu
generateMenu :: MonadClientUI m
=> (K.KM -> HumanCmd -> m (Either MError ReqUI))
-> FontOverlayMap
-> [(Text, HumanCmd, Maybe HumanCmd, Maybe FontOverlayMap)]
-> [String]
-> String
-> m (Either MError ReqUI)
generateMenu cmdSemInCxtOfKM blurb kdsRaw gameInfo menuName = do
COps{corule} <- getsState scops
CCUI{ coinput=InputContent{brevMap}
, coscreen=ScreenContent{rheight, rwebAddress} } <- getsSession sccui
FontSetup{..} <- getFontSetup
let matchKM slot kd@(_, cmd, _, _) = case M.lookup cmd brevMap of
Just (km : _) -> (Left km, kd)
_ -> (Right slot, kd)
kds = zipWith matchKM natSlots kdsRaw
bindings = -- key bindings to display
let attrCursor = Color.defAttr {Color.bg = Color.HighlightNoneCursor}
highAttr ac = ac {Color.acAttr = attrCursor}
highW32 = Color.attrCharToW32 . highAttr . Color.attrCharFromW32
markFirst d = markFirstAS $ textToAS d
markFirstAS [] = []
markFirstAS (ac : rest) = highW32 ac : rest
fmt (ekm, (d, _, _, _)) = (ekm, markFirst d)
in map fmt kds
generate :: Int -> (KeyOrSlot, AttrString) -> KYX
generate y (ekm, binding) =
(ekm, (PointUI 0 y, ButtonWidth squareFont (length binding)))
okxBindings = ( EM.singleton squareFont
$ offsetOverlay $ map (attrStringToAL . snd) bindings
, zipWith generate [0..] bindings )
titleLine =
rtitle corule ++ " " ++ showVersion (rexeVersion corule) ++ " "
titleAndInfo = map stringToAL
([ ""
, titleLine ++ "[" ++ rwebAddress ++ "]"
, "" ]
++ gameInfo)
webButton = ( Left $ K.mkChar '@' -- to start the menu not here
, ( PointUI (2 * length titleLine) 1
, ButtonWidth squareFont (2 + length rwebAddress) ) )
okxTitle = ( EM.singleton squareFont $ offsetOverlay titleAndInfo
, [webButton] )
okx = xytranslateOKX 2 0
$ sideBySideOKX 2 (length titleAndInfo) okxTitle okxBindings
prepareBlurb ovs =
let introLen = 1 + maxYofFontOverlayMap ovs
start0 = max 0 (rheight - introLen
- if isSquareFont propFont then 1 else 2)
in EM.map (xytranslateOverlay (-2) (start0 - 2)) ovs
-- subtracting 2 from X and Y to negate the indentation in
-- @displayChoiceScreenWithRightPane@
returnDefaultOKS = return (prepareBlurb blurb, [])
displayInRightPane ekm = case ekm `lookup` kds of
Just (_, _, _, mblurbRight) -> case mblurbRight of
Nothing -> returnDefaultOKS
Just blurbRight -> return (prepareBlurb blurbRight, [])
Nothing | ekm == Left (K.mkChar '@') -> returnDefaultOKS
Nothing -> error $ "generateMenu: unexpected key:"
`showFailure` ekm
keys = [K.leftKM, K.rightKM, K.escKM, K.mkChar '@']
loop = do
kmkm <- displayChoiceScreenWithRightPaneKMKM displayInRightPane True
menuName ColorFull True
(menuToSlideshow okx) keys
case kmkm of
Left (km@(K.KM {key=K.Left}), ekm) -> case ekm `lookup` kds of
Just (_, _, Nothing, _) -> loop
Just (_, _, Just cmdReverse, _) -> cmdSemInCxtOfKM km cmdReverse
Nothing -> weaveJust <$> failWith "never mind"
Left (km@(K.KM {key=K.Right}), ekm) -> case ekm `lookup` kds of
Just (_, cmd, _, _) -> cmdSemInCxtOfKM km cmd
Nothing -> weaveJust <$> failWith "never mind"
Left (K.KM {key=K.Char '@'}, _)-> do
success <- tryOpenBrowser rwebAddress
if success
then generateMenu cmdSemInCxtOfKM blurb kdsRaw gameInfo menuName
else weaveJust <$> failWith "failed to open web browser"
Left (km, _) -> case Left km `lookup` kds of
Just (_, cmd, _, _) -> cmdSemInCxtOfKM km cmd
Nothing -> weaveJust <$> failWith "never mind"
Right slot -> case Right slot `lookup` kds of
Just (_, cmd, _, _) -> cmdSemInCxtOfKM K.escKM cmd
Nothing -> weaveJust <$> failWith "never mind"
loop
-- | Display the main menu.
mainMenuHuman :: MonadClientUI m
=> (K.KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
mainMenuHuman cmdSemInCxtOfKM = do
CCUI{coscreen=ScreenContent{rintroScreen}} <- getsSession sccui
FontSetup{propFont} <- getFontSetup
gameMode <- getGameMode
curTutorial <- getsSession scurTutorial
overrideTut <- getsSession soverrideTut
curChal <- getsClient scurChal
let offOn b = if b then "on" else "off"
-- Key-description-command tuples.
kds = [ ("+ setup and start new game>", ChallengeMenu, Nothing, Nothing)
, ("@ save and exit to desktop", GameExit, Nothing, Nothing)
, ("+ tweak convenience settings>", SettingsMenu, Nothing, Nothing)
, ("@ toggle autoplay", AutomateToggle, Nothing, Nothing)
, ("@ see command help", Help, Nothing, Nothing)
, ("@ switch to dashboard", Dashboard, Nothing, Nothing)
, ("^ back to playing", AutomateBack, Nothing, Nothing) ]
gameName = MK.mname gameMode
displayTutorialHints = fromMaybe curTutorial overrideTut
gameInfo = map T.unpack
[ "Now playing:" <+> gameName
, ""
, " with difficulty:" <+> tshow (cdiff curChal)
, " cold fish:" <+> offOn (cfish curChal)
, " ready goods:" <+> offOn (cgoods curChal)
, " lone wolf:" <+> offOn (cwolf curChal)
, " finder keeper:" <+> offOn (ckeeper curChal)
, " tutorial hints:" <+> offOn displayTutorialHints
, "" ]
glueLines (l1 : l2 : rest) =
if | null l1 -> l1 : glueLines (l2 : rest)
| null l2 -> l1 : l2 : glueLines rest
| otherwise -> (l1 ++ l2) : glueLines rest
glueLines ll = ll
backstory | isSquareFont propFont = fst rintroScreen
| otherwise = glueLines $ fst rintroScreen
backstoryAL = map (stringToAL . dropWhile (== ' ')) backstory
blurb = attrLinesToFontMap [(propFont, backstoryAL)]
generateMenu cmdSemInCxtOfKM blurb kds gameInfo "main"
-- * MainMenuAutoOn
-- | Display the main menu and set @swasAutomated@.
mainMenuAutoOnHuman :: MonadClientUI m
=> (K.KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
mainMenuAutoOnHuman cmdSemInCxtOfKM = do
modifySession $ \sess -> sess {swasAutomated = True}
mainMenuHuman cmdSemInCxtOfKM
-- * MainMenuAutoOff
-- | Display the main menu and unset @swasAutomated@.
mainMenuAutoOffHuman :: MonadClientUI m
=> (K.KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
mainMenuAutoOffHuman cmdSemInCxtOfKM = do
modifySession $ \sess -> sess {swasAutomated = False}
mainMenuHuman cmdSemInCxtOfKM
-- * SettingsMenu
-- | Display the settings menu.
settingsMenuHuman :: MonadClientUI m
=> (K.KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
settingsMenuHuman cmdSemInCxtOfKM = do
CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui
UIOptions{uMsgWrapColumn} <- getsSession sUIOptions
FontSetup{..} <- getFontSetup
markSuspect <- getsClient smarkSuspect
markVision <- getsSession smarkVision
markSmell <- getsSession smarkSmell
noAnim <- getsClient $ fromMaybe False . snoAnim . soptions
side <- getsClient sside
factDoctrine <- getsState $ gdoctrine . (EM.! side) . sfactionD
overrideTut <- getsSession soverrideTut
let offOn b = if b then "on" else "off"
offOnAll n = case n of
0 -> "none"
1 -> "untried"
2 -> "all"
_ -> error $ "" `showFailure` n
neverEver n = case n of
0 -> "never"
1 -> "aiming"
2 -> "always"
_ -> error $ "" `showFailure` n
offOnUnset mb = case mb of
Nothing -> "pass"
Just b -> if b then "force on" else "force off"
tsuspect = "@ mark suspect terrain:" <+> offOnAll markSuspect
tvisible = "@ show visible zone:" <+> neverEver markVision
tsmell = "@ display smell clues:" <+> offOn markSmell
tanim = "@ play animations:" <+> offOn (not noAnim)
tdoctrine = "@ squad doctrine:" <+> Ability.nameDoctrine factDoctrine
toverride = "@ override tutorial hints:" <+> offOnUnset overrideTut
width = if isSquareFont propFont
then rwidth `div` 2
else min uMsgWrapColumn (rwidth - 2)
textToBlurb t = Just $ attrLinesToFontMap
[ ( propFont
, splitAttrString width width
$ textToAS t ) ]
-- Key-description-command-text tuples.
kds = [ ( tsuspect, MarkSuspect 1, Just (MarkSuspect (-1))
, textToBlurb "* mark suspect terrain\nThis setting affects the ongoing and the next games. It determines which suspect terrain is marked in special color on the map: none, untried (not searched nor revealed), all. It correspondingly determines which, if any, suspect tiles are considered for mouse go-to, auto-explore and for the command that marks the nearest unexplored position." )
, ( tvisible, MarkVision 1, Just (MarkVision (-1))
, textToBlurb "* show visible zone\nThis setting affects the ongoing and the next games. It determines the conditions under which the area visible to the party is marked on the map via a gray background: never, when aiming, always." )
, ( tsmell, MarkSmell, Just MarkSmell
, textToBlurb "* display smell clues\nThis setting affects the ongoing and the next games. It determines whether the map displays any smell traces (regardless of who left them) detected by a party member that can track via smell (as determined by the smell radius skill; not common among humans)." )
, ( tanim, MarkAnim, Just MarkAnim
, textToBlurb "* play animations\nThis setting affects the ongoing and the next games. It determines whether important events, such combat, are highlighted by animations. This overrides the corresponding config file setting." )
, ( tdoctrine, Doctrine, Nothing
, textToBlurb "* squad doctrine\nThis setting affects the ongoing game, but does not persist to the next games. It determines the behaviour of henchmen (non-pointman characters) in the party and, in particular, if they are permitted to move autonomously or fire opportunistically (assuming they are able to, usually due to rare equipment). This setting has a poor UI that will be improved in the future." )
, ( toverride, OverrideTut 1, Just (OverrideTut (-1))
, textToBlurb "* override tutorial hints\nThis setting affects the ongoing and the next games. It determines whether tutorial hints are, respectively, not overridden with respect to the default game mode setting, forced to be off, forced to be on. Tutorial hints are rendered as pink messages and can afterwards be re-read from message history." )
, ( "^ back to main menu", MainMenu, Nothing, Just EM.empty ) ]
gameInfo = map T.unpack
[ "Tweak convenience settings:"
, "" ]
generateMenu cmdSemInCxtOfKM EM.empty kds gameInfo "settings"
-- * ChallengeMenu
-- | Display the challenge menu.
challengeMenuHuman :: MonadClientUI m
=> (K.KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
challengeMenuHuman cmdSemInCxtOfKM = do
cops <- getsState scops
CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui
UIOptions{uMsgWrapColumn} <- getsSession sUIOptions
FontSetup{..} <- getFontSetup
svictories <- getsSession svictories
snxtScenario <- getsSession snxtScenario
nxtChal <- getsClient snxtChal
let (gameModeId, gameMode) = nxtGameMode cops snxtScenario
victories = case EM.lookup gameModeId svictories of
Nothing -> 0
Just cm -> fromMaybe 0 (M.lookup nxtChal cm)
star t = if victories > 0 then "*" <> t else t
tnextScenario = "@ adventure:" <+> star (MK.mname gameMode)
offOn b = if b then "on" else "off"
tnextDiff = "@ difficulty level:" <+> tshow (cdiff nxtChal)
tnextFish = "@ cold fish (rather hard):" <+> offOn (cfish nxtChal)
tnextGoods = "@ ready goods (hard):" <+> offOn (cgoods nxtChal)
tnextWolf = "@ lone wolf (very hard):" <+> offOn (cwolf nxtChal)
tnextKeeper = "@ finder keeper (hard):" <+> offOn (ckeeper nxtChal)
width = if isSquareFont propFont
then rwidth `div` 2
else min uMsgWrapColumn (rwidth - 2)
widthFull = if isSquareFont propFont
then rwidth `div` 2
else rwidth - 2
duplicateEOL '\n' = "\n\n"
duplicateEOL c = T.singleton c
blurb = Just $ attrLinesToFontMap
[ ( propFont
, splitAttrString width width
$ textFgToAS Color.BrBlack
$ T.concatMap duplicateEOL (MK.mdesc gameMode)
<> "\n\n" )
, ( propFont
, splitAttrString widthFull widthFull
$ textToAS
$ MK.mrules gameMode
<> "\n\n" )
, ( propFont
, splitAttrString width width
$ textToAS
$ T.concatMap duplicateEOL (MK.mreason gameMode) )
]
textToBlurb t = Just $ attrLinesToFontMap
[ ( propFont
, splitAttrString width width -- not widthFull!
$ textToAS t ) ]
-- Key-description-command-text tuples.
kds = [ ( tnextScenario, GameScenarioIncr 1, Just (GameScenarioIncr (-1))
, blurb )
, ( tnextDiff, GameDifficultyIncr 1, Just (GameDifficultyIncr (-1))
, textToBlurb "* difficulty level\nThis determines the difficulty of survival in the next game that's about to be started. Lower numbers result in easier game. In particular, difficulty below 5 multiplies hitpoints of player characters and difficulty over 5 multiplies hitpoints of their enemies. Game score scales with difficulty.")
, ( tnextFish, GameFishToggle, Just GameFishToggle
, textToBlurb "* cold fish\nThis challenge mode setting will affect the next game that's about to be started. When on, it makes it impossible for player characters to be healed by actors from other factions (this is a significant restriction in the long crawl adventure).")
, ( tnextGoods, GameGoodsToggle, Just GameGoodsToggle
, textToBlurb "* ready goods\nThis challenge mode setting will affect the next game that's about to be started. When on, it disables crafting for the player, making the selection of equipment, especially melee weapons, very limited, unless the player has the luck to find the rare powerful ready weapons (this applies only if the chosen adventure supports crafting at all).")
, ( tnextWolf, GameWolfToggle, Just GameWolfToggle
, textToBlurb "* lone wolf\nThis challenge mode setting will affect the next game that's about to be started. When on, it reduces player's starting actors to exactly one, though later on new heroes may join the party. This makes the game very hard in the long run.")
, ( tnextKeeper, GameKeeperToggle, Just GameKeeperToggle
, textToBlurb "* finder keeper\nThis challenge mode setting will affect the next game that's about to be started. When on, it completely disables flinging projectiles by the player, which affects not only ranged damage dealing, but also throwing of consumables that buff teammates engaged in melee combat, weaken and distract enemies, light dark corners, etc.")
, ( "@ start new game", GameRestart, Nothing, blurb )
, ( "^ back to main menu", MainMenu, Nothing, Nothing ) ]
gameInfo = map T.unpack [ "Setup and start new game:"
, "" ]
generateMenu cmdSemInCxtOfKM EM.empty kds gameInfo "challenge"
-- * GameDifficultyIncr
gameDifficultyIncr :: MonadClient m => Int -> m ()
gameDifficultyIncr delta = do
nxtDiff <- getsClient $ cdiff . snxtChal
let d | nxtDiff + delta > difficultyBound = 1
| nxtDiff + delta < 1 = difficultyBound
| otherwise = nxtDiff + delta
modifyClient $ \cli -> cli {snxtChal = (snxtChal cli) {cdiff = d} }
-- * GameFishToggle
gameFishToggle :: MonadClient m => m ()
gameFishToggle =
modifyClient $ \cli ->
cli {snxtChal = (snxtChal cli) {cfish = not (cfish (snxtChal cli))} }
-- * GameGoodsToggle
gameGoodsToggle :: MonadClient m => m ()
gameGoodsToggle =
modifyClient $ \cli ->
cli {snxtChal = (snxtChal cli) {cgoods = not (cgoods (snxtChal cli))} }
-- * GameWolfToggle
gameWolfToggle :: MonadClient m => m ()
gameWolfToggle =
modifyClient $ \cli ->
cli {snxtChal = (snxtChal cli) {cwolf = not (cwolf (snxtChal cli))} }
-- * GameKeeperToggle
gameKeeperToggle :: MonadClient m => m ()
gameKeeperToggle =
modifyClient $ \cli ->
cli {snxtChal = (snxtChal cli) {ckeeper = not (ckeeper (snxtChal cli))} }
-- * GameScenarioIncr
gameScenarioIncr :: MonadClientUI m => Int -> m ()
gameScenarioIncr delta = do
cops <- getsState scops
oldScenario <- getsSession snxtScenario
let snxtScenario = oldScenario + delta
snxtTutorial = MK.mtutorial $ snd $ nxtGameMode cops snxtScenario
modifySession $ \sess -> sess {snxtScenario, snxtTutorial}
-- * GameRestart & GameQuit
data ExitStrategy = Restart | Quit
gameExitWithHuman :: MonadClientUI m => ExitStrategy -> m (FailOrCmd ReqUI)
gameExitWithHuman exitStrategy = do
snxtChal <- getsClient snxtChal
cops <- getsState scops
noConfirmsGame <- isNoConfirmsGame
gameMode <- getGameMode
snxtScenario <- getsSession snxtScenario
let nxtGameName = MK.mname $ snd $ nxtGameMode cops snxtScenario
exitReturn x = return $ Right $ ReqUIGameRestart x snxtChal
displayExitMessage diff =
displayYesNo ColorBW
$ diff <+> "progress of the ongoing"
<+> MK.mname gameMode <+> "game will be lost! Are you sure?"
ifM (if' noConfirmsGame
(return True) -- true case
(displayExitMessage $ case exitStrategy of -- false case
Restart -> "You just requested a new" <+> nxtGameName
<+> "game. The "
Quit -> "If you quit, the "))
(exitReturn $ case exitStrategy of -- ifM true case
Restart ->
let (mainName, _) = T.span (\c -> Char.isAlpha c || c == ' ')
nxtGameName
in DefsInternal.GroupName $ T.intercalate " "
$ take 2 $ T.words mainName
Quit -> MK.INSERT_COIN)
(rndToActionUI (oneOf -- ifM false case
[ "yea, would be a pity to leave them to die"
, "yea, a shame to get your team stranded" ])
>>= failWith)
ifM :: Monad m => m Bool -> m b -> m b -> m b
ifM b t f = do b' <- b; if b' then t else f
if' :: Bool -> p -> p -> p
if' b t f = if b then t else f
-- * GameDrop
gameDropHuman :: MonadClientUI m => m ReqUI
gameDropHuman = do
modifySession $ \sess -> sess {sallNframes = -1} -- hack, but we crash anyway
msgAdd MsgPromptGeneric "Interrupt! Trashing the unsaved game. The program exits now."
clientPrintUI "Interrupt! Trashing the unsaved game. The program exits now."
-- this is not shown by ANSI frontend, but at least shown by sdl2 one
return ReqUIGameDropAndExit
-- * GameExit
gameExitHuman :: Monad m => m ReqUI
gameExitHuman =
return ReqUIGameSaveAndExit
-- * GameSave
gameSaveHuman :: MonadClientUI m => m ReqUI
gameSaveHuman = do
-- Announce before the saving started, since it can take a while.
msgAdd MsgInnerWorkSpam "Saving game backup."
return ReqUIGameSave
-- * Doctrine
-- Note that the difference between seek-target and follow-the-leader doctrine
-- can influence even a faction with passive actors. E.g., if a passive actor
-- has an extra active skill from equipment, he moves every turn.
doctrineHuman :: MonadClientUI m => m (FailOrCmd ReqUI)
doctrineHuman = do
fid <- getsClient sside
fromT <- getsState $ gdoctrine . (EM.! fid) . sfactionD
let toT = if fromT == maxBound then minBound else succ fromT
go <- displaySpaceEsc ColorFull
$ "(Beware, work in progress!)"
<+> "Current squad doctrine is '" <> Ability.nameDoctrine fromT <> "'"
<+> "(" <> Ability.describeDoctrine fromT <> ")."
<+> "Switching doctrine to '" <> Ability.nameDoctrine toT <> "'"
<+> "(" <> Ability.describeDoctrine toT <> ")."
<+> "This clears targets of all non-pointmen teammates."
<+> "New targets will be picked according to new doctrine."
if not go
then failWith "squad doctrine change canceled"
else return $ Right $ ReqUIDoctrine toT
-- * Automate
automateHuman :: MonadClientUI m => m (FailOrCmd ReqUI)
automateHuman = do
clearAimMode
proceed <- displayYesNo ColorBW "Do you really want to cede control to AI?"
if not proceed
then failWith "automation canceled"
else return $ Right ReqUIAutomate
-- * AutomateToggle
automateToggleHuman :: MonadClientUI m => m (FailOrCmd ReqUI)
automateToggleHuman = do
swasAutomated <- getsSession swasAutomated
if swasAutomated
then failWith "automation canceled"
else automateHuman
-- * AutomateBack
automateBackHuman :: MonadClientUI m => m (Either MError ReqUI)
automateBackHuman = do
swasAutomated <- getsSession swasAutomated
return $! if swasAutomated
then Right ReqUIAutomate
else Left Nothing