module Game.LambdaHack.Client.UI.HandleHumanGlobalM
(
byAreaHuman, byAimModeHuman
, composeIfLocalHuman, composeUnlessErrorHuman, compose2ndLocalHuman
, loopOnNothingHuman, executeIfClearHuman
, waitHuman, waitHuman10, yellHuman, moveRunHuman
, runOnceAheadHuman, moveOnceToXhairHuman
, runOnceToXhairHuman, continueToXhairHuman
, moveItemHuman, projectHuman, applyHuman
, alterDirHuman, alterWithPointerHuman
, helpHuman, hintHuman, dashboardHuman, itemMenuHuman, chooseItemMenuHuman
, mainMenuHuman, settingsMenuHuman, challengesMenuHuman
, gameScenarioIncr, gameDifficultyIncr, gameWolfToggle, gameFishToggle
, gameRestartHuman, gameDropHuman, gameExitHuman, gameSaveHuman
, tacticHuman, automateHuman
#ifdef EXPOSE_INTERNAL
, areaToRectangles, meleeAid, displaceAid, moveSearchAlter, goToXhair
, multiActorGoTo, moveOrSelectItem, selectItemsToMove, moveItems, projectItem
, applyItem, alterTile, alterTileAtPos, verifyAlters, verifyEscape, guessAlter
, artWithVersion, generateMenu, nxtGameMode
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.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.Request
import Game.LambdaHack.Client.State
import Game.LambdaHack.Client.UI.ActorUI
import Game.LambdaHack.Client.UI.Content.Input
import Game.LambdaHack.Client.UI.Content.Screen
import Game.LambdaHack.Client.UI.ContentClientUI
import Game.LambdaHack.Client.UI.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
import Game.LambdaHack.Client.UI.InventoryM
import Game.LambdaHack.Client.UI.ItemDescription
import qualified Game.LambdaHack.Client.UI.Key as K
import Game.LambdaHack.Client.UI.KeyBindings
import Game.LambdaHack.Client.UI.MonadClientUI
import Game.LambdaHack.Client.UI.Msg
import Game.LambdaHack.Client.UI.MsgM
import Game.LambdaHack.Client.UI.Overlay
import Game.LambdaHack.Client.UI.RunM
import Game.LambdaHack.Client.UI.SessionUI
import Game.LambdaHack.Client.UI.Slideshow
import Game.LambdaHack.Client.UI.SlideshowM
import Game.LambdaHack.Client.UI.UIOptions
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Area
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.ItemAspect as IA
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.ReqFailure
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Common.Vector
import qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Content.TileKind (TileKind)
import qualified Game.LambdaHack.Content.TileKind as TK
import Game.LambdaHack.Core.Random
import qualified Game.LambdaHack.Definition.Ability as Ability
import Game.LambdaHack.Definition.Defs
byAreaHuman :: MonadClientUI m
=> (HumanCmd -> m (Either MError ReqUI))
-> [(CmdArea, HumanCmd)]
-> m (Either MError ReqUI)
byAreaHuman cmdAction l = do
pointer <- getsSession spointer
let pointerInArea a = do
rs <- areaToRectangles a
return $! any (inside pointer) $ catMaybes rs
cmds <- filterM (pointerInArea . fst) l
case cmds of
[] -> do
stopPlayBack
return $ Left Nothing
(_, cmd) : _ ->
cmdAction cmd
areaToRectangles :: MonadClientUI m => CmdArea -> m [Maybe Area]
areaToRectangles ca = map toArea <$> do
CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui
case ca of
CaMessage -> return [(0, 0, rwidth - 1, 0)]
CaMapLeader -> do
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, rwidth - 1, mapStartY + rheight - 4 )]
CaLevelNumber -> let y = rheight - 2
in return [(0, y, 1, y)]
CaArenaName -> let y = rheight - 2
x = (rwidth - 1) `div` 2 - 11
in return [(3, y, x, y)]
CaPercentSeen -> let y = rheight - 2
x = (rwidth - 1) `div` 2
in return [(x - 9, y, x, y)]
CaXhairDesc -> let y = rheight - 2
x = (rwidth - 1) `div` 2 + 2
in return [(x, y, rwidth - 1, y)]
CaSelected -> let y = rheight - 1
x = (rwidth - 1) `div` 2
in return [(0, y, x - 24, y)]
CaCalmGauge -> let y = rheight - 1
x = (rwidth - 1) `div` 2
in return [(x - 22, y, x - 18, y)]
CaCalmValue -> let y = rheight - 1
x = (rwidth - 1) `div` 2
in return [(x - 17, y, x - 11, y)]
CaHPGauge -> let y = rheight - 1
x = (rwidth - 1) `div` 2
in return [(x - 9, y, x - 6, y)]
CaHPValue -> let y = rheight - 1
x = (rwidth - 1) `div` 2
in return [(x - 6, y, x, y)]
CaLeaderDesc -> let y = rheight - 1
x = (rwidth - 1) `div` 2 + 2
in return [(x, y, rwidth - 1, y)]
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
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
executeIfClearHuman :: MonadClientUI m
=> m (Either MError ReqUI)
-> m (Either MError ReqUI)
executeIfClearHuman c1 = do
sreportNull <- getsSession sreportNull
if sreportNull then c1 else return $ Left Nothing
waitHuman :: MonadClientUI m => m (FailOrCmd RequestTimed)
waitHuman = do
actorSk <- leaderSkillsClientUI
if Ability.getSk Ability.SkWait actorSk > 0 then do
modifySession $ \sess -> sess {swaitTimes = abs (swaitTimes sess) + 1}
return $ Right ReqWait
else failSer WaitUnskilled
waitHuman10 :: MonadClientUI m => m (FailOrCmd RequestTimed)
waitHuman10 = do
actorSk <- leaderSkillsClientUI
if Ability.getSk Ability.SkWait actorSk >= 4 then do
modifySession $ \sess -> sess {swaitTimes = abs (swaitTimes sess) + 1}
return $ Right ReqWait10
else failSer WaitUnskilled
yellHuman :: MonadClientUI m => m (FailOrCmd RequestTimed)
yellHuman = do
actorSk <- leaderSkillsClientUI
if Ability.getSk Ability.SkWait actorSk > 0
|| Ability.getSk Ability.SkMove actorSk <= 0
|| Ability.getSk Ability.SkDisplace actorSk <= 0
|| Ability.getSk Ability.SkMelee actorSk <= 0
then return $ Right ReqYell
else failSer WaitUnskilled
moveRunHuman :: (MonadClient m, MonadClientUI m)
=> Bool -> Bool -> Bool -> Bool -> Vector
-> m (FailOrCmd RequestTimed)
moveRunHuman initialStep finalGoal run runAhead dir = do
actorSk <- leaderSkillsClientUI
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 $ posToAidAssocs tpos arena
case tgts of
[] -> do
runStopOrCmd <- moveSearchAlter run dir
case runStopOrCmd of
Left stopMsg -> return $ Left stopMsg
Right runCmd ->
return $ Right runCmd
[(target, _)] | run
&& initialStep
&& Ability.getSk Ability.SkDisplace actorSk > 0 ->
displaceAid target
_ : _ : _ | run
&& initialStep
&& Ability.getSk Ability.SkDisplace actorSk > 0 ->
failSer DisplaceMultiple
(target, tb) : _ | not run
&& initialStep && finalGoal
&& bfid tb == bfid sb && not (bproj tb) -> do
stopPlayBack
success <- pickLeader True target
let !_A = assert (success `blame` "bump self"
`swith` (leader, target, tb)) ()
failWith "by bumping"
(target, tb) : _ | not run
&& initialStep && finalGoal
&& (bfid tb /= bfid sb || bproj tb)
&& Ability.getSk Ability.SkMelee actorSk > 0 -> do
stopPlayBack
meleeAid target
_ : _ -> failWith "actor in the way"
meleeAid :: (MonadClient m, MonadClientUI m)
=> ActorId -> m (FailOrCmd RequestTimed)
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
modifyClient $ updateTarget leader $ const $ Just $ TEnemy target
modifySession $ \sess -> sess {sxhair = Just $ TEnemy target}
return $ Right wp
res | bproj tb || isFoe (bfid sb) sfact (bfid tb) = returnCmd
| isFriend (bfid sb) sfact (bfid tb) = do
let !_A = assert (bfid sb /= bfid tb) ()
go1 <- displayYesNo ColorBW
"You are bound by an alliance. Really attack?"
if not go1 then failWith "attack canceled" else returnCmd
| otherwise = do
go2 <- displayYesNo ColorBW
"This attack will start a war. Are you sure?"
if not go2 then failWith "attack canceled" else returnCmd
res
displaceAid :: MonadClientUI m
=> ActorId -> m (FailOrCmd RequestTimed)
displaceAid target = do
COps{coTileSpeedup} <- getsState scops
leader <- getLeaderUI
sb <- getsState $ getActorBody leader
tb <- getsState $ getActorBody target
let dozes = bwatch tb `elem` [WSleep, WWake]
tfact <- getsState $ (EM.! bfid tb) . sfactionD
actorMaxSk <- getsState $ getActorMaxSkills target
dEnemy <- getsState $ dispEnemy leader target actorMaxSk
let immobile = Ability.getSk Ability.SkMove actorMaxSk <= 0
tpos = bpos tb
adj = checkAdjacent sb tb
atWar = isFoe (bfid tb) tfact (bfid sb)
if | not adj -> failSer DisplaceDistant
| not (bproj tb) && atWar
&& actorDying tb ->
failSer DisplaceDying
| not (bproj tb) && atWar
&& actorWaits tb ->
failSer DisplaceBraced
| not (bproj tb) && atWar
&& immobile && not dozes ->
failSer DisplaceImmobile
| not dEnemy && 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 DisplaceMultiple
else failSer DisplaceAccess
moveSearchAlter :: MonadClientUI m
=> Bool -> Vector -> m (FailOrCmd RequestTimed)
moveSearchAlter run dir = do
COps{cotile, coTileSpeedup} <- getsState scops
actorSk <- leaderSkillsClientUI
leader <- getLeaderUI
sb <- getsState $ getActorBody leader
actorMaxSk <- getsState $ getActorMaxSkills leader
let calmE = calmEnough sb actorMaxSk
moveSkill = Ability.getSk Ability.SkMove actorSk
alterSkill = Ability.getSk Ability.SkAlter actorSk
applySkill = Ability.getSk Ability.SkApply actorSk
spos = bpos sb
tpos = spos `shift` dir
itemToF <- getsState $ flip itemToFull
localTime <- getsState $ getLocalTime (blid sb)
embeds <- getsState $ getEmbedBag (blid sb) tpos
lvl <- getLevel $ blid sb
blurb <- lookAtPosition (blid sb) tpos
let t = lvl `at` tpos
alterMinSkill = Tile.alterMinSkill coTileSpeedup t
canApplyEmbeds = any canApplyEmbed $ EM.assocs embeds
canApplyEmbed (iid, kit) =
let itemFull = itemToF iid
legal = permittedApply localTime applySkill calmE itemFull kit
in either (const False) (const True) legal
alterable = Tile.isModifiable coTileSpeedup t || not (EM.null embeds)
underFeet = tpos == spos
runStopOrCmd <-
if
| Tile.isWalkable coTileSpeedup t ->
if moveSkill > 0 then
return $ Right $ ReqMove dir
else failSer MoveUnskilled
| run -> do
promptAdd0 blurb
failWith $ if alterable
then "potentially alterable"
else "not alterable"
| not alterable -> do
let name = MU.Text $ TK.tname $ okind cotile t
failWith $ makePhrase ["there is no point kicking", MU.AW name]
| not underFeet && alterSkill <= 1 -> failSer AlterUnskilled
| not (Tile.isSuspect coTileSpeedup t)
&& not underFeet
&& alterSkill < alterMinSkill -> do
promptAdd0 blurb
failSer AlterUnwalked
| not $ Tile.isModifiable coTileSpeedup t || canApplyEmbeds -> do
promptAdd0 blurb
failWith "unable to exploit the terrain"
| EM.member tpos $ lfloor lvl -> failSer AlterBlockItem
| occupiedBigLvl tpos lvl || occupiedProjLvl tpos lvl ->
failSer AlterBlockActor
| otherwise -> do
verAlters <- verifyAlters (blid sb) tpos
case verAlters of
Right () -> return $ Right $ ReqAlter tpos
Left err -> return $ Left err
return $! runStopOrCmd
runOnceAheadHuman :: MonadClientUI m => m (Either MError RequestTimed)
runOnceAheadHuman = do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
leader <- getLeaderUI
keyPressed <- anyKeyPressed
srunning <- getsSession srunning
case srunning of
Nothing -> do
stopPlayBack
return $ Left Nothing
Just RunParams{runMembers}
| noRunWithMulti fact && runMembers /= [leader] -> do
stopPlayBack
msgAdd MsgRunStop "run stop: automatic leader change"
return $ Left Nothing
Just _runParams | keyPressed -> do
discardPressedKey
stopPlayBack
msgAdd MsgRunStop "run stop: key pressed"
weaveJust <$> failWith "interrupted"
Just runParams -> do
arena <- getArenaUI
runOutcome <- continueRun arena runParams
case runOutcome of
Left stopMsg -> do
stopPlayBack
msgAdd MsgRunStop ("run stop:" <+> stopMsg)
return $ Left Nothing
Right runCmd ->
return $ Right runCmd
moveOnceToXhairHuman :: (MonadClient m, MonadClientUI m)
=> m (FailOrCmd RequestTimed)
moveOnceToXhairHuman = goToXhair True False
goToXhair :: (MonadClient m, MonadClientUI m)
=> Bool -> Bool -> m (FailOrCmd RequestTimed)
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 -> 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 (press again to go there anyway)"
_ | initialStep && adjacent (bpos b) c -> do
let dir = towards (bpos b) c
moveRunHuman initialStep True run False dir
Nothing -> failWith "no route to crosshair"
Just AndPath{pathList=[]} -> failWith "almost there"
Just AndPath{pathList = p1 : _} -> do
let finalGoal = p1 == c
dir = towards (bpos b) p1
moveRunHuman initialStep finalGoal run False dir
multiActorGoTo :: (MonadClient m, MonadClientUI m)
=> LevelId -> Point -> RunParams -> m (FailOrCmd (Bool, Vector))
multiActorGoTo arena c paramOld =
case paramOld of
RunParams{runMembers = []} -> failWith "selected actors no longer there"
RunParams{runMembers = r : rs, runWaiting} -> do
onLevel <- getsState $ memActor r arena
if not onLevel then do
let paramNew = paramOld {runMembers = rs}
multiActorGoTo arena c paramNew
else do
sL <- getState
modifyClient $ updateLeader r sL
let runMembersNew = rs ++ [r]
paramNew = paramOld { runMembers = runMembersNew
, runWaiting = 0}
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 (press again to go there anyway)"
Nothing -> failWith "no route to crosshair"
Just AndPath{pathList=[]} -> failWith "almost there"
Just AndPath{pathList = p1 : _} -> do
let finalGoal = p1 == c
dir = towards (bpos b) p1
tgts <- getsState $ posToAids p1 arena
case tgts of
[] -> do
modifySession $ \sess -> sess {srunning = Just paramNew}
return $ Right (finalGoal, dir)
[target] | target `elem` rs || runWaiting <= length rs ->
multiActorGoTo arena c paramNew{runWaiting=runWaiting + 1}
_ ->
failWith "actor in the way"
runOnceToXhairHuman :: (MonadClient m, MonadClientUI m)
=> m (FailOrCmd RequestTimed)
runOnceToXhairHuman = goToXhair True True
continueToXhairHuman :: (MonadClient m, MonadClientUI m)
=> m (FailOrCmd RequestTimed)
continueToXhairHuman = goToXhair False False
moveItemHuman :: forall m. MonadClientUI m
=> [CStore] -> CStore -> Maybe MU.Part -> Bool
-> m (FailOrCmd RequestTimed)
moveItemHuman cLegalRaw destCStore mverb auto = do
actorSk <- leaderSkillsClientUI
if Ability.getSk Ability.SkMoveItem actorSk > 0 then
moveOrSelectItem cLegalRaw destCStore mverb auto
else failSer MoveItemUnskilled
moveOrSelectItem :: forall m. MonadClientUI m
=> [CStore] -> CStore -> Maybe MU.Part -> Bool
-> m (FailOrCmd RequestTimed)
moveOrSelectItem cLegalRaw destCStore mverb auto = do
itemSel <- getsSession sitemSel
modifySession $ \sess -> sess {sitemSel = Nothing}
case itemSel of
Just (iid, fromCStore, _) | 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
itemFull <- getsState $ itemToFull iid
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, (itemFull, (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 (iid, fromCStore, False)}
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, ItemFullKit)]))
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
actorMaxSk <- getsState $ getActorMaxSkills leader
lastItemMove <- getsSession slastItemMove
let calmE = calmEnough b actorMaxSk
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 _kit ->
IA.goesIntoEqp $ aspectRecordFull 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, ItemFullKit)]) -> CStore
-> m (FailOrCmd RequestTimed)
moveItems cLegalRaw (fromCStore, l) destCStore = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
actorMaxSk <- getsState $ getActorMaxSkills leader
discoBenefit <- getsClient sdiscoBenefit
let calmE = calmEnough b actorMaxSk
ret4 :: [(ItemId, ItemFullKit)] -> Int
-> m [(ItemId, Int, CStore, CStore)]
ret4 [] _ = return []
ret4 ((iid, (itemFull, (itemK, _))) : rest) oldN = do
let k = itemK
!_A = assert (k > 0) ()
inEqp = benInEqp $ discoBenefit EM.! iid
retRec toCStore = do
let n = oldN + if toCStore == CEqp then k else 0
l4 <- ret4 rest n
return $ (iid, k, fromCStore, toCStore) : l4
issueWarning = do
let fullWarn = if eqpOverfull b (oldN + 1)
then EqpOverfull
else EqpStackFull
msgAdd MsgWarning $ "Warning:" <+> showReqFailure fullWarn <> "."
if cLegalRaw == [CGround]
then case destCStore of
CEqp | calmE && IA.goesIntoSha (aspectRecordFull itemFull) ->
retRec CSha
CEqp | inEqp && eqpOverfull b (oldN + k) -> do
issueWarning
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
issueWarning
return []
_ -> retRec destCStore
if not calmE && CSha `elem` [fromCStore, destCStore]
then failSer ItemNotCalm
else do
l4 <- ret4 l 0
return $! if null l4
then error $ "" `showFailure` l
else Right $ ReqMoveItems l4
projectHuman :: (MonadClient m, MonadClientUI m) => m (FailOrCmd RequestTimed)
projectHuman = do
actorSk <- leaderSkillsClientUI
if Ability.getSk Ability.SkProject actorSk <= 0 then
failSer ProjectUnskilled
else do
itemSel <- getsSession sitemSel
case itemSel of
Just (iid, fromCStore, _) -> 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
itemFull <- getsState $ itemToFull iid
let i = (fromCStore, (iid, itemFull))
projectItem i
Nothing -> failWith "no item to fling"
projectItem :: (MonadClient m, MonadClientUI m)
=> (CStore, (ItemId, ItemFull))
-> m (FailOrCmd RequestTimed)
projectItem (fromCStore, (iid, itemFull)) = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
actorMaxSk <- getsState $ getActorMaxSkills leader
let calmE = calmEnough b actorMaxSk
if not calmE && fromCStore == CSha then failSer ItemNotCalm
else do
mpsuitReq <- psuitReq
case mpsuitReq of
Left err -> failWith err
Right psuitReqFun ->
case psuitReqFun itemFull of
Left reqFail -> failSer reqFail
Right (pos, _) -> do
Benefit{benFling} <- getsClient $ (EM.! iid) . sdiscoBenefit
go <- if benFling > 0
then displayYesNo ColorFull
"The item appears beneficial. Do you really want to fling it?"
else return True
if go then do
sxhair <- getsSession sxhair
modifyClient $ updateTarget leader (const sxhair)
eps <- getsClient seps
return $ Right $ ReqProject pos eps iid fromCStore
else do
modifySession $ \sess -> sess {sitemSel = Nothing}
failWith "never mind"
applyHuman :: MonadClientUI m => m (FailOrCmd RequestTimed)
applyHuman = do
actorSk <- leaderSkillsClientUI
if Ability.getSk Ability.SkApply actorSk <= 0 then
failSer ApplyUnskilled
else do
itemSel <- getsSession sitemSel
case itemSel of
Just (iid, fromCStore, _) -> 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
itemFull <- getsState $ itemToFull iid
applyItem (fromCStore, (iid, (itemFull, kit)))
Nothing -> failWith "no item to apply"
applyItem :: MonadClientUI m
=> (CStore, (ItemId, ItemFullKit))
-> m (FailOrCmd RequestTimed)
applyItem (fromCStore, (iid, (itemFull, kit))) = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
localTime <- getsState $ getLocalTime (blid b)
actorMaxSk <- getsState $ getActorMaxSkills leader
actorSk <- leaderSkillsClientUI
let skill = Ability.getSk Ability.SkApply actorSk
calmE = calmEnough b actorMaxSk
arItem = aspectRecordFull itemFull
if not calmE && fromCStore == CSha
then failSer ItemNotCalm
else case permittedApply localTime skill calmE itemFull kit of
Left reqFail -> failSer reqFail
Right _ -> do
Benefit{benApply} <- getsClient $ (EM.! iid) . sdiscoBenefit
go <-
if | IA.checkFlag Ability.Periodic arItem
&& not (IA.checkFlag Ability.Durable arItem) ->
displayYesNo ColorFull
"Applying this periodic item will produce only the first of its effects and moreover, because it's not durable, will destroy it. Are you sure?"
| benApply < 0 ->
displayYesNo ColorFull
"The item appears harmful. Do you really want to apply it?"
| otherwise -> return True
if go
then return $ Right $ ReqApply iid fromCStore
else do
modifySession $ \sess -> sess {sitemSel = Nothing}
failWith "never mind"
alterDirHuman :: MonadClientUI m
=> [TriggerTile] -> m (FailOrCmd RequestTimed)
alterDirHuman ts = do
UIOptions{uVi, uLaptop} <- getsSession sUIOptions
let verb1 = case ts of
[] -> "alter"
tr : _ -> ttverb tr
keys = K.escKM
: K.leftButtonReleaseKM
: map (K.KM K.NoModifier) (K.dirAllKey uVi uLaptop)
prompt = makePhrase
["Where to", verb1 <> "? [movement key] [pointer]"]
promptAdd0 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 uVi uLaptop km of
Nothing -> failWith "never mind"
Just dir -> alterTile ts dir
alterTile :: MonadClientUI m
=> [TriggerTile] -> Vector -> m (FailOrCmd RequestTimed)
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
=> [TriggerTile] -> Point -> Text
-> m (FailOrCmd RequestTimed)
alterTileAtPos ts tpos pText = do
cops@COps{cotile, coTileSpeedup} <- getsState scops
leader <- getLeaderUI
b <- getsState $ getActorBody leader
actorSk <- leaderSkillsClientUI
lvl <- getLevel $ blid b
embeds <- getsState $ getEmbedBag (blid b) tpos
let alterSkill = Ability.getSk Ability.SkAlter actorSk
t = lvl `at` tpos
alterMinSkill = Tile.alterMinSkill coTileSpeedup t
hasFeat TriggerTile{ttfeature} = Tile.hasFeature cotile ttfeature t
case filter hasFeat ts of
[] | not $ null ts -> failWith $ guessAlter cops ts t
_ | not (Tile.isModifiable coTileSpeedup t)
&& EM.null embeds -> failSer AlterNothing
_ | chessDist tpos (bpos b) > 1 -> failSer AlterDistant
_ | alterSkill <= 1 -> failSer AlterUnskilled
_ | not (Tile.isSuspect coTileSpeedup t)
&& alterSkill < alterMinSkill -> failSer AlterUnwalked
trs ->
if EM.notMember tpos $ lfloor lvl then
if not (occupiedBigLvl tpos lvl)
&& not (occupiedProjLvl tpos lvl) then do
let v = case trs of
[] -> "alter"
tr : _ -> ttverb tr
verAlters <- verifyAlters (blid b) tpos
case verAlters of
Right () -> do
let msg = makeSentence ["you", v, MU.Text pText]
msgAdd MsgDone 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
COps{coTileSpeedup} <- getsState scops
lvl <- getLevel lid
let t = lvl `at` p
bag <- getsState $ getEmbedBag lid p
getKind <- getsState $ flip getIidKind
let ks = map getKind $ EM.keys bag
if | any (any IK.isEffEscape . IK.ieffects) ks -> verifyEscape
| null ks && not (Tile.isModifiable 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
(_, total) <- getsState $ calculateTotal side
dungeonTotal <- getsState sgold
let prompt | dungeonTotal == 0 =
"You finally reached the way out. Really leave now?"
| total == 0 =
"Afraid of the challenge? Leaving so soon and without any treasure? Are you sure?"
| total < dungeonTotal =
"You finally found the way out, but still more valuables are rumoured to hide around here. Really leave already?"
| otherwise =
"This is the way out and you collected all treasure there is to find. Really leave now?"
go <- displayYesNo ColorBW prompt
if not go
then failWith "here's your chance!"
else return $ Right ()
guessAlter :: COps -> [TriggerTile] -> ContentId TileKind -> Text
guessAlter COps{cotile} (TriggerTile{ttfeature=TK.OpenTo _} : _) t
| Tile.isClosable cotile t = "already open"
guessAlter _ (TriggerTile{ttfeature=TK.OpenTo _} : _) _ = "cannot be opened"
guessAlter COps{cotile} (TriggerTile{ttfeature=TK.CloseTo _} : _) t
| Tile.isOpenable cotile t = "already closed"
guessAlter _ (TriggerTile{ttfeature=TK.CloseTo _} : _) _ = "cannot be closed"
guessAlter _ _ _ = "never mind"
alterWithPointerHuman :: MonadClientUI m
=> [TriggerTile] -> m (FailOrCmd RequestTimed)
alterWithPointerHuman ts = do
COps{corule=RuleContent{rXmax, rYmax}, cotile} <- getsState scops
lidV <- viewedLevelUI
lvl <- getLevel lidV
Point{..} <- getsSession spointer
let tpos = Point px (py - mapStartY)
t = lvl `at` tpos
if px >= 0 && py - mapStartY >= 0
&& px < rXmax && py - mapStartY < rYmax
then alterTileAtPos ts tpos $ "the" <+> TK.tname (okind cotile t)
else failWith "never mind"
helpHuman :: MonadClientUI m
=> (HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
helpHuman cmdAction = do
cops <- getsState scops
ccui@CCUI{coinput, coscreen=ScreenContent{rwidth, rheight}}
<- getsSession sccui
let keyH = keyHelp cops ccui 1
splitHelp (t, okx) =
splitOKX rwidth rheight (textToAL t) [K.spaceKM, K.escKM] okx
sli = toSlideshow $ concat $ map splitHelp keyH
ekm <- displayChoiceScreen "help" ColorFull True sli [K.spaceKM, K.escKM]
case ekm of
Left km -> case km `M.lookup` bcmdMap coinput of
_ | km `elem` [K.escKM, K.spaceKM] -> return $ Left Nothing
Just (_desc, _cats, cmd) -> cmdAction cmd
Nothing -> weaveJust <$> failWith "never mind"
Right _slot -> error $ "" `showFailure` ekm
hintHuman :: MonadClientUI m
=> (HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
hintHuman cmdAction = do
hintMode <- getsSession shintMode
if hintMode == HintWiped then
helpHuman cmdAction
else do
modifySession $ \sess -> sess {shintMode = HintShown}
promptMainKeys
return $ Left Nothing
dashboardHuman :: MonadClientUI m
=> (HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
dashboardHuman cmdAction = do
CCUI{coinput, coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui
let keyL = 2
(ov0, kxs0) = okxsN coinput 1 keyL (const False) False
CmdDashboard [] []
al1 = textToAL "Dashboard"
splitHelp (al, okx) = splitOKX rwidth (rheight - 2) al [K.escKM] okx
sli = toSlideshow $ splitHelp (al1, (ov0, kxs0))
extraKeys = [K.escKM]
ekm <- displayChoiceScreen "dashboard" ColorFull False sli extraKeys
case ekm of
Left km -> case km `M.lookup` bcmdMap coinput of
_ | km == K.escKM -> weaveJust <$> failWith "never mind"
Just (_desc, _cats, cmd) -> cmdAction cmd
Nothing -> weaveJust <$> failWith "never mind"
Right _slot -> error $ "" `showFailure` ekm
itemMenuHuman :: MonadClientUI m
=> (HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
itemMenuHuman cmdAction = do
itemSel <- getsSession sitemSel
case itemSel of
Just (iid, fromCStore, _) -> 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
CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui
actorMaxSk <- getsState $ getActorMaxSkills leader
itemFull <- getsState $ itemToFull iid
localTime <- getsState $ getLocalTime (blid b)
found <- getsState $ findIid leader (bfid b) iid
factionD <- getsState sfactionD
sactorUI <- getsSession sactorUI
jlid <- getsSession $ (EM.! iid) . sitemUI
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:"
markParagraphs = rheight >= 45
desc = itemDesc markParagraphs (bfid b) factionD
(Ability.getSk Ability.SkHurtMelee actorMaxSk)
fromCStore localTime jlid itemFull kit
alPrefix = splitAttrLine rwidth $ 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 rwidth ks
ovFound = glueLines alPrefix ovFoundRaw
report <- getReportUI
CCUI{coinput} <- getsSession sccui
actorSk <- leaderSkillsClientUI
let calmE = calmEnough b actorMaxSk
greyedOut cmd = not calmE && fromCStore == CSha || case cmd of
ByAimMode AimModeCmd{..} ->
greyedOut exploration || greyedOut aiming
ComposeIfLocal cmd1 cmd2 -> greyedOut cmd1 || greyedOut cmd2
ComposeUnlessError cmd1 cmd2 -> greyedOut cmd1 || greyedOut cmd2
Compose2ndLocal cmd1 cmd2 -> greyedOut cmd1 || greyedOut cmd2
MoveItem stores destCStore _ _ ->
fromCStore `notElem` stores
|| not calmE && CSha == destCStore
|| destCStore == CEqp && eqpOverfull b 1
Apply{} ->
let skill = Ability.getSk Ability.SkApply actorSk
in not $ either (const False) id
$ permittedApply localTime skill calmE itemFull kit
Project{} ->
let skill = Ability.getSk Ability.SkProject actorSk
in not $ either (const False) id
$ permittedProject False skill calmE itemFull
_ -> False
fmt n k h = " " <> T.justifyLeft n ' ' k <+> h
keyL = 11
keyCaption = fmt keyL "keys" "command"
offset = 1 + length ovFound
(ov0, kxs0) = okxsN coinput offset keyL greyedOut True
CmdItemMenu [keyCaption] []
t0 = makeSentence [ MU.SubjectVerbSg (partActor bUI) "choose"
, "an item", MU.Text $ ppCStoreIn fromCStore ]
al1 = renderReport report <+:> textToAL t0
splitHelp (al, okx) =
splitOKX rwidth (rheight - 2) al [K.spaceKM, K.escKM] okx
sli = toSlideshow
$ splitHelp (al1, (ovFound ++ ov0, kxsFound ++ kxs0))
extraKeys = [K.spaceKM, K.escKM] ++ foundKeys
recordHistory
ekm <- displayChoiceScreen "item menu" ColorFull False sli extraKeys
case ekm of
Left km -> case km `M.lookup` bcmdMap coinput of
_ | km == K.escKM -> weaveJust <$> failWith "never mind"
_ | km == K.spaceKM -> 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 (iid, newCStore, False)}
itemMenuHuman cmdAction
_ -> error $ "" `showFailure` km
Just (_desc, _cats, cmd) -> do
modifySession $ \sess ->
sess {sitemSel = Just (iid, fromCStore, True)}
res <- cmdAction cmd
modifySession $ \sess ->
sess {sitemSel = Just (iid, fromCStore, False)}
return res
Nothing -> weaveJust <$> failWith "never mind"
Right _slot -> error $ "" `showFailure` ekm
Nothing -> weaveJust <$> failWith "no item to open item menu for"
chooseItemMenuHuman :: MonadClientUI m
=> (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
artAtSize :: MonadClientUI m => m [Text]
artAtSize = do
CCUI{coscreen=ScreenContent{rwidth, rheight, rmainMenuArt}} <-
getsSession sccui
let tlines = T.lines rmainMenuArt
xoffset = (80 - rwidth) `div` 2
yoffset = (length tlines - rheight) `div` 2
f = T.take rwidth . T.drop xoffset
return $! map f $ take rheight $ drop yoffset tlines
artWithVersion :: MonadClientUI m => m [String]
artWithVersion = do
COps{corule} <- getsState scops
let pasteVersion :: [Text] -> [String]
pasteVersion art =
let exeVersion = rexeVersion corule
libVersion = Self.version
version = " Version " ++ showVersion exeVersion
++ " (frontend: " ++ frontendName
++ ", engine: LambdaHack " ++ showVersion libVersion
++ ") "
versionLen = length version
f line =
let (prefix, versionSuffix) = T.breakOn "Version" line
in if T.null versionSuffix then T.unpack line else
let suffix = drop versionLen $ T.unpack versionSuffix
overfillLen = versionLen - T.length versionSuffix
prefixModified = T.unpack $ T.dropEnd overfillLen prefix
in prefixModified ++ version ++ suffix
in map f art
mainMenuArt <- artAtSize
return $! pasteVersion mainMenuArt
generateMenu :: MonadClientUI m
=> (HumanCmd -> m (Either MError ReqUI))
-> [(K.KM, (Text, 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
ekm <- displayChoiceScreen menuName ColorFull True
(menuToSlideshow (ov, kyxs)) [K.escKM]
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 -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
mainMenuHuman cmdAction = do
cops <- getsState scops
CCUI{coinput=InputContent{bcmdList}} <- getsSession sccui
gameMode <- getGameMode
snxtScenario <- getsClient snxtScenario
let nxtGameName = mname $ nxtGameMode cops snxtScenario
tnextScenario = "pick next:" <+> nxtGameName
kds = (K.mkKM "p", (tnextScenario, GameScenarioIncr))
: [ (km, (desc, cmd))
| (km, ([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 -> 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 -> "low"
1 -> "medium"
2 -> "high"
_ -> error $ "" `showFailure` n
tsuspect = "suspect terrain:" <+> offOnAll markSuspect
tvisible = "visible zone:" <+> offOn markVision
tsmell = "smell clues:" <+> offOn markSmell
thenchmen = "tactic:" <+> Ability.nameTactic factTactic
kds = [ (K.mkKM "s", (tsuspect, MarkSuspect))
, (K.mkKM "v", (tvisible, MarkVision))
, (K.mkKM "c", (tsmell, MarkSmell))
, (K.mkKM "t", (thenchmen, Tactic))
, (K.mkKM "Escape", ("back to main menu", 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 -> 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, GameDifficultyIncr))
, (K.mkKM "w", (tnextWolf, GameWolfToggle))
, (K.mkKM "f", (tnextFish, GameFishToggle))
, (K.mkKM "Escape", ("back to main menu", 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 ' ' "Next game challenges:"
, T.justifyLeft bindingLen ' ' "" ]
generateMenu cmdAction kds gameInfo "challenge"
gameScenarioIncr :: MonadClient m => m ()
gameScenarioIncr =
modifyClient $ \cli -> cli {snxtScenario = snxtScenario cli + 1}
gameDifficultyIncr :: MonadClient 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 :: MonadClient m => m ()
gameWolfToggle =
modifyClient $ \cli ->
cli {snxtChal = (snxtChal cli) {cwolf = not (cwolf (snxtChal cli))} }
gameFishToggle :: MonadClient 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 to die"
, "yea, a shame to get your team stranded" ]
failWith msg2
nxtGameMode :: COps -> Int -> ModeKind
nxtGameMode COps{comode} snxtScenario =
let f !acc _p _i !a = a : acc
campaignModes = ofoldlGroup' comode "campaign scenario" f []
in campaignModes !! (snxtScenario `mod` length campaignModes)
gameDropHuman :: MonadClientUI m => m ReqUI
gameDropHuman = do
modifySession $ \sess -> sess {sallNframes = -1}
promptAdd0 "Interrupt! Trashing the unsaved game. The program exits now."
clientPrintUI "Interrupt! Trashing the unsaved game. The program exits now."
return ReqUIGameDropAndExit
gameExitHuman :: MonadClientUI m => m ReqUI
gameExitHuman = do
promptAdd0 "Saving game. The program stops now."
return ReqUIGameSaveAndExit
gameSaveHuman :: MonadClientUI m => m ReqUI
gameSaveHuman = do
promptAdd0 "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" <+> Ability.nameTactic fromT
<+> "(" <> Ability.describeTactic fromT <> ")."
<+> "Switching tactic to" <+> Ability.nameTactic toT
<+> "(" <> Ability.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