-- | 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