HandleHumanGlobalClient.hs

{-# LANGUAGE DataKinds, GADTs #-}
-- | Semantics of 'Command.Cmd' client commands that return server commands.
-- A couple of them do not take time, the rest does.
-- Here prompts and menus and displayed, but any feedback resulting
-- from the commands (e.g., from inventory manipulation) is generated later on,
-- for all clients that witness the results of the commands.
-- TODO: document
module Game.LambdaHack.Client.UI.HandleHumanGlobalClient
  ( -- * Commands that usually take time
    moveRunHuman, waitHuman, moveItemHuman, describeItemHuman
  , projectHuman, applyHuman, alterDirHuman, triggerTileHuman
  , runOnceAheadHuman, moveOnceToCursorHuman
  , runOnceToCursorHuman, continueToCursorHuman
    -- * Commands that never take time
  , gameRestartHuman, gameExitHuman, gameSaveHuman, tacticHuman, automateHuman
  ) where

import Control.Applicative
import Control.Exception.Assert.Sugar
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import qualified NLP.Miniutter.English as MU

import Game.LambdaHack.Client.BfsClient
import Game.LambdaHack.Client.CommonClient
import qualified Game.LambdaHack.Client.Key as K
import Game.LambdaHack.Client.MonadClient
import Game.LambdaHack.Client.State
import Game.LambdaHack.Client.UI.Config
import Game.LambdaHack.Client.UI.HandleHumanLocalClient
import Game.LambdaHack.Client.UI.HumanCmd (Trigger (..))
import Game.LambdaHack.Client.UI.InventoryClient
import Game.LambdaHack.Client.UI.MonadClientUI
import Game.LambdaHack.Client.UI.MsgClient
import Game.LambdaHack.Client.UI.RunClient
import Game.LambdaHack.Client.UI.WidgetClient
import Game.LambdaHack.Common.Ability
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.ClientOptions
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import Game.LambdaHack.Common.ItemStrongest
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Common.Request
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Vector
import qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.TileKind (TileKind)
import qualified Game.LambdaHack.Content.TileKind as TK

-- * Move and Run

moveRunHuman :: MonadClientUI m
             => Bool -> Bool -> Bool -> Bool -> Vector
             -> m (SlideOrCmd RequestAnyAbility)
moveRunHuman initialStep finalGoal run runAhead dir = do
  tgtMode <- getsClient stgtMode
  if isJust tgtMode then
    Left <$> moveCursorHuman dir (if run then 10 else 1)
  else do
    arena <- getArenaUI
    leader <- getLeaderUI
    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 <- getsClient sselected
    let runMembers = if runAhead || noRunWithMulti fact
                     then [leader]  -- TODO: warn?
                     else ES.toList (ES.delete leader sel) ++ [leader]
        runParams = RunParams { runLeader = leader
                              , runMembers
                              , runInitial = True
                              , runStopMsg = Nothing
                              , runWaiting = 0 }
        macroRun25 = ["CTRL-comma", "CTRL-V"]
    when (initialStep && run) $ do
      modifyClient $ \cli ->
        cli {srunning = Just runParams}
      when runAhead $
        modifyClient $ \cli ->
          cli {slastPlay = map K.mkKM macroRun25 ++ slastPlay cli}
    -- 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).
    -- TODO: stop running at invisible actor
    let tpos = bpos sb `shift` dir
    -- We start by checking actors at the 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 $ posToActors tpos arena
    case tgts of
      [] -> do  -- move or search or alter
        runStopOrCmd <- moveSearchAlterAid leader dir
        case runStopOrCmd of
          Left stopMsg -> failWith stopMsg
          Right runCmd ->
            -- Don't check @initialStep@ and @finalGoal@
            -- and don't stop going to target: door opening is mundane enough.
            return $ Right runCmd
      [((target, _), _)] | run && initialStep ->
        -- No @stopPlayBack@: initial displace is benign enough.
        -- Displacing requires accessibility, but it's checked later on.
        fmap RequestAnyAbility <$> displaceAid target
      _ : _ : _ | run && initialStep -> do
        let !_A = assert (all (bproj . snd . fst) tgts) ()
        failSer DisplaceProjectiles
      ((target, tb), _) : _ | initialStep && finalGoal -> do
        stopPlayBack  -- don't ever auto-repeat melee
        -- No problem if there are many projectiles at the spot. We just
        -- attack the first one.
        -- We always see actors from our own faction.
        if bfid tb == bfid sb && not (bproj tb) then do
          let autoLvl = snd $ autoDungeonLevel fact
          if autoLvl then failSer NoChangeLvlLeader
          else do
            -- Select adjacent actor by bumping into him. Takes no time.
            success <- pickLeader True target
            let !_A = assert (success `blame` "bump self"
                                      `twith` (leader, target, tb)) ()
            return $ Left mempty
        else
          -- Attacking does not require full access, adjacency is enough.
          fmap RequestAnyAbility <$> meleeAid target
      _ : _ -> failWith "actor in the way"

-- | Actor atttacks an enemy actor or his own projectile.
meleeAid :: MonadClientUI m
         => ActorId -> m (SlideOrCmd (RequestTimed 'AbMelee))
meleeAid target = do
  leader <- getLeaderUI
  sb <- getsState $ getActorBody leader
  tb <- getsState $ getActorBody target
  sfact <- getsState $ (EM.! bfid sb) . sfactionD
  mel <- pickWeaponClient leader target
  case mel of
    Nothing -> failWith "nothing to melee with"
    Just wp -> do
      let returnCmd = return $ Right wp
          res | bproj tb || isAtWar sfact (bfid tb) = returnCmd
              | isAllied sfact (bfid tb) = do
                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 -> m (SlideOrCmd (RequestTimed 'AbDisplace))
displaceAid target = do
  cops <- getsState scops
  leader <- getLeaderUI
  sb <- getsState $ getActorBody leader
  tb <- getsState $ getActorBody target
  tfact <- getsState $ (EM.! bfid tb) . sfactionD
  activeItems <- activeItemsClient target
  disp <- getsState $ dispEnemy leader target activeItems
  let actorMaxSk = sumSkills activeItems
      immobile = EM.findWithDefault 0 AbMove actorMaxSk <= 0
      spos = bpos sb
      tpos = bpos tb
      adj = checkAdjacent sb tb
      atWar = isAtWar tfact (bfid sb)
  if not adj then failSer DisplaceDistant
  else if not (bproj tb) && atWar
          && actorDying tb then failSer DisplaceDying
  else if not (bproj tb) && atWar
          && braced tb then failSer DisplaceBraced
  else if not (bproj tb) && atWar
          && immobile then failSer DisplaceImmobile
  else if not disp && atWar then failSer DisplaceSupported
  else do
    let lid = blid sb
    lvl <- getLevel lid
    -- Displacing requires full access.
    if accessible cops lvl spos tpos then do
      tgts <- getsState $ posToActors tpos lid
      case tgts of
        [] -> assert `failure` (leader, sb, target, tb)
        [_] -> return $ Right $ ReqDisplace target
        _ -> failSer DisplaceProjectiles
    else failSer DisplaceAccess

-- | Actor moves or searches or alters. No visible actor at the position.
moveSearchAlterAid :: MonadClient m
                   => ActorId -> Vector -> m (Either Msg RequestAnyAbility)
moveSearchAlterAid source dir = do
  cops@Kind.COps{cotile} <- getsState scops
  sb <- getsState $ getActorBody source
  let lid = blid sb
  lvl <- getLevel lid
  let spos = bpos sb           -- source position
      tpos = spos `shift` dir  -- target position
      t = lvl `at` tpos
      runStopOrCmd
        -- Movement requires full access.
        | accessible cops lvl spos tpos =
            -- A potential invisible actor is hit. War started without asking.
            Right $ RequestAnyAbility $ ReqMove dir
        -- No access, so search and/or alter the tile. Non-walkability is
        -- not implied by the lack of access.
        | not (Tile.isWalkable cotile t)
                && (not (knownLsecret lvl)
                    || (isSecretPos lvl tpos  -- possible secrets here
                        && (Tile.isSuspect cotile t  -- not yet searched
                            || Tile.hideAs cotile t /= t))  -- search again
                    || Tile.isOpenable cotile t
                    || Tile.isClosable cotile t
                    || Tile.isChangeable cotile t)
          = if EM.member tpos $ lfloor lvl then
              Left $ showReqFailure AlterBlockItem
            else
              Right $ RequestAnyAbility $ ReqAlter tpos Nothing
            -- We don't use MoveSer, because we don't hit invisible actors.
            -- The potential invisible actor, e.g., in a wall or in
            -- an inaccessible doorway, is made known, taking a turn.
            -- 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 lurking 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.
        -- Ignore a known boring, not accessible tile.
        | otherwise = Left "never mind"
  return $! runStopOrCmd

-- * Wait

-- | Leader waits a turn (and blocks, etc.).
waitHuman :: MonadClientUI m => m (RequestTimed 'AbWait)
waitHuman = do
  modifyClient $ \cli -> cli {swaitTimes = abs (swaitTimes cli) + 1}
  return ReqWait

-- * MoveItem

moveItemHuman :: forall m. MonadClientUI m
              => [CStore] -> CStore -> Maybe MU.Part -> Bool
              -> m (SlideOrCmd (RequestTimed 'AbMoveItem))
moveItemHuman cLegalRaw destCStore mverb auto = do
  let !_A = assert (destCStore `notElem` cLegalRaw) ()
  let verb = fromMaybe (MU.Text $ verbCStore destCStore) mverb
  leader <- getLeaderUI
  b <- getsState $ getActorBody leader
  activeItems <- activeItemsClient leader
  -- 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 activeItems
      cLegal | calmE = cLegalRaw
             | destCStore == CSha = []
             | otherwise = delete CSha cLegalRaw
      ret4 :: MonadClientUI m
           => CStore -> [(ItemId, ItemFull)]
           -> Int -> [(ItemId, Int, CStore, CStore)]
           -> m (Either Slideshow [(ItemId, Int, CStore, CStore)])
      ret4 _ [] _ acc = return $ Right $ reverse acc
      ret4 fromCStore ((iid, itemFull) : rest) oldN acc = do
        let k = itemK itemFull
            retRec toCStore =
              let n = oldN + if toCStore == CEqp then k else 0
              in ret4 fromCStore rest n ((iid, k, fromCStore, toCStore) : acc)
        if cLegalRaw == [CGround]  -- normal pickup
        then case destCStore of
          CEqp | calmE && goesIntoSha itemFull ->
            retRec CSha
          CEqp | not $ goesIntoEqp itemFull ->
            retRec CInv
          CEqp | eqpOverfull b (oldN + k) -> do
            msgAdd $ "Warning:" <+> showReqFailure EqpOverfull <> "."
            retRec CInv
          _ ->
            retRec destCStore
        else case destCStore of
          CEqp | eqpOverfull b (oldN + k) -> failSer EqpOverfull
          _ -> retRec destCStore
      prompt = makePhrase ["What to", verb]
      promptEqp = makePhrase ["What consumable to", verb]
      p :: CStore -> (Text, m Suitability)
      p cstore = if cstore `elem` [CEqp, CSha] && cLegalRaw /= [CGround]
                 then (promptEqp, return $ SuitsSomething goesIntoEqp)
                 else (prompt, return SuitsEverything)
      (promptGeneric, psuit) = p destCStore
  ggi <-
    if auto
    then getAnyItems psuit prompt promptGeneric cLegalRaw cLegal False False
    else getAnyItems psuit prompt promptGeneric cLegalRaw cLegal True True
  case ggi of
    Right (l, MStore fromCStore) -> do
      leader2 <- getLeaderUI
      b2 <- getsState $ getActorBody leader2
      activeItems2 <- activeItemsClient leader2
      let calmE2 = calmEnough b2 activeItems2
      -- This is not ideal, because the failure message comes late,
      -- but it's simple and good enough.
      if not calmE2 && destCStore == CSha then failSer ItemNotCalm
      else do
        l4 <- ret4 fromCStore l 0 []
        return $! case l4 of
          Left sli -> Left sli
          Right [] -> assert `failure` ggi
          Right lr -> Right $ ReqMoveItems lr
    Left slides -> return $ Left slides
    _ -> assert `failure` ggi

-- * DescribeItem

-- | Display items from a given container store and describe the chosen one.
describeItemHuman :: MonadClientUI m
                  => ItemDialogMode -> m (SlideOrCmd (RequestTimed 'AbMoveItem))
describeItemHuman = describeItemC

-- * Project

projectHuman :: forall m. MonadClientUI m
             => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbProject))
projectHuman ts = do
  leader <- getLeaderUI
  lidV <- viewedLevel
  oldTgtMode <- getsClient stgtMode
  -- Show the targeting line, temporarily.
  modifyClient $ \cli -> cli {stgtMode = Just $ TgtMode lidV}
  -- Set cursor to the personal target, permanently.
  tgt <- getsClient $ getTarget leader
  modifyClient $ \cli -> cli {scursor = fromMaybe (scursor cli) tgt}
  -- Let the user pick the item to fling.
  let posFromCursor :: m (Either Msg Point)
      posFromCursor = do
        canAim <- aidTgtAims leader lidV Nothing
        case canAim of
          Right newEps -> do
            -- Modify @seps@, permanently.
            modifyClient $ \cli -> cli {seps = newEps}
            mpos <- aidTgtToPos leader lidV Nothing
            case mpos of
              Nothing -> assert `failure` (tgt, leader, lidV)
              Just pos -> do
                munit <- projectCheck pos
                case munit of
                  Nothing -> return $ Right pos
                  Just reqFail -> return $ Left $ showReqFailure reqFail
          Left cause -> return $ Left cause
  mitem <- projectItem ts posFromCursor
  outcome <- case mitem of
    Right (iid, fromCStore) -> do
      mpos <- posFromCursor
      case mpos of
        Right pos -> do
          eps <- getsClient seps
          return $ Right $ ReqProject pos eps iid fromCStore
        Left cause -> failWith cause
    Left sli -> return $ Left sli
  modifyClient $ \cli -> cli {stgtMode = oldTgtMode}
  return outcome

projectCheck :: MonadClientUI m => Point -> m (Maybe ReqFailure)
projectCheck tpos = do
  Kind.COps{cotile} <- getsState scops
  leader <- getLeaderUI
  eps <- getsClient seps
  sb <- getsState $ getActorBody leader
  let lid = blid sb
      spos = bpos sb
  Level{lxsize, lysize} <- getLevel lid
  case bla lxsize lysize eps spos tpos of
    Nothing -> return $ Just ProjectAimOnself
    Just [] -> assert `failure` "project from the edge of level"
                      `twith` (spos, tpos, sb)
    Just (pos : _) -> do
      lvl <- getLevel lid
      let t = lvl `at` pos
      if not $ Tile.isWalkable cotile t
        then return $ Just ProjectBlockTerrain
        else do
          mab <- getsState $ posToActor pos lid
          if maybe True (bproj . snd . fst) mab
          then return Nothing
          else return $ Just ProjectBlockActor

projectItem :: forall m. MonadClientUI m
            => [Trigger] -> m (Either Msg Point)
            -> m (SlideOrCmd (ItemId, CStore))
projectItem ts posFromCursor = do
  leader <- getLeaderUI
  b <- getsState $ getActorBody leader
  activeItems <- activeItemsClient leader
  actorSk <- actorSkillsClient leader
  let skill = EM.findWithDefault 0 AbProject actorSk
      cLegal = [CGround, CInv, CEqp, CSha]
      (verb1, object1) = case ts of
        [] -> ("aim", "item")
        tr : _ -> (verb tr, object tr)
      triggerSyms = triggerSymbols ts
      psuitReq :: m (Either Msg (ItemFull -> Either ReqFailure Bool))
      psuitReq = do
        mpos <- posFromCursor
        case mpos of
          Left err -> return $ Left err
          Right pos -> return $ Right $ \itemFull@ItemFull{itemBase} -> do
            let legal = permittedProject triggerSyms False skill
                                         itemFull b activeItems
            case legal of
              Left{} -> legal
              Right False -> legal
              Right True ->
                Right $ totalRange itemBase >= chessDist (bpos b) pos
      psuit :: m Suitability
      psuit = do
        mpsuitReq <- psuitReq
        case mpsuitReq of
          -- If target invalid, no item is considered a (suitable) missile.
          Left err -> return $ SuitsNothing err
          Right psuitReqFun -> return $ SuitsSomething $ \itemFull ->
            case psuitReqFun itemFull of
              Left _ -> False
              Right suit -> suit
      prompt = makePhrase ["What", object1, "to", verb1]
      promptGeneric = "What to fling"
  ggi <- getGroupItem psuit prompt promptGeneric True
                      cLegal cLegal
  case ggi of
    Right ((iid, itemFull), MStore fromCStore) -> do
      mpsuitReq <- psuitReq
      case mpsuitReq of
        Left err -> failWith err
        Right psuitReqFun ->
          case psuitReqFun itemFull of
            Left reqFail -> failSer reqFail
            Right _ -> return $ Right (iid, fromCStore)
    Left slides -> return $ Left slides
    _ -> assert `failure` ggi

triggerSymbols :: [Trigger] -> [Char]
triggerSymbols [] = []
triggerSymbols (ApplyItem{symbol} : ts) = symbol : triggerSymbols ts
triggerSymbols (_ : ts) = triggerSymbols ts

-- * Apply

applyHuman :: MonadClientUI m
           => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbApply))
applyHuman ts = do
  leader <- getLeaderUI
  b <- getsState $ getActorBody leader
  actorSk <- actorSkillsClient leader
  let skill = EM.findWithDefault 0 AbApply actorSk
  activeItems <- activeItemsClient leader
  localTime <- getsState $ getLocalTime (blid b)
  let cLegal = [CGround, CInv, CEqp, CSha]
      (verb1, object1) = case ts of
        [] -> ("apply", "item")
        tr : _ -> (verb tr, object tr)
      triggerSyms = triggerSymbols ts
      p itemFull =
        permittedApply triggerSyms localTime skill itemFull b activeItems
      prompt = makePhrase ["What", object1, "to", verb1]
      promptGeneric = "What to apply"
  ggi <- getGroupItem (return $ SuitsSomething $ either (const False) id . p)
                      prompt promptGeneric False cLegal cLegal
  case ggi of
    Right ((iid, itemFull), MStore fromCStore) ->
      case p itemFull of
        Left reqFail -> failSer reqFail
        Right _ -> return $ Right $ ReqApply iid fromCStore
    Left slides -> return $ Left slides
    _ -> assert `failure` ggi

-- * AlterDir

-- TODO: accept mouse, too
-- | Ask for a direction and alter a tile, if possible.
alterDirHuman :: MonadClientUI m
              => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbAlter))
alterDirHuman ts = do
  Config{configVi, configLaptop} <- askConfig
  let verb1 = case ts of
        [] -> "alter"
        tr : _ -> verb tr
      keys = map (K.toKM K.NoModifier) (K.dirAllKey configVi configLaptop)
      prompt = makePhrase ["What to", verb1 <> "? [movement key"]
  me <- displayChoiceUI prompt emptyOverlay keys
  case me of
    Left slides -> failSlides slides
    Right e -> K.handleDir configVi configLaptop e (`alterTile` ts)
                                                   (failWith "never mind")

-- | Player tries to alter a tile using a feature.
alterTile :: MonadClientUI m
          => Vector -> [Trigger] -> m (SlideOrCmd (RequestTimed 'AbAlter))
alterTile dir ts = do
  cops@Kind.COps{cotile} <- getsState scops
  leader <- getLeaderUI
  b <- getsState $ getActorBody leader
  lvl <- getLevel $ blid b
  as <- getsState $ actorList (const True) (blid b)
  let tpos = bpos b `shift` dir
      t = lvl `at` tpos
      alterFeats = alterFeatures ts
  case filter (\feat -> Tile.hasFeature cotile feat t) alterFeats of
    [] -> failWith $ guessAlter cops alterFeats t
    feat : _ ->
      if EM.notMember tpos $ lfloor lvl then
        if unoccupied as tpos then
          return $ Right $ ReqAlter tpos $ Just feat
        else failSer AlterBlockActor
      else failSer AlterBlockItem

alterFeatures :: [Trigger] -> [TK.Feature]
alterFeatures [] = []
alterFeatures (AlterFeature{feature} : ts) = feature : alterFeatures ts
alterFeatures (_ : ts) = alterFeatures ts

-- | Guess and report why the bump command failed.
guessAlter :: Kind.COps -> [TK.Feature] -> Kind.Id TileKind -> Msg
guessAlter Kind.COps{cotile} (TK.OpenTo _ : _) t
  | Tile.isClosable cotile t = "already open"
guessAlter _ (TK.OpenTo _ : _) _ = "cannot be opened"
guessAlter Kind.COps{cotile} (TK.CloseTo _ : _) t
  | Tile.isOpenable cotile t = "already closed"
guessAlter _ (TK.CloseTo _ : _) _ = "cannot be closed"
guessAlter _ _ _ = "never mind"

-- * TriggerTile

-- | Leader tries to trigger the tile he's standing on.
triggerTileHuman :: MonadClientUI m
                 => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbTrigger))
triggerTileHuman ts = do
  tgtMode <- getsClient stgtMode
  if isJust tgtMode then do
    let getK tfs = case tfs of
          TriggerFeature {feature = TK.Cause (IK.Ascend k)} : _ -> Just k
          _ : rest -> getK rest
          [] -> Nothing
        mk = getK ts
    case mk of
      Nothing -> failWith "never mind"
      Just k -> Left <$> tgtAscendHuman k
  else triggerTile ts

-- | Player tries to trigger a tile using a feature.
triggerTile :: MonadClientUI m
            => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbTrigger))
triggerTile ts = do
  cops@Kind.COps{cotile} <- getsState scops
  leader <- getLeaderUI
  b <- getsState $ getActorBody leader
  lvl <- getLevel $ blid b
  let t = lvl `at` bpos b
      triggerFeats = triggerFeatures ts
  case filter (\feat -> Tile.hasFeature cotile feat t) triggerFeats of
    [] -> failWith $ guessTrigger cops triggerFeats t
    feat : _ -> do
      go <- verifyTrigger leader feat
      case go of
        Right () -> return $ Right $ ReqTrigger $ Just feat
        Left slides -> return $ Left slides

triggerFeatures :: [Trigger] -> [TK.Feature]
triggerFeatures [] = []
triggerFeatures (TriggerFeature{feature} : ts) = feature : triggerFeatures ts
triggerFeatures (_ : ts) = triggerFeatures ts

-- | Verify important feature triggers, such as fleeing the dungeon.
verifyTrigger :: MonadClientUI m
              => ActorId -> TK.Feature -> m (SlideOrCmd ())
verifyTrigger leader feat = case feat of
  TK.Cause IK.Escape{} -> do
    b <- getsState $ getActorBody leader
    side <- getsClient sside
    fact <- getsState $ (EM.! side) . sfactionD
    if not (fcanEscape $ gplayer fact) then failWith
      "This is the way out, but where would you go in this alien world?"
    else do
      go <- displayYesNo ColorFull "This is the way out. Really leave now?"
      if not go then failWith "game resumed"
      else do
        (_, total) <- getsState $ calculateTotal b
        if total == 0 then do
          -- The player can back off at each of these steps.
          go1 <- displayMore ColorBW
                   "Afraid of the challenge? Leaving so soon and empty-handed?"
          if not go1 then failWith "brave soul!"
          else do
             go2 <- displayMore ColorBW
                     "Next time try to grab some loot before escape!"
             if not go2 then failWith "here's your chance!"
             else return $ Right ()
        else return $ Right ()
  _ -> return $ Right ()

-- | Guess and report why the bump command failed.
guessTrigger :: Kind.COps -> [TK.Feature] -> Kind.Id TileKind -> Msg
guessTrigger Kind.COps{cotile} fs@(TK.Cause (IK.Ascend k) : _) t
  | Tile.hasFeature cotile (TK.Cause (IK.Ascend (-k))) t =
    if k > 0 then "the way goes down, not up"
    else if k < 0 then "the way goes up, not down"
    else assert `failure` fs
guessTrigger _ fs@(TK.Cause (IK.Ascend k) : _) _ =
    if k > 0 then "cannot ascend"
    else if k < 0 then "cannot descend"
    else assert `failure` fs
guessTrigger _ _ _ = "never mind"

-- * RunOnceAhead

runOnceAheadHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)
runOnceAheadHuman = do
  side <- getsClient sside
  fact <- getsState $ (EM.! side) . sfactionD
  leader <- getLeaderUI
  srunning <- getsClient srunning
  -- When running, stop if disturbed. If not running, stop at once.
  case srunning of
    Nothing -> do
      stopPlayBack
      return $ Left mempty
    Just RunParams{runMembers}
      | noRunWithMulti fact && runMembers /= [leader] -> do
      stopPlayBack
      Config{configRunStopMsgs} <- askConfig
      if configRunStopMsgs
      then failWith "run stop: automatic leader change"
      else return $ Left mempty
    Just runParams -> do
      arena <- getArenaUI
      runOutcome <- continueRun arena runParams
      case runOutcome of
        Left stopMsg -> do
          stopPlayBack
          Config{configRunStopMsgs} <- askConfig
          if configRunStopMsgs
          then failWith $ "run stop:" <+> stopMsg
          else return $ Left mempty
        Right runCmd ->
          return $ Right runCmd

-- * MoveOnceToCursor

moveOnceToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)
moveOnceToCursorHuman = goToCursor True False

goToCursor :: MonadClientUI m
           => Bool -> Bool -> m (SlideOrCmd RequestAnyAbility)
goToCursor initialStep run = do
  tgtMode <- getsClient stgtMode
  -- Movement is legal only outside targeting mode.
  if isJust tgtMode then failWith "cannot move in aiming mode"
  else do
    leader <- getLeaderUI
    b <- getsState $ getActorBody leader
    cursorPos <- cursorToPos
    case cursorPos of
      Nothing -> failWith "crosshair position invalid"
      Just c | c == bpos b ->
        if initialStep
        then return $ Right $ RequestAnyAbility ReqWait
        else do
          report <- getsClient sreport
          if nullReport report
          then return $ Left mempty
          -- Mark that the messages are accumulated, not just from last move.
          else failWith "crosshair now reached"
      Just c -> do
        running <- getsClient srunning
        case running of
          -- Don't use running params from previous run or goto-cursor.
          Just paramOld | not initialStep -> do
            arena <- getArenaUI
            runOutcome <- multiActorGoTo arena c paramOld
            case runOutcome of
              Left stopMsg -> failWith stopMsg
              Right (finalGoal, dir) ->
                moveRunHuman initialStep finalGoal run False dir
          _ -> do
            let !_A = assert (initialStep || not run) ()
            (_, mpath) <- getCacheBfsAndPath leader c
            case mpath of
              Nothing -> failWith "no route to crosshair"
              Just [] -> assert `failure` (leader, b, c)
              Just (p1 : _) -> do
                let finalGoal = p1 == c
                    dir = towards (bpos b) p1
                moveRunHuman initialStep finalGoal run False dir

multiActorGoTo :: MonadClient m
               => LevelId -> Point -> RunParams
               -> m (Either Msg (Bool, Vector))
multiActorGoTo arena c paramOld =
  case paramOld of
    RunParams{runMembers = []} ->
      return $ Left "selected actors no longer there"
    RunParams{runMembers = r : rs, runWaiting} -> do
      onLevel <- getsState $ memActor r arena
      if not onLevel then do
        let paramNew = paramOld {runMembers = rs}
        multiActorGoTo arena c paramNew
      else do
        s <- getState
        modifyClient $ updateLeader r s
        let runMembersNew = rs ++ [r]
            paramNew = paramOld { runMembers = runMembersNew
                                , runWaiting = 0}
        b <- getsState $ getActorBody r
        (_, mpath) <- getCacheBfsAndPath r c
        case mpath of
          Nothing -> return $ Left "no route to crosshair"
          Just [] ->
            -- This actor already at goal; will be caught in goToCursor.
            return $ Left ""
          Just (p1 : _) -> do
            let finalGoal = p1 == c
                dir = towards (bpos b) p1
                tpos = bpos b `shift` dir
            tgts <- getsState $ posToActors tpos arena
            case tgts of
              [] -> do
                modifyClient $ \cli -> cli {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}
              _ ->
                 return $ Left "actor in the way"

-- * RunOnceToCursor

runOnceToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)
runOnceToCursorHuman = goToCursor True True

-- * ContinueToCursor

continueToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)
continueToCursorHuman = goToCursor False False{-irrelevant-}

-- * GameRestart; does not take time

gameRestartHuman :: MonadClientUI m => GroupName ModeKind -> m (SlideOrCmd RequestUI)
gameRestartHuman t = do
  let restart = do
        leader <- getLeaderUI
        DebugModeCli{sdifficultyCli} <- getsClient sdebugCli
        Config{configHeroNames} <- askConfig
        return $ Right
               $ ReqUIGameRestart leader t sdifficultyCli configHeroNames
  escAI <- getsClient sescAI
  if escAI == EscAIExited then restart
  else do
    let msg = "You just requested a new" <+> tshow t <+> "game."
    b1 <- displayMore ColorFull msg
    if not b1 then failWith "never mind"
    else do
      b2 <- displayYesNo ColorBW
              "Current progress will be lost! Really restart the game?"
      msg2 <- rndToAction $ oneOf
                [ "yea, would be a pity to leave them all to die"
                , "yea, a shame to get your own team stranded" ]
      if not b2 then failWith msg2
      else restart

-- * GameExit; does not take time

gameExitHuman :: MonadClientUI m => m (SlideOrCmd RequestUI)
gameExitHuman = do
  go <- displayYesNo ColorFull "Really save and exit?"
  if go then do
    leader <- getLeaderUI
    DebugModeCli{sdifficultyCli} <- getsClient sdebugCli
    return $ Right $ ReqUIGameExit leader sdifficultyCli
  else failWith "save and exit canceled"

-- * GameSave; does not take time

gameSaveHuman :: MonadClientUI m => m RequestUI
gameSaveHuman = do
  -- Announce before the saving started, since it can take some time
  -- and may slow down the machine, even if not block the client.
  -- TODO: do not save to history:
  msgAdd "Saving game backup."
  return ReqUIGameSave

-- * Tactic; does not take time

-- Note that the difference between seek-target and follow-the-leader tactic
-- 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.
-- TODO: set tactic for allied passive factions, too or all allied factions
-- and perhaps even factions with a leader should follow our leader
-- and his target, not their leader.
tacticHuman :: MonadClientUI m => m (SlideOrCmd RequestUI)
tacticHuman = do
  fid <- getsClient sside
  fromT <- getsState $ ftactic . gplayer . (EM.! fid) . sfactionD
  let toT = if fromT == maxBound then minBound else succ fromT
  go <- displayMore ColorFull
        $ "Switching tactic to"
          <+> tshow toT
          <> ". (This clears targets.)"
  if not go
    then failWith "tactic change canceled"
    else return $ Right $ ReqUITactic toT

-- * Automate; does not take time

automateHuman :: MonadClientUI m => m (SlideOrCmd RequestUI)
automateHuman = do
  -- BFS is not updated while automated, which would lead to corruption.
  modifyClient $ \cli -> cli {stgtMode = Nothing}
  escAI <- getsClient sescAI
  if escAI == EscAIExited then return $ Right ReqUIAutomate
  else do
    go <- displayMore ColorBW "Ceding control to AI (ESC to regain)."
    if not go
      then failWith "automation canceled"
      else return $ Right ReqUIAutomate