module Game.LambdaHack.Client.UI.HandleHumanGlobalClient
(
moveRunHuman, waitHuman, moveItemHuman, describeItemHuman
, projectHuman, applyHuman, alterDirHuman, triggerTileHuman
, runOnceAheadHuman, moveOnceToCursorHuman
, runOnceToCursorHuman, continueToCursorHuman
, 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.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
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
sel <- getsClient sselected
let runMembers = if runAhead || noRunWithMulti fact
then [leader]
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}
let tpos = bpos sb `shift` dir
tgts <- getsState $ posToActors tpos arena
case tgts of
[] -> do
runStopOrCmd <- moveSearchAlterAid leader dir
case runStopOrCmd of
Left stopMsg -> failWith stopMsg
Right runCmd ->
return $ Right runCmd
[(target, _)] | run && initialStep ->
fmap RequestAnyAbility <$> displaceAid target
_ : _ : _ | run && initialStep -> do
let !_A = assert (all (bproj . snd) tgts) ()
failSer DisplaceProjectiles
(target, tb) : _ | initialStep && finalGoal -> do
stopPlayBack
if bfid tb == bfid sb && not (bproj tb) then do
let autoLvl = snd $ autoDungeonLevel fact
if autoLvl then failSer NoChangeLvlLeader
else do
success <- pickLeader True target
let !_A = assert (success `blame` "bump self"
`twith` (leader, target, tb)) ()
return $ Left mempty
else
fmap RequestAnyAbility <$> meleeAid target
_ : _ -> failWith "actor in the way"
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
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
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
moveSearchAlterAid :: MonadClient m
=> ActorId -> Vector -> m (Either Msg RequestAnyAbility)
moveSearchAlterAid source dir = do
cops@Kind.COps{cotile} <- getsState scops
sb <- getsState $ getActorBody source
actorSk <- actorSkillsClient source
lvl <- getLevel $ blid sb
let skill = EM.findWithDefault 0 AbAlter actorSk
spos = bpos sb
tpos = spos `shift` dir
t = lvl `at` tpos
runStopOrCmd
| accessible cops lvl spos tpos =
Right $ RequestAnyAbility $ ReqMove dir
| not (Tile.isWalkable cotile t)
&& (not (knownLsecret lvl)
|| (isSecretPos lvl tpos
&& (Tile.isSuspect cotile t
|| Tile.hideAs cotile t /= t))
|| Tile.isOpenable cotile t
|| Tile.isClosable cotile t
|| Tile.isChangeable cotile t)
= if skill < 1 then
Left $ showReqFailure AlterUnskilled
else if EM.member tpos $ lfloor lvl then
Left $ showReqFailure AlterBlockItem
else
Right $ RequestAnyAbility $ ReqAlter tpos Nothing
| otherwise = Left "never mind"
return $! runStopOrCmd
waitHuman :: MonadClientUI m => m (RequestTimed 'AbWait)
waitHuman = do
modifyClient $ \cli -> cli {swaitTimes = abs (swaitTimes cli) + 1}
return ReqWait
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
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]
then case destCStore of
CEqp | calmE && goesIntoSha itemFull ->
retRec CSha
CEqp | not $ goesIntoEqp itemFull ->
retRec CInv
CEqp | eqpOverfull b (oldN + k) -> do
let fullWarn = if eqpOverfull b (oldN + 1)
then EqpOverfull
else EqpStackFull
msgAdd $ "Warning:" <+> showReqFailure fullWarn <> "."
retRec $ if calmE then CSha else CInv
_ ->
retRec destCStore
else case destCStore of
CEqp | eqpOverfull b (oldN + k) -> do
let fullWarn = if eqpOverfull b (oldN + 1)
then EqpOverfull
else EqpStackFull
failSer fullWarn
_ -> 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
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
describeItemHuman :: MonadClientUI m
=> ItemDialogMode -> m (SlideOrCmd (RequestTimed 'AbMoveItem))
describeItemHuman = describeItemC
projectHuman :: forall m. MonadClientUI m
=> [Trigger] -> m (SlideOrCmd (RequestTimed 'AbProject))
projectHuman ts = do
leader <- getLeaderUI
lidV <- viewedLevel
oldTgtMode <- getsClient stgtMode
modifyClient $ \cli -> cli {stgtMode = Just $ TgtMode lidV}
tgt <- getsClient $ getTarget leader
modifyClient $ \cli -> cli {scursor = fromMaybe (scursor cli) tgt}
let posFromCursor :: m (Either Msg Point)
posFromCursor = do
canAim <- aidTgtAims leader lidV Nothing
case canAim of
Right newEps -> do
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
lab <- getsState $ posToActors pos lid
if all (bproj . snd) lab
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
calmE = calmEnough b activeItems
cLegalRaw = [CGround, CInv, CEqp, CSha]
cLegal | calmE = cLegalRaw
| otherwise = delete CSha cLegalRaw
(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
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
cLegalRaw 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
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 calmE = calmEnough b activeItems
cLegalRaw = [CGround, CInv, CEqp, CSha]
cLegal | calmE = cLegalRaw
| otherwise = delete CSha cLegalRaw
(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 cLegalRaw 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
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")
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
actorSk <- actorSkillsClient leader
lvl <- getLevel $ blid b
as <- getsState $ actorList (const True) (blid b)
let skill = EM.findWithDefault 0 AbAlter actorSk
tpos = bpos b `shift` dir
t = lvl `at` tpos
alterFeats = alterFeatures ts
case filter (\feat -> Tile.hasFeature cotile feat t) alterFeats of
_ | skill < 1 -> failSer AlterUnskilled
[] -> 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
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"
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
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
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
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 ()
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"
runOnceAheadHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)
runOnceAheadHuman = do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
leader <- getLeaderUI
srunning <- getsClient srunning
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
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
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
else failWith "crosshair now reached"
Just c -> do
running <- getsClient srunning
case running of
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 [] ->
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 ->
multiActorGoTo arena c paramNew{runWaiting=runWaiting + 1}
_ ->
return $ Left "actor in the way"
runOnceToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)
runOnceToCursorHuman = goToCursor True True
continueToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)
continueToCursorHuman = goToCursor False False
gameRestartHuman :: MonadClientUI m => GroupName ModeKind -> m (SlideOrCmd RequestUI)
gameRestartHuman t = do
let restart = do
leader <- getLeaderUI
snxtDiff <- getsClient snxtDiff
Config{configHeroNames} <- askConfig
return $ Right
$ ReqUIGameRestart leader t snxtDiff 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
gameExitHuman :: MonadClientUI m => m (SlideOrCmd RequestUI)
gameExitHuman = do
go <- displayYesNo ColorFull "Really save and exit?"
if go then do
leader <- getLeaderUI
return $ Right $ ReqUIGameExit leader
else failWith "save and exit canceled"
gameSaveHuman :: MonadClientUI m => m RequestUI
gameSaveHuman = do
msgAdd "Saving game backup."
return ReqUIGameSave
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
$ "Current tactic is '" <> tshow fromT
<> "'. Switching tactic to '" <> tshow toT
<> "'. (This clears targets.)"
if not go
then failWith "tactic change canceled"
else return $ Right $ ReqUITactic toT
automateHuman :: MonadClientUI m => m (SlideOrCmd RequestUI)
automateHuman = do
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