{-# LANGUAGE DataKinds, GADTs #-}
module Game.LambdaHack.Client.UI.HandleHumanGlobalM
(
byAreaHuman, byAimModeHuman, byItemModeHuman
, composeIfLocalHuman, composeUnlessErrorHuman, compose2ndLocalHuman
, loopOnNothingHuman
, waitHuman, waitHuman10, moveRunHuman
, runOnceAheadHuman, moveOnceToXhairHuman
, runOnceToXhairHuman, continueToXhairHuman
, moveItemHuman, projectHuman, applyHuman
, alterDirHuman, alterWithPointerHuman
, helpHuman, itemMenuHuman, chooseItemMenuHuman
, mainMenuHuman, settingsMenuHuman, challengesMenuHuman
, gameDifficultyIncr, gameWolfToggle, gameFishToggle, gameScenarioIncr
, gameRestartHuman, gameExitHuman, gameSaveHuman
, tacticHuman, automateHuman
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Paths_LambdaHack as Self (version)
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.State
import Game.LambdaHack.Client.UI.ActorUI
import Game.LambdaHack.Client.UI.Config
import Game.LambdaHack.Client.UI.FrameM
import Game.LambdaHack.Client.UI.Frontend (frontendName)
import Game.LambdaHack.Client.UI.HandleHelperM
import Game.LambdaHack.Client.UI.HandleHumanLocalM
import Game.LambdaHack.Client.UI.HumanCmd (CmdArea (..), Trigger (..))
import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd
import Game.LambdaHack.Client.UI.InventoryM
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.RunM
import Game.LambdaHack.Client.UI.SessionUI
import Game.LambdaHack.Client.UI.Slideshow
import Game.LambdaHack.Client.UI.SlideshowM
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 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.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 Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Content.TileKind (TileKind)
import qualified Game.LambdaHack.Content.TileKind as TK
byAreaHuman :: MonadClientUI m
=> (HumanCmd.HumanCmd -> m (Either MError ReqUI))
-> [(HumanCmd.CmdArea, HumanCmd.HumanCmd)]
-> m (Either MError ReqUI)
byAreaHuman cmdAction l = do
pointer <- getsSession spointer
let pointerInArea a = do
rs <- areaToRectangles a
return $! any (inside pointer) rs
cmds <- filterM (pointerInArea . fst) l
case cmds of
[] -> do
stopPlayBack
return $ Left Nothing
(_, cmd) : _ ->
cmdAction cmd
areaToRectangles :: MonadClientUI m => HumanCmd.CmdArea -> m [(X, Y, X, Y)]
areaToRectangles ca = case ca of
CaMessage -> return [(0, 0, fst normalLevelBound, 0)]
CaMapLeader -> do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
let Point{..} = bpos b
return [(px, mapStartY + py, px, mapStartY + py)]
CaMapParty -> do
lidV <- viewedLevelUI
side <- getsClient sside
ours <- getsState $ filter (not . bproj) . map snd
. actorAssocs (== side) lidV
let rectFromB Point{..} = (px, mapStartY + py, px, mapStartY + py)
return $! map (rectFromB . bpos) ours
CaMap -> return
[( 0, mapStartY, fst normalLevelBound, mapStartY + snd normalLevelBound )]
CaLevelNumber -> let y = snd normalLevelBound + 2
in return [(0, y, 1, y)]
CaArenaName -> let y = snd normalLevelBound + 2
x = fst normalLevelBound `div` 2 - 11
in return [(3, y, x, y)]
CaPercentSeen -> let y = snd normalLevelBound + 2
x = fst normalLevelBound `div` 2
in return [(x - 9, y, x, y)]
CaXhairDesc -> let y = snd normalLevelBound + 2
x = fst normalLevelBound `div` 2 + 2
in return [(x, y, fst normalLevelBound, y)]
CaSelected -> let y = snd normalLevelBound + 3
x = fst normalLevelBound `div` 2
in return [(0, y, x - 24, y)]
CaCalmGauge -> let y = snd normalLevelBound + 3
x = fst normalLevelBound `div` 2
in return [(x - 22, y, x - 11, y)]
CaHPGauge -> let y = snd normalLevelBound + 3
x = fst normalLevelBound `div` 2
in return [(x - 9, y, x, y)]
CaTargetDesc -> let y = snd normalLevelBound + 3
x = fst normalLevelBound `div` 2 + 2
in return [(x, y, fst normalLevelBound, y)]
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
byItemModeHuman :: MonadClientUI m
=> [Trigger]
-> m (Either MError ReqUI) -> m (Either MError ReqUI)
-> m (Either MError ReqUI)
byItemModeHuman ts cmdNotChosenM cmdChosenM = do
itemSel <- getsSession sitemSel
let triggerSyms = triggerSymbols ts
case itemSel of
Just (fromCStore, iid) -> do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
bag <- getsState $ getBodyStoreBag b fromCStore
itemBase <- getsState $ getItemBody iid
case iid `EM.lookup` bag of
Just _ | ' ' `elem` triggerSyms
|| jsymbol itemBase `elem` triggerSyms -> cmdChosenM
_ -> cmdNotChosenM
Nothing -> cmdNotChosenM
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
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
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
req -> do
void c2
return req
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
waitHuman :: MonadClientUI m => m (RequestTimed 'AbWait)
waitHuman = do
modifySession $ \sess -> sess {swaitTimes = abs (swaitTimes sess) + 1}
return ReqWait
waitHuman10 :: MonadClientUI m => m (RequestTimed 'AbWait)
waitHuman10 = do
modifySession $ \sess -> sess {swaitTimes = abs (swaitTimes sess) + 1}
return ReqWait10
moveRunHuman :: MonadClientUI m
=> Bool -> Bool -> Bool -> Bool -> Vector
-> m (FailOrCmd RequestAnyAbility)
moveRunHuman initialStep finalGoal run runAhead dir = do
arena <- getArenaUI
leader <- getLeaderUI
sb <- getsState $ getActorBody leader
fact <- getsState $ (EM.! bfid sb) . sfactionD
sel <- getsSession 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 = ["C-comma", "C-V"]
when (initialStep && run) $ do
modifySession $ \cli ->
cli {srunning = Just runParams}
when runAhead $
modifySession $ \cli ->
cli {slastPlay = map K.mkKM macroRun25 ++ slastPlay cli}
let tpos = bpos sb `shift` dir
tgts <- getsState $ posToAssocs tpos arena
case tgts of
[] -> do
runStopOrCmd <- moveSearchAlter dir
case runStopOrCmd of
Left stopMsg -> return $ Left stopMsg
Right runCmd ->
return $ Right runCmd
[(target, _)] | run && initialStep ->
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
success <- pickLeader True target
let !_A = assert (success `blame` "bump self"
`swith` (leader, target, tb)) ()
failWith "by bumping"
else
RequestAnyAbility <$$> meleeAid target
_ : _ -> failWith "actor in the way"
meleeAid :: MonadClientUI m
=> ActorId -> m (FailOrCmd (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 = do
let f (Just (TEnemy _ b)) = Just $ TEnemy target b
f (Just (TPoint (TEnemyPos _ b) _ _)) = Just $ TEnemy target b
f _ = Just $ TEnemy target False
modifyClient $ updateTarget leader f
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 (FailOrCmd (RequestTimed 'AbDisplace))
displaceAid target = do
Kind.COps{coTileSpeedup} <- getsState scops
leader <- getLeaderUI
sb <- getsState $ getActorBody leader
tb <- getsState $ getActorBody target
tfact <- getsState $ (EM.! bfid tb) . sfactionD
actorMaxSk <- maxActorSkillsClient target
disp <- getsState $ dispEnemy leader target actorMaxSk
let immobile = EM.findWithDefault 0 AbMove actorMaxSk <= 0
tpos = bpos tb
adj = checkAdjacent sb tb
atWar = isAtWar tfact (bfid sb)
if | not adj -> failSer DisplaceDistant
| not (bproj tb) && atWar
&& actorDying tb ->
failSer DisplaceDying
| not (bproj tb) && atWar
&& braced tb ->
failSer DisplaceBraced
| not (bproj tb) && atWar
&& immobile ->
failSer DisplaceImmobile
| not disp && atWar ->
failSer DisplaceSupported
| otherwise -> do
let lid = blid sb
lvl <- getLevel lid
if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then
case posToAidsLvl tpos lvl of
[] -> error $ "" `showFailure` (leader, sb, target, tb)
[_] -> return $ Right $ ReqDisplace target
_ -> failSer DisplaceProjectiles
else failSer DisplaceAccess
moveSearchAlter :: MonadClientUI m => Vector -> m (FailOrCmd RequestAnyAbility)
moveSearchAlter dir = do
Kind.COps{coTileSpeedup} <- getsState scops
leader <- getLeaderUI
sb <- getsState $ getActorBody leader
actorSk <- leaderSkillsClientUI
lvl <- getLevel $ blid sb
let alterSkill = EM.findWithDefault 0 AbAlter actorSk
spos = bpos sb
tpos = spos `shift` dir
t = lvl `at` tpos
alterMinSkill = Tile.alterMinSkill coTileSpeedup t
runStopOrCmd <-
if | Tile.isWalkable coTileSpeedup t ->
return $ Right $ RequestAnyAbility $ ReqMove dir
| Tile.isSuspect coTileSpeedup t
|| Tile.isHideAs coTileSpeedup t
|| alterMinSkill < 10
|| alterMinSkill >= 10 && alterSkill >= alterMinSkill ->
if | alterSkill < alterMinSkill -> failSer AlterUnwalked
| EM.member tpos $ lfloor lvl -> failSer AlterBlockItem
| otherwise -> do
verAlters <- verifyAlters (blid sb) tpos
case verAlters of
Right() ->
return $ Right $ RequestAnyAbility $ ReqAlter tpos
Left err -> return $ Left err
| otherwise -> failWith "never mind"
return $! runStopOrCmd
runOnceAheadHuman :: MonadClientUI m => m (Either MError ReqUI)
runOnceAheadHuman = do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
leader <- getLeaderUI
Config{configRunStopMsgs} <- getsSession sconfig
keyPressed <- anyKeyPressed
srunning <- getsSession srunning
case srunning of
Nothing -> do
stopPlayBack
return $ Left Nothing
Just RunParams{runMembers}
| noRunWithMulti fact && runMembers /= [leader] -> do
stopPlayBack
if configRunStopMsgs
then weaveJust <$> failWith "run stop: automatic leader change"
else return $ Left Nothing
Just _runParams | keyPressed -> do
discardPressedKey
stopPlayBack
if configRunStopMsgs
then weaveJust <$> failWith "run stop: key pressed"
else weaveJust <$> failWith "interrupted"
Just runParams -> do
arena <- getArenaUI
runOutcome <- continueRun arena runParams
case runOutcome of
Left stopMsg -> do
stopPlayBack
if configRunStopMsgs
then weaveJust <$> failWith ("run stop:" <+> stopMsg)
else return $ Left Nothing
Right runCmd ->
return $ Right $ ReqUITimed runCmd
moveOnceToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestAnyAbility)
moveOnceToXhairHuman = goToXhair True False
goToXhair :: MonadClientUI m
=> Bool -> Bool -> m (FailOrCmd RequestAnyAbility)
goToXhair initialStep run = do
aimMode <- getsSession saimMode
if isJust aimMode then failWith "cannot move in aiming mode"
else do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
xhairPos <- xhairToPos
case xhairPos of
Nothing -> failWith "crosshair position invalid"
Just c | c == bpos b ->
if initialStep
then return $ Right $ RequestAnyAbility ReqWait
else failWith "position reached"
Just c -> do
running <- getsSession srunning
case running of
Just paramOld | not initialStep -> do
arena <- getArenaUI
runOutcome <- multiActorGoTo arena c paramOld
case runOutcome of
Left stopMsg -> return $ Left stopMsg
Right (finalGoal, dir) ->
moveRunHuman initialStep finalGoal run False dir
_ -> 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"
_ | initialStep && adjacent (bpos b) c -> do
let dir = towards (bpos b) c
moveRunHuman initialStep True run False dir
NoPath -> failWith "no route to crosshair"
AndPath{pathList=[]} -> failWith "almost there"
AndPath{pathList = p1 : _} -> do
let finalGoal = p1 == c
dir = towards (bpos b) p1
moveRunHuman initialStep finalGoal run False dir
multiActorGoTo :: 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
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
(bfs, mpath) <- getCacheBfsAndPath r c
xhairMoused <- getsSession sxhairMoused
case mpath of
_ | xhairMoused && isNothing (accessBfs bfs c) ->
failWith "no route to crosshair"
NoPath -> failWith "no route to crosshair"
AndPath{pathList=[]} -> failWith "almost there"
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 ->
multiActorGoTo arena c paramNew{runWaiting=runWaiting + 1}
_ ->
failWith "actor in the way"
runOnceToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestAnyAbility)
runOnceToXhairHuman = goToXhair True True
continueToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestAnyAbility)
continueToXhairHuman = goToXhair False False
moveItemHuman :: forall m. MonadClientUI m
=> [CStore] -> CStore -> Maybe MU.Part -> Bool
-> m (FailOrCmd (RequestTimed 'AbMoveItem))
moveItemHuman cLegalRaw destCStore mverb auto = do
itemSel <- getsSession sitemSel
modifySession $ \sess -> sess {sitemSel = Nothing}
case itemSel of
Just (fromCStore, iid) | fromCStore /= destCStore
&& fromCStore `elem` cLegalRaw -> do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
bag <- getsState $ getBodyStoreBag b fromCStore
case iid `EM.lookup` bag of
Nothing ->
moveItemHuman cLegalRaw destCStore mverb auto
Just (k, it) -> assert (k > 0) $ do
itemToF <- itemToFullClient
let eqpFree = eqpFreeN b
kToPick | destCStore == CEqp = min eqpFree k
| otherwise = k
if kToPick == 0
then failWith "no more items can be equipped"
else do
socK <- pickNumber (not auto) kToPick
case socK of
Left Nothing -> moveItemHuman cLegalRaw destCStore mverb auto
Left (Just err) -> return $ Left err
Right kChosen ->
let is = ( fromCStore
, [(iid, itemToF iid (kChosen, take kChosen it))] )
in moveItems cLegalRaw is destCStore
_ -> do
mis <- selectItemsToMove cLegalRaw destCStore mverb auto
case mis of
Left err -> return $ Left err
Right (fromCStore, [(iid, _)]) | cLegalRaw /= [CGround] -> do
modifySession $ \sess -> sess {sitemSel = Just (fromCStore, iid)}
moveItemHuman cLegalRaw destCStore mverb auto
Right is -> moveItems cLegalRaw is destCStore
selectItemsToMove :: forall m. MonadClientUI m
=> [CStore] -> CStore -> Maybe MU.Part -> Bool
-> m (FailOrCmd (CStore, [(ItemId, ItemFull)]))
selectItemsToMove 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
actorAspect <- getsClient sactorAspect
lastItemMove <- getsSession slastItemMove
let ar = fromMaybe (error $ "" `showFailure` leader)
(EM.lookup leader actorAspect)
calmE = calmEnough b ar
cLegalE | calmE = cLegalRaw
| destCStore == CSha = []
| otherwise = delete CSha cLegalRaw
cLegal = case lastItemMove of
Just (lastFrom, lastDest) | lastDest == destCStore
&& lastFrom `elem` cLegalE ->
lastFrom : delete lastFrom cLegalE
_ -> cLegalE
prompt = makePhrase ["What to", verb]
promptEqp = makePhrase ["What consumable to", verb]
(promptGeneric, psuit) =
if destCStore == CEqp && cLegalRaw /= [CGround]
then (promptEqp, return $ SuitsSomething $ \itemFull ->
goesIntoEqp $ itemBase itemFull)
else (prompt, return SuitsEverything)
ggi <- getFull psuit
(\_ _ _ cCur -> prompt <+> ppItemDialogModeFrom cCur)
(\_ _ _ cCur -> promptGeneric <+> ppItemDialogModeFrom cCur)
cLegalRaw cLegal (not auto) True
case ggi of
Right (l, (MStore fromCStore, _)) -> do
modifySession $ \sess ->
sess {slastItemMove = Just (fromCStore, destCStore)}
return $ Right (fromCStore, l)
Left err -> failWith err
_ -> error $ "" `showFailure` ggi
moveItems :: forall m. MonadClientUI m
=> [CStore] -> (CStore, [(ItemId, ItemFull)]) -> CStore
-> m (FailOrCmd (RequestTimed 'AbMoveItem))
moveItems cLegalRaw (fromCStore, l) destCStore = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
actorAspect <- getsClient sactorAspect
discoBenefit <- getsClient sdiscoBenefit
let ar = fromMaybe (error $ "" `showFailure` leader)
(EM.lookup leader actorAspect)
calmE = calmEnough b ar
ret4 :: MonadClientUI m
=> [(ItemId, ItemFull)]
-> Int -> [(ItemId, Int, CStore, CStore)]
-> m (FailOrCmd [(ItemId, Int, CStore, CStore)])
ret4 [] _ acc = return $ Right $ reverse acc
ret4 ((iid, itemFull) : rest) oldN acc = do
let k = itemK itemFull
!_A = assert (k > 0) ()
retRec toCStore =
let n = oldN + if toCStore == CEqp then k else 0
in ret4 rest n ((iid, k, fromCStore, toCStore) : acc)
inEqp = maybe (goesIntoEqp $ itemBase itemFull) benInEqp
(EM.lookup iid discoBenefit)
if cLegalRaw == [CGround]
then case destCStore of
CEqp | calmE && goesIntoSha (itemBase itemFull) ->
retRec CSha
CEqp | inEqp && 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
CEqp | inEqp ->
retRec CEqp
CEqp ->
retRec 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
if not calmE && CSha `elem` [fromCStore, destCStore]
then failSer ItemNotCalm
else do
l4 <- ret4 l 0 []
return $! case l4 of
Left err -> Left err
Right [] -> error $ "" `showFailure` l
Right lr -> Right $ ReqMoveItems lr
projectHuman :: MonadClientUI m
=> [Trigger] -> m (FailOrCmd (RequestTimed 'AbProject))
projectHuman ts = do
itemSel <- getsSession sitemSel
case itemSel of
Just (fromCStore, iid) -> do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
bag <- getsState $ getBodyStoreBag b fromCStore
case iid `EM.lookup` bag of
Nothing -> failWith "no item to fling"
Just kit -> do
itemToF <- itemToFullClient
let i = (fromCStore, (iid, itemToF iid kit))
projectItem ts i
Nothing -> failWith "no item to fling"
projectItem :: MonadClientUI m
=> [Trigger] -> (CStore, (ItemId, ItemFull))
-> m (FailOrCmd (RequestTimed 'AbProject))
projectItem ts (fromCStore, (iid, itemFull)) = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
actorAspect <- getsClient sactorAspect
let ar = fromMaybe (error $ "" `showFailure` leader)
(EM.lookup leader actorAspect)
calmE = calmEnough b ar
if not calmE && fromCStore == CSha then failSer ItemNotCalm
else do
mpsuitReq <- psuitReq ts
case mpsuitReq of
Left err -> failWith err
Right psuitReqFun ->
case psuitReqFun itemFull of
Left reqFail -> failSer reqFail
Right (pos, _) -> do
mposTgt <- leaderTgtToPos
unless (Just pos == mposTgt) $ do
sxhair <- getsSession sxhair
modifyClient $ updateTarget leader (const $ Just sxhair)
eps <- getsClient seps
return $ Right $ ReqProject pos eps iid fromCStore
applyHuman :: MonadClientUI m
=> [Trigger] -> m (FailOrCmd (RequestTimed 'AbApply))
applyHuman ts = do
itemSel <- getsSession sitemSel
case itemSel of
Just (fromCStore, iid) -> do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
bag <- getsState $ getBodyStoreBag b fromCStore
case iid `EM.lookup` bag of
Nothing -> failWith "no item to apply"
Just kit -> do
itemToF <- itemToFullClient
let i = (fromCStore, (iid, itemToF iid kit))
applyItem ts i
Nothing -> failWith "no item to apply"
applyItem :: MonadClientUI m
=> [Trigger] -> (CStore, (ItemId, ItemFull))
-> m (FailOrCmd (RequestTimed 'AbApply))
applyItem ts (fromCStore, (iid, itemFull)) = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
actorAspect <- getsClient sactorAspect
let ar = fromMaybe (error $ "" `showFailure` leader)
(EM.lookup leader actorAspect)
calmE = calmEnough b ar
if not calmE && fromCStore == CSha then failSer ItemNotCalm
else do
p <- permittedApplyClient $ triggerSymbols ts
case p itemFull of
Left reqFail -> failSer reqFail
Right _ -> return $ Right $ ReqApply iid fromCStore
alterDirHuman :: MonadClientUI m
=> [Trigger] -> m (FailOrCmd (RequestTimed 'AbAlter))
alterDirHuman ts = do
Config{configVi, configLaptop} <- getsSession sconfig
let verb1 = case ts of
[] -> "alter"
tr : _ -> verb tr
keys = K.escKM
: K.leftButtonReleaseKM
: map (K.KM K.NoModifier) (K.dirAllKey configVi configLaptop)
prompt = makePhrase
["Where to", verb1 <> "? [movement key] [pointer]"]
promptAdd prompt
slides <- reportToSlideshow [K.escKM]
km <- getConfirms ColorFull keys slides
case K.key km of
K.LeftButtonRelease -> do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
Point x y <- getsSession spointer
let dir = Point x (y - mapStartY) `vectorToFrom` bpos b
if isUnit dir
then alterTile ts dir
else failWith "never mind"
_ ->
case K.handleDir configVi configLaptop km of
Nothing -> failWith "never mind"
Just dir -> alterTile ts dir
alterTile :: MonadClientUI m
=> [Trigger] -> Vector -> m (FailOrCmd (RequestTimed 'AbAlter))
alterTile ts dir = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
let tpos = bpos b `shift` dir
pText = compassText dir
alterTileAtPos ts tpos pText
alterTileAtPos :: MonadClientUI m
=> [Trigger] -> Point -> Text
-> m (FailOrCmd (RequestTimed 'AbAlter))
alterTileAtPos ts tpos pText = do
cops@Kind.COps{cotile, coTileSpeedup} <- getsState scops
leader <- getLeaderUI
b <- getsState $ getActorBody leader
actorSk <- leaderSkillsClientUI
lvl <- getLevel $ blid b
let alterSkill = EM.findWithDefault 0 AbAlter actorSk
t = lvl `at` tpos
hasFeat AlterFeature{feature} = Tile.hasFeature cotile feature t
hasFeat _ = False
case filter hasFeat ts of
_ : _ | alterSkill < Tile.alterMinSkill coTileSpeedup t ->
failSer AlterUnskilled
[] -> failWith $ guessAlter cops ts t
tr : _ ->
if EM.notMember tpos $ lfloor lvl then
if null (posToAidsLvl tpos lvl) then do
verAlters <- verifyAlters (blid b) tpos
case verAlters of
Right() -> do
let msg = makeSentence ["you", verb tr, MU.Text pText]
msgAdd msg
return $ Right $ ReqAlter tpos
Left err -> return $ Left err
else failSer AlterBlockActor
else failSer AlterBlockItem
verifyAlters :: MonadClientUI m => LevelId -> Point -> m (FailOrCmd ())
verifyAlters lid p = do
Kind.COps{coTileSpeedup} <- getsState scops
lvl <- getLevel lid
let t = lvl `at` p
bag <- getsState $ getEmbedBag lid p
is <- mapM (getsState . getItemBody) $ EM.keys bag
let isE Item{jname} = jname == "escape"
if | any isE is -> verifyEscape
| null is && not (Tile.isDoor coTileSpeedup t
|| Tile.isChangable coTileSpeedup t) ->
failWith "never mind"
| otherwise -> return $ Right ()
verifyEscape :: MonadClientUI m => m (FailOrCmd ())
verifyEscape = do
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 side
if total == 0 then do
go1 <- displaySpaceEsc ColorBW
"Afraid of the challenge? Leaving so soon and empty-handed?"
if not go1 then failWith "brave soul!"
else do
go2 <- displaySpaceEsc 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 ()
guessAlter :: Kind.COps -> [Trigger] -> Kind.Id TileKind -> Text
guessAlter Kind.COps{cotile} (AlterFeature{feature=TK.OpenTo _} : _) t
| Tile.isClosable cotile t = "already open"
guessAlter _ (AlterFeature{feature=TK.OpenTo _} : _) _ = "cannot be opened"
guessAlter Kind.COps{cotile} (AlterFeature{feature=TK.CloseTo _} : _) t
| Tile.isOpenable cotile t = "already closed"
guessAlter _ (AlterFeature{feature=TK.CloseTo _} : _) _ = "cannot be closed"
guessAlter _ _ _ = "never mind"
alterWithPointerHuman :: MonadClientUI m
=> [Trigger] -> m (FailOrCmd (RequestTimed 'AbAlter))
alterWithPointerHuman ts = do
lidV <- viewedLevelUI
Level{lxsize, lysize} <- getLevel lidV
Point{..} <- getsSession spointer
if px >= 0 && py - mapStartY >= 0
&& px < lxsize && py - mapStartY < lysize
then do
let tpos = Point px (py - mapStartY)
alterTileAtPos ts tpos "the door"
else do
stopPlayBack
failWith "never mind"
helpHuman :: MonadClientUI m
=> (HumanCmd.HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
helpHuman cmdAction = do
lidV <- viewedLevelUI
Level{lxsize, lysize} <- getLevel lidV
keyb <- getsSession sbinding
menuIxMap <- getsSession smenuIxMap
let menuName = "help"
menuIx = fromMaybe 0 (M.lookup menuName menuIxMap)
keyH = keyHelp keyb 1
splitHelp (t, okx) =
splitOKX lxsize (lysize + 3) (textToAL t) [K.spaceKM, K.escKM] okx
sli = toSlideshow $ concat $ map splitHelp keyH
(ekm, pointer) <-
displayChoiceScreen ColorFull True menuIx sli [K.spaceKM, K.escKM]
modifySession $ \sess ->
sess { smenuIxMap = M.insert menuName pointer menuIxMap
, skeysHintMode = KeysHintBlocked }
case ekm of
Left km -> case km `M.lookup` bcmdMap keyb of
_ | km == K.escKM -> return $ Left Nothing
Just (_desc, _cats, cmd) -> cmdAction cmd
Nothing -> weaveJust <$> failWith "never mind"
Right _slot -> error $ "" `showFailure` ekm
itemMenuHuman :: MonadClientUI m
=> (HumanCmd.HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
itemMenuHuman cmdAction = do
itemSel <- getsSession sitemSel
case itemSel of
Just (fromCStore, iid) -> do
leader <- getLeaderUI
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
actorAspect <- getsClient sactorAspect
let ar = fromMaybe (error $ "" `showFailure` leader)
(EM.lookup leader actorAspect)
itemToF <- itemToFullClient
lidV <- viewedLevelUI
Level{lxsize, lysize} <- getLevel lidV
localTime <- getsState $ getLocalTime (blid b)
found <- getsState $ findIid leader (bfid b) iid
factionD <- getsState sfactionD
sactorUI <- getsSession sactorUI
let !_A = assert (not (null found) || fromCStore == CGround
`blame` (iid, leader)) ()
fAlt (aid, (_, store)) = aid /= leader || store /= fromCStore
foundAlt = filter fAlt found
foundUI = map (\(aid, bs) ->
(aid, bs, sactorUI EM.! aid)) foundAlt
foundKeys = map (K.KM K.NoModifier . K.Fun)
[1 .. length foundUI]
ppLoc bUI2 store =
let phr = makePhrase $ ppCStoreWownW False store
$ partActor bUI2
in "[" ++ T.unpack phr ++ "]"
foundTexts = map (\(_, (_, store), bUI2) ->
ppLoc bUI2 store) foundUI
foundPrefix = textToAL $
if null foundTexts then "" else "The item is also in:"
itemFull = itemToF iid kit
desc = itemDesc (bfid b) factionD (aHurtMelee ar)
fromCStore localTime itemFull
alPrefix = splitAttrLine lxsize $ desc <+:> foundPrefix
ystart = length alPrefix - 1
xstart = length (last alPrefix) + 1
ks = zip foundKeys $ map (\(_, (_, store), bUI2) ->
ppLoc bUI2 store) foundUI
(ovFoundRaw, kxsFound) = wrapOKX ystart xstart lxsize ks
ovFound = glueLines alPrefix ovFoundRaw
report <- getReportUI
keyb <- getsSession sbinding
let calmE = calmEnough b ar
greyedOut cmd = not calmE && fromCStore == CSha || case cmd of
HumanCmd.MoveItem stores destCStore _ _ ->
fromCStore `notElem` stores
|| not calmE && CSha == destCStore
|| destCStore == CEqp && eqpOverfull b 1
_ -> False
fmt n k h = " " <> T.justifyLeft n ' ' k <+> h
keyL = 11
keyCaption = fmt keyL "keys" "command"
offset = 1 + length ovFound
(ov0, kxs0) = okxsN keyb offset keyL greyedOut
HumanCmd.CmdItemMenu [keyCaption] []
t0 = makeSentence [ MU.SubjectVerbSg (partActor bUI) "choose"
, "an item", MU.Text $ ppCStoreIn fromCStore ]
al1 = renderReport report <+:> textToAL t0
splitHelp (al, okx) =
splitOKX lxsize (lysize + 1) al [K.spaceKM, K.escKM] okx
sli = toSlideshow
$ splitHelp (al1, (ovFound ++ ov0, kxsFound ++ kxs0))
ix = 2 + length foundKeys
extraKeys = [K.spaceKM, K.escKM] ++ foundKeys
recordHistory
(ekm, _) <- displayChoiceScreen ColorFull False ix sli extraKeys
case ekm of
Left km -> case km `M.lookup` bcmdMap keyb of
_ | km == K.escKM -> weaveJust <$> failWith "never mind"
_ | km == K.spaceKM -> return $ Left Nothing
_ | km `elem` foundKeys -> case km of
K.KM{key=K.Fun n} -> do
let (newAid, (bNew, newCStore)) = foundAlt !! (n - 1)
fact <- getsState $ (EM.! bfid bNew) . sfactionD
let (autoDun, _) = autoDungeonLevel fact
if | blid bNew /= blid b && autoDun ->
weaveJust <$> failSer NoChangeDunLeader
| otherwise -> do
void $ pickLeader True newAid
modifySession $ \sess ->
sess {sitemSel = Just (newCStore, iid)}
itemMenuHuman cmdAction
_ -> error $ "" `showFailure` km
Just (_desc, _cats, cmd) -> cmdAction cmd
Nothing -> weaveJust <$> failWith "never mind"
Right _slot -> error $ "" `showFailure` ekm
Nothing -> weaveJust <$> failWith "no item to open Item Menu for"
chooseItemMenuHuman :: MonadClientUI m
=> (HumanCmd.HumanCmd -> m (Either MError ReqUI))
-> ItemDialogMode
-> m (Either MError ReqUI)
chooseItemMenuHuman cmdAction c = do
res <- chooseItemDialogMode c
case res of
Right c2 -> do
res2 <- itemMenuHuman cmdAction
case res2 of
Left Nothing -> chooseItemMenuHuman cmdAction c2
_ -> return res2
Left err -> return $ Left $ Just err
artWithVersion :: MonadClientUI m => m [String]
artWithVersion = do
Kind.COps{corule} <- getsState scops
let stdRuleset = Kind.stdRuleset corule
pasteVersion :: [Text] -> [String]
pasteVersion art =
let exeVersion = rexeVersion stdRuleset
libVersion = Self.version
version = "Version " ++ showVersion exeVersion
++ " (frontend: " ++ frontendName
++ ", engine: LambdaHack " ++ showVersion libVersion
++ ") "
versionLen = length version
lastOriginal = last art
(prefix, versionSuffix) = T.breakOn "Version" lastOriginal
suffix = drop versionLen $ T.unpack versionSuffix
overfillLen = versionLen - T.length versionSuffix
prefixModified = T.unpack $ T.dropEnd overfillLen prefix
lastModified = prefixModified ++ version ++ suffix
in map T.unpack (init art) ++ [lastModified]
mainMenuArt = rmainMenuArt stdRuleset
return $! pasteVersion $ T.lines mainMenuArt
generateMenu :: MonadClientUI m
=> (HumanCmd.HumanCmd -> m (Either MError ReqUI))
-> [(K.KM, (Text, HumanCmd.HumanCmd))] -> [String] -> String
-> m (Either MError ReqUI)
generateMenu cmdAction kds gameInfo menuName = do
art <- artWithVersion
let bindingLen = 30
emptyInfo = repeat $ replicate bindingLen ' '
bindings =
let fmt (k, (d, _)) =
( Just k
, T.unpack
$ T.justifyLeft bindingLen ' '
$ T.justifyLeft 3 ' ' (T.pack $ K.showKM k) <> " " <> d )
in map fmt kds
overwrite :: [(Int, String)] -> [(String, Maybe KYX)]
overwrite =
let over [] (_, line) = ([], (line, Nothing))
over bs@((mkey, binding) : bsRest) (y, line) =
let (prefix, lineRest) = break (=='{') line
(braces, suffix) = span (=='{') lineRest
in if length braces >= bindingLen
then
let lenB = length binding
post = drop (lenB - length braces) suffix
len = length prefix
yxx key = (Left [key], (y, len, len + lenB))
myxx = yxx <$> mkey
in (bsRest, (prefix <> binding <> post, myxx))
else (bs, (line, Nothing))
in snd . mapAccumL over (zip (repeat Nothing) gameInfo
++ bindings
++ zip (repeat Nothing) emptyInfo)
menuOverwritten = overwrite $ zip [0..] art
(menuOvLines, mkyxs) = unzip menuOverwritten
kyxs = catMaybes mkyxs
ov = map stringToAL menuOvLines
menuIxMap <- getsSession smenuIxMap
let menuIx = fromMaybe 0 (M.lookup menuName menuIxMap)
(ekm, pointer) <- displayChoiceScreen ColorFull True menuIx
(menuToSlideshow (ov, kyxs)) [K.escKM]
modifySession $ \sess ->
sess {smenuIxMap = M.insert menuName pointer menuIxMap}
case ekm of
Left km -> case km `lookup` kds of
Just (_desc, cmd) -> cmdAction cmd
Nothing -> weaveJust <$> failWith "never mind"
Right _slot -> error $ "" `showFailure` ekm
mainMenuHuman :: MonadClientUI m
=> (HumanCmd.HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
mainMenuHuman cmdAction = do
cops <- getsState scops
Binding{bcmdList} <- getsSession sbinding
gameMode <- getGameMode
snxtScenario <- getsClient snxtScenario
let nxtGameName = mname $ nxtGameMode cops snxtScenario
tnextScenario = "new scenario:" <+> nxtGameName
kds = (K.mkKM "s", (tnextScenario, HumanCmd.GameScenarioIncr))
: [ (km, (desc, cmd))
| (km, ([HumanCmd.CmdMainMenu], desc, cmd)) <- bcmdList ]
bindingLen = 30
gameName = mname gameMode
gameInfo = map T.unpack
[ T.justifyLeft bindingLen ' ' ""
, T.justifyLeft bindingLen ' '
$ "Now playing:" <+> gameName
, T.justifyLeft bindingLen ' ' "" ]
generateMenu cmdAction kds gameInfo "main"
settingsMenuHuman :: MonadClientUI m
=> (HumanCmd.HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
settingsMenuHuman cmdAction = do
markSuspect <- getsClient smarkSuspect
markVision <- getsSession smarkVision
markSmell <- getsSession smarkSmell
side <- getsClient sside
factTactic <- getsState $ ftactic . gplayer . (EM.! side) . sfactionD
let offOn b = if b then "on" else "off"
offOnAll n = case n of
0 -> "off"
1 -> "on"
2 -> "all"
_ -> error $ "" `showFailure` n
tsuspect = "suspect terrain:" <+> offOnAll markSuspect
tvisible = "visible zone:" <+> offOn markVision
tsmell = "smell clues:" <+> offOn markSmell
thenchmen = "tactic:" <+> tshow factTactic
kds = [ (K.mkKM "s", (tsuspect, HumanCmd.MarkSuspect))
, (K.mkKM "v", (tvisible, HumanCmd.MarkVision))
, (K.mkKM "c", (tsmell, HumanCmd.MarkSmell))
, (K.mkKM "t", (thenchmen, HumanCmd.Tactic))
, (K.mkKM "Escape", ("back to main menu", HumanCmd.MainMenu)) ]
bindingLen = 30
gameInfo = map T.unpack
[ T.justifyLeft bindingLen ' ' ""
, T.justifyLeft bindingLen ' ' "Convenience settings:"
, T.justifyLeft bindingLen ' ' "" ]
generateMenu cmdAction kds gameInfo "settings"
challengesMenuHuman :: MonadClientUI m
=> (HumanCmd.HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
challengesMenuHuman cmdAction = do
curChal <- getsClient scurChal
nxtChal <- getsClient snxtChal
let offOn b = if b then "on" else "off"
tcurDiff = "* difficulty:" <+> tshow (cdiff curChal)
tnextDiff = "difficulty:" <+> tshow (cdiff nxtChal)
tcurWolf = "* lone wolf:"
<+> offOn (cwolf curChal)
tnextWolf = "lone wolf:"
<+> offOn (cwolf nxtChal)
tcurFish = "* cold fish:"
<+> offOn (cfish curChal)
tnextFish = "cold fish:"
<+> offOn (cfish nxtChal)
kds = [ (K.mkKM "d", (tnextDiff, HumanCmd.GameDifficultyIncr))
, (K.mkKM "w", (tnextWolf, HumanCmd.GameWolfToggle))
, (K.mkKM "f", (tnextFish, HumanCmd.GameFishToggle))
, (K.mkKM "Escape", ("back to main menu", HumanCmd.MainMenu)) ]
bindingLen = 30
gameInfo = map T.unpack
[ T.justifyLeft bindingLen ' ' "Current challenges:"
, T.justifyLeft bindingLen ' ' ""
, T.justifyLeft bindingLen ' ' tcurDiff
, T.justifyLeft bindingLen ' ' tcurWolf
, T.justifyLeft bindingLen ' ' tcurFish
, T.justifyLeft bindingLen ' ' ""
, T.justifyLeft bindingLen ' ' "New game challenges:"
, T.justifyLeft bindingLen ' ' "" ]
generateMenu cmdAction kds gameInfo "challenge"
gameScenarioIncr :: MonadClientUI m => m ()
gameScenarioIncr =
modifyClient $ \cli -> cli {snxtScenario = snxtScenario cli + 1}
gameDifficultyIncr :: MonadClientUI m => m ()
gameDifficultyIncr = do
nxtDiff <- getsClient $ cdiff . snxtChal
let delta = 1
d | nxtDiff + delta > difficultyBound = 1
| nxtDiff + delta < 1 = difficultyBound
| otherwise = nxtDiff + delta
modifyClient $ \cli -> cli {snxtChal = (snxtChal cli) {cdiff = d} }
gameWolfToggle :: MonadClientUI m => m ()
gameWolfToggle =
modifyClient $ \cli ->
cli {snxtChal = (snxtChal cli) {cwolf = not (cwolf (snxtChal cli))} }
gameFishToggle :: MonadClientUI m => m ()
gameFishToggle =
modifyClient $ \cli ->
cli {snxtChal = (snxtChal cli) {cfish = not (cfish (snxtChal cli))} }
gameRestartHuman :: MonadClientUI m => m (FailOrCmd ReqUI)
gameRestartHuman = do
cops <- getsState scops
isNoConfirms <- isNoConfirmsGame
gameMode <- getGameMode
snxtScenario <- getsClient snxtScenario
let nxtGameName = mname $ nxtGameMode cops snxtScenario
b <- if isNoConfirms
then return True
else displayYesNo ColorBW
$ "You just requested a new" <+> nxtGameName
<+> "game. The progress of the ongoing" <+> mname gameMode
<+> "game will be lost! Are you sure?"
if b
then do
snxtChal <- getsClient snxtChal
let nxtGameGroup = toGroupName $ head $ T.words nxtGameName
return $ Right $ ReqUIGameRestart nxtGameGroup snxtChal
else do
msg2 <- rndToActionForget $ oneOf
[ "yea, would be a pity to leave them all to die"
, "yea, a shame to get your team stranded" ]
failWith msg2
nxtGameMode :: Kind.COps -> Int -> ModeKind
nxtGameMode Kind.COps{comode=Kind.Ops{ofoldlGroup'}} snxtScenario =
let f acc _p _i a = a : acc
campaignModes = ofoldlGroup' "campaign scenario" f []
in campaignModes !! (snxtScenario `mod` length campaignModes)
gameExitHuman :: MonadClientUI m => m ReqUI
gameExitHuman = do
promptAdd "Saving game. The program stops now."
return ReqUIGameExit
gameSaveHuman :: MonadClientUI m => m ReqUI
gameSaveHuman = do
promptAdd "Saving game backup."
return ReqUIGameSave
tacticHuman :: MonadClientUI m => m (FailOrCmd ReqUI)
tacticHuman = do
fid <- getsClient sside
fromT <- getsState $ ftactic . gplayer . (EM.! fid) . sfactionD
let toT = if fromT == maxBound then minBound else succ fromT
go <- displaySpaceEsc ColorFull
$ "(Beware, work in progress!)"
<+> "Current henchmen tactic is" <+> tshow fromT
<+> "(" <> describeTactic fromT <> ")."
<+> "Switching tactic to" <+> tshow toT
<+> "(" <> describeTactic toT <> ")."
<+> "This clears targets of all henchmen (non-leader teammates)."
<+> "New targets will be picked according to new tactic."
if not go
then failWith "tactic change canceled"
else return $ Right $ ReqUITactic toT
automateHuman :: MonadClientUI m => m (FailOrCmd ReqUI)
automateHuman = do
clearAimMode
go <- displaySpaceEsc ColorBW
"Ceding control to AI (press ESC to regain)."
if not go
then failWith "automation canceled"
else return $ Right ReqUIAutomate