module Game.LambdaHack.Client.UI.HandleHumanLocalM
(
macroHuman
, sortSlotsHuman, chooseItemHuman, chooseItemDialogMode
, chooseItemProjectHuman, chooseItemApplyHuman
, psuitReq, triggerSymbols, permittedApplyClient
, pickLeaderHuman, pickLeaderWithPointerHuman
, memberCycleHuman, memberBackHuman
, selectActorHuman, selectNoneHuman, selectWithPointerHuman
, repeatHuman, recordHuman, historyHuman
, markVisionHuman, markSmellHuman, markSuspectHuman, printScreenHuman
, cancelHuman, acceptHuman, tgtClearHuman, itemClearHuman
, moveXhairHuman, aimTgtHuman, aimFloorHuman, aimEnemyHuman, aimItemHuman
, aimAscendHuman, epsIncrHuman
, xhairUnknownHuman, xhairItemHuman, xhairStairHuman
, xhairPointerFloorHuman, xhairPointerEnemyHuman
, aimPointerFloorHuman, aimPointerEnemyHuman
#ifdef EXPOSE_INTERNAL
, permittedProjectClient, projectCheck, xhairLegalEps, posFromXhair
, selectAid, endAiming, endAimingMsg, doLook, flashAiming
, xhairPointerFloor, xhairPointerEnemy
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Ord
import qualified Data.Text as T
import qualified NLP.Miniutter.English as MU
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.Animation
import Game.LambdaHack.Client.UI.DrawM
import Game.LambdaHack.Client.UI.EffectDescription
import Game.LambdaHack.Client.UI.FrameM
import Game.LambdaHack.Client.UI.HandleHelperM
import Game.LambdaHack.Client.UI.HumanCmd
import Game.LambdaHack.Client.UI.InventoryM
import Game.LambdaHack.Client.UI.ItemDescription
import Game.LambdaHack.Client.UI.ItemSlot
import qualified Game.LambdaHack.Client.UI.Key as K
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.SessionUI
import Game.LambdaHack.Client.UI.SlideshowM
import Game.LambdaHack.Client.UI.UIOptions
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.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.Perception
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.Time
import Game.LambdaHack.Common.Vector
import qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.ModeKind (fhasGender)
macroHuman :: MonadClientUI m => [String] -> m ()
macroHuman kms = do
modifySession $ \sess -> sess {slastPlay = map K.mkKM kms ++ slastPlay sess}
UIOptions{uRunStopMsgs} <- getsSession sUIOptions
when uRunStopMsgs $
promptAdd1 $ "Macro activated:" <+> T.pack (intercalate " " kms)
sortSlotsHuman :: MonadClientUI m => m ()
sortSlotsHuman = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
sortSlots (bfid b) (Just b)
promptAdd1 "Items sorted by kind and stats."
chooseItemHuman :: MonadClientUI m => ItemDialogMode -> m MError
chooseItemHuman c = either Just (const Nothing) <$> chooseItemDialogMode c
chooseItemDialogMode :: MonadClientUI m
=> ItemDialogMode -> m (FailOrCmd ItemDialogMode)
chooseItemDialogMode c = do
let subject = partActor
verbSha body ar = if calmEnough body ar
then "notice"
else "paw distractedly"
prompt body bodyUI ar c2 =
let (tIn, t) = ppItemDialogMode c2
in case c2 of
MStore CGround ->
makePhrase
[ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "notice"
, MU.Text "at"
, MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text "feet" ]
MStore CSha ->
makePhrase
[ MU.Capitalize
$ MU.SubjectVerbSg (subject bodyUI) (verbSha body ar)
, MU.Text tIn
, MU.Text t ]
MOrgans ->
makePhrase
[ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "feel"
, MU.Text tIn
, MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ]
MOwned ->
makePhrase
[ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "recall"
, MU.Text tIn
, MU.Text t ]
MStats ->
makePhrase
[ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "estimate"
, MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ]
MLore{} ->
makePhrase
[ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "recall"
, MU.Text t ]
_ ->
makePhrase
[ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "see"
, MU.Text tIn
, MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ]
ggi <- getStoreItem prompt c
recordHistory
lidV <- viewedLevelUI
leader <- getLeaderUI
b <- getsState $ getActorBody leader
bUI <- getsSession $ getActorUI leader
itemToF <- getsState $ flip itemToFull
localTime <- getsState $ getLocalTime (blid b)
factionD <- getsState sfactionD
ar <- getsState $ getActorAspect leader
Level{lxsize, lysize} <- getLevel lidV
case ggi of
(Right (iid, itemBag, lSlots), (c2, _)) -> do
let lSlotsElems = EM.elems lSlots
lSlotsBound = length lSlotsElems - 1
displayLore slotIndex promptFun = do
let iid2 = lSlotsElems !! slotIndex
itemFull2 = itemToF iid2
kit2 = itemBag EM.! iid2
attrLine = itemDesc True (bfid b) factionD (IA.aHurtMelee ar)
CGround localTime itemFull2 kit2
ov = splitAttrLine lxsize attrLine
keys = [K.spaceKM, K.escKM]
++ [K.upKM | slotIndex /= 0]
++ [K.downKM | slotIndex /= lSlotsBound]
promptAdd0 $ promptFun $ itemKind itemFull2
slides <- overlayToSlideshow (lysize + 1) keys (ov, [])
km <- getConfirms ColorFull keys slides
case K.key km of
K.Space -> chooseItemDialogMode c2
K.Up -> displayLore (slotIndex - 1) promptFun
K.Down -> displayLore (slotIndex + 1) promptFun
K.Esc -> failWith "never mind"
_ -> error $ "" `showFailure` km
ix0 = fromJust $ findIndex (== iid) lSlotsElems
case c2 of
MStore fromCStore -> do
modifySession $ \sess ->
sess {sitemSel = Just (iid, fromCStore, False)}
return $ Right c2
MOrgans -> do
let blurb itemKind
| IK.isTmpCondition itemKind = "condition"
| otherwise = "organ"
prompt2 itemKind = makeSentence [ partActor bUI, "can't remove"
, MU.AW $ blurb itemKind ]
displayLore ix0 prompt2
MOwned -> do
found <- getsState $ findIid leader (bfid b) iid
let (newAid, bestStore) = case leader `lookup` found of
Just (_, store) -> (leader, store)
Nothing -> case found of
(aid, (_, store)) : _ -> (aid, store)
[] -> error $ "" `showFailure` iid
modifySession $ \sess ->
sess {sitemSel = Just (iid, bestStore, False)}
arena <- getArenaUI
b2 <- getsState $ getActorBody newAid
fact <- getsState $ (EM.! bfid b2) . sfactionD
let (autoDun, _) = autoDungeonLevel fact
if | blid b2 /= arena && autoDun ->
failSer NoChangeDunLeader
| otherwise -> do
void $ pickLeader True newAid
return $ Right c2
MStats -> error $ "" `showFailure` ggi
MLore slore -> displayLore ix0 $ const $
makeSentence [ MU.SubjectVerbSg (partActor bUI) "remember"
, MU.Text (ppSLore slore), "lore" ]
(Left err, (MStats, ekm)) -> case ekm of
Right slot0 -> assert (err == "stats") $ do
let statListBound = length statSlots - 1
displayOneStat slotIndex = do
let slot = allSlots !! slotIndex
eqpSlot = statSlots !! fromJust (elemIndex slot allSlots)
valueText =
slotToDecorator eqpSlot b $ IA.prEqpSlot eqpSlot ar
prompt2 = makeSentence
[ MU.WownW (partActor bUI) (MU.Text $ slotToName eqpSlot)
, "is", MU.Text valueText ]
ov0 = indentSplitAttrLine lxsize $ textToAL
$ slotToDesc eqpSlot
keys = [K.spaceKM, K.escKM]
++ [K.upKM | slotIndex /= 0]
++ [K.downKM | slotIndex /= statListBound]
promptAdd0 prompt2
slides <- overlayToSlideshow (lysize + 1) keys (ov0, [])
km <- getConfirms ColorFull keys slides
case K.key km of
K.Space -> chooseItemDialogMode MStats
K.Up -> displayOneStat $ slotIndex - 1
K.Down -> displayOneStat $ slotIndex + 1
K.Esc -> failWith "never mind"
_ -> error $ "" `showFailure` km
slotIndex0 = fromMaybe (error "displayOneStat: illegal slot")
$ elemIndex slot0 allSlots
displayOneStat slotIndex0
Left _ -> failWith "never mind"
(Left err, _) -> failWith err
chooseItemProjectHuman :: forall m. MonadClientUI m => [TriggerItem] -> m MError
chooseItemProjectHuman ts = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
ar <- getsState $ getActorAspect leader
let calmE = calmEnough b ar
cLegalRaw = [CGround, CInv, CSha, CEqp]
cLegal | calmE = cLegalRaw
| otherwise = delete CSha cLegalRaw
(verb1, object1) = case ts of
[] -> ("aim", "item")
tr : _ -> (tiverb tr, tiobject tr)
triggerSyms = triggerSymbols ts
mpsuitReq <- psuitReq
case mpsuitReq of
Left err -> failMsg err
Right psuitReqFun -> do
itemSel <- getsSession sitemSel
case itemSel of
Just (_, _, True) -> return Nothing
Just (iid, fromCStore, False) -> do
itemFull <- getsState $ itemToFull iid
bag <- getsState $ getBodyStoreBag b fromCStore
case iid `EM.lookup` bag of
Just _ | either (const False) snd (psuitReqFun itemFull) ->
return Nothing
_ -> do
modifySession $ \sess -> sess {sitemSel = Nothing}
chooseItemProjectHuman ts
Nothing -> do
let psuit =
return $ SuitsSomething $ \itemFull _kit ->
either (const False) snd (psuitReqFun itemFull)
&& (null triggerSyms
|| IK.isymbol (itemKind itemFull) `elem` triggerSyms)
prompt = makePhrase ["What", object1, "to", verb1]
promptGeneric = "What to fling"
ggi <- getGroupItem psuit prompt promptGeneric cLegalRaw cLegal
case ggi of
Right ((iid, _itemFull), (MStore fromCStore, _)) -> do
modifySession $ \sess ->
sess {sitemSel = Just (iid, fromCStore, False)}
return Nothing
Left err -> failMsg err
_ -> error $ "" `showFailure` ggi
permittedProjectClient :: MonadClientUI m
=> m (ItemFull -> Either ReqFailure Bool)
permittedProjectClient = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
ar <- getsState $ getActorAspect leader
actorSk <- leaderSkillsClientUI
let skill = EM.findWithDefault 0 AbProject actorSk
calmE = calmEnough b ar
return $ permittedProject False skill calmE
projectCheck :: MonadClientUI m => Point -> m (Maybe ReqFailure)
projectCheck tpos = do
COps{coTileSpeedup} <- 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 [] -> error $ "project from the edge of level"
`showFailure` (spos, tpos, sb)
Just (pos : _) -> do
lvl <- getLevel lid
let t = lvl `at` pos
if not $ Tile.isWalkable coTileSpeedup t
then return $ Just ProjectBlockTerrain
else do
lab <- getsState $ posToAssocs pos lid
if all (bproj . snd) lab
then return Nothing
else return $ Just ProjectBlockActor
xhairLegalEps :: MonadClientUI m => m (Either Text Int)
xhairLegalEps = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
lidV <- viewedLevelUI
let !_A = assert (lidV == blid b) ()
findNewEps onlyFirst pos = do
oldEps <- getsClient seps
mnewEps <- makeLine onlyFirst b pos oldEps
return $! case mnewEps of
Just newEps -> Right newEps
Nothing -> Left $ if onlyFirst
then "aiming blocked at the first step"
else "aiming line blocked somewhere"
xhair <- getsSession sxhair
case xhair of
TEnemy a _ -> do
body <- getsState $ getActorBody a
let pos = bpos body
if blid body == lidV
then findNewEps False pos
else error $ "" `showFailure` (xhair, body, lidV)
TPoint TEnemyPos{} _ _ ->
return $ Left "selected opponent not visible"
TPoint _ lid pos ->
if lid == lidV
then findNewEps False pos
else error $ "" `showFailure` (xhair, lidV)
TVector v -> do
Level{lxsize, lysize} <- getLevel lidV
let shifted = shiftBounded lxsize lysize (bpos b) v
if shifted == bpos b && v /= Vector 0 0
then return $ Left "selected translation is void"
else findNewEps True shifted
posFromXhair :: MonadClientUI m => m (Either Text Point)
posFromXhair = do
canAim <- xhairLegalEps
case canAim of
Right newEps -> do
modifyClient $ \cli -> cli {seps = newEps}
sxhair <- getsSession sxhair
mpos <- xhairToPos
case mpos of
Nothing -> error $ "" `showFailure` sxhair
Just pos -> do
munit <- projectCheck pos
case munit of
Nothing -> return $ Right pos
Just reqFail -> return $ Left $ showReqFailure reqFail
Left cause -> return $ Left cause
psuitReq :: MonadClientUI m
=> m (Either Text (ItemFull -> Either ReqFailure (Point, Bool)))
psuitReq = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
lidV <- viewedLevelUI
if lidV /= blid b
then return $ Left "can't project on remote levels"
else do
mpos <- posFromXhair
p <- permittedProjectClient
case mpos of
Left err -> return $ Left err
Right pos -> return $ Right $ \itemFull ->
case p itemFull of
Left err -> Left err
Right False -> Right (pos, False)
Right True ->
Right (pos, IK.totalRange (itemKind itemFull)
>= chessDist (bpos b) pos)
triggerSymbols :: [TriggerItem] -> [Char]
triggerSymbols [] = []
triggerSymbols (TriggerItem{tisymbols} : ts) = tisymbols ++ triggerSymbols ts
chooseItemApplyHuman :: forall m. MonadClientUI m => [TriggerItem] -> m MError
chooseItemApplyHuman ts = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
ar <- getsState $ getActorAspect leader
let calmE = calmEnough b ar
cLegalRaw = [CGround, CInv, CSha, CEqp]
cLegal | calmE = cLegalRaw
| otherwise = delete CSha cLegalRaw
(verb1, object1) = case ts of
[] -> ("apply", "item")
tr : _ -> (tiverb tr, tiobject tr)
triggerSyms = triggerSymbols ts
prompt = makePhrase ["What", object1, "to", verb1]
promptGeneric = "What to apply"
itemSel <- getsSession sitemSel
case itemSel of
Just (_, _, True) -> return Nothing
Just (iid, fromCStore, False) -> do
itemFull <- getsState $ itemToFull iid
bag <- getsState $ getBodyStoreBag b fromCStore
mp <- permittedApplyClient
case iid `EM.lookup` bag of
Just kit | either (const False) id (mp itemFull kit) ->
return Nothing
_ -> do
modifySession $ \sess -> sess {sitemSel = Nothing}
chooseItemApplyHuman ts
Nothing -> do
let psuit :: m Suitability
psuit = do
mp <- permittedApplyClient
return $ SuitsSomething $ \itemFull kit ->
either (const False) id (mp itemFull kit)
&& (null triggerSyms
|| IK.isymbol (itemKind itemFull) `elem` triggerSyms)
ggi <- getGroupItem psuit prompt promptGeneric cLegalRaw cLegal
case ggi of
Right ((iid, _itemFull), (MStore fromCStore, _)) -> do
modifySession $ \sess ->
sess {sitemSel = Just (iid, fromCStore, False)}
return Nothing
Left err -> failMsg err
_ -> error $ "" `showFailure` ggi
permittedApplyClient :: MonadClientUI m
=> m (ItemFull -> ItemQuant -> Either ReqFailure Bool)
permittedApplyClient = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
ar <- getsState $ getActorAspect leader
actorSk <- leaderSkillsClientUI
let skill = EM.findWithDefault 0 AbApply actorSk
calmE = calmEnough b ar
localTime <- getsState $ getLocalTime (blid b)
return $ permittedApply localTime skill calmE
pickLeaderHuman :: MonadClientUI m => Int -> m MError
pickLeaderHuman k = do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
arena <- getArenaUI
sactorUI <- getsSession sactorUI
mhero <- getsState $ tryFindHeroK sactorUI side k
allA <- getsState $ EM.assocs . sactorD
let allOurs = filter (\(_, body) ->
not (bproj body) && bfid body == side) allA
allOursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) allOurs
hs = sortBy (comparing keySelected) allOursUI
mactor = case drop k hs of
[] -> Nothing
(aid, b, _) : _ -> Just (aid, b)
mchoice = if fhasGender (gplayer fact) then mhero else mactor
(autoDun, _) = autoDungeonLevel fact
case mchoice of
Nothing -> failMsg "no such member of the party"
Just (aid, b)
| blid b /= arena && autoDun ->
failMsg $ showReqFailure NoChangeDunLeader
| otherwise -> do
void $ pickLeader True aid
return Nothing
pickLeaderWithPointerHuman :: MonadClientUI m => m MError
pickLeaderWithPointerHuman = pickLeaderWithPointer
memberCycleHuman :: MonadClientUI m => m MError
memberCycleHuman = memberCycle True
memberBackHuman :: MonadClientUI m => m MError
memberBackHuman = memberBack True
selectActorHuman :: MonadClientUI m => m ()
selectActorHuman = do
leader <- getLeaderUI
selectAid leader
selectAid :: MonadClientUI m => ActorId -> m ()
selectAid leader = do
bodyUI <- getsSession $ getActorUI leader
wasMemeber <- getsSession $ ES.member leader . sselected
let upd = if wasMemeber
then ES.delete leader
else ES.insert leader
modifySession $ \sess -> sess {sselected = upd $ sselected sess}
let subject = partActor bodyUI
promptAdd1 $ makeSentence [subject, if wasMemeber
then "deselected"
else "selected"]
selectNoneHuman :: MonadClientUI m => m ()
selectNoneHuman = do
side <- getsClient sside
lidV <- viewedLevelUI
oursIds <- getsState $ fidActorRegularIds side lidV
let ours = ES.fromDistinctAscList oursIds
oldSel <- getsSession sselected
let wasNone = ES.null $ ES.intersection ours oldSel
upd = if wasNone
then ES.union
else ES.difference
modifySession $ \sess -> sess {sselected = upd (sselected sess) ours}
let subject = "all party members on the level"
promptAdd1 $ makeSentence [subject, if wasNone
then "selected"
else "deselected"]
selectWithPointerHuman :: MonadClientUI m => m MError
selectWithPointerHuman = do
lidV <- viewedLevelUI
Level{lysize} <- getLevel lidV
side <- getsClient sside
ours <- getsState $ filter (not . bproj . snd)
. actorAssocs (== side) lidV
sactorUI <- getsSession sactorUI
let oursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) ours
viewed = sortBy (comparing keySelected) oursUI
Point{..} <- getsSession spointer
if | py == lysize + 2 && px == 0 -> selectNoneHuman >> return Nothing
| py == lysize + 2 ->
case drop (px - 1) viewed of
[] -> failMsg "not pointing at an actor"
(aid, _, _) : _ -> selectAid aid >> return Nothing
| otherwise ->
case find (\(_, b) -> bpos b == Point px (py - mapStartY)) ours of
Nothing -> failMsg "not pointing at an actor"
Just (aid, _) -> selectAid aid >> return Nothing
repeatHuman :: MonadClientUI m => Int -> m ()
repeatHuman n = do
LastRecord _ seqPrevious k <- getsSession slastRecord
let macro = concat $ replicate n $ reverse seqPrevious
modifySession $ \sess -> sess {slastPlay = macro ++ slastPlay sess}
let slastRecord = LastRecord [] [] (if k == 0 then 0 else maxK)
modifySession $ \sess -> sess {slastRecord}
maxK :: Int
maxK = 100
recordHuman :: MonadClientUI m => m ()
recordHuman = do
lastPlayOld <- getsSession slastPlay
LastRecord _seqCurrent seqPrevious k <- getsSession slastRecord
case k of
0 -> do
let slastRecord = LastRecord [] [] maxK
modifySession $ \sess -> sess {slastRecord}
when (null lastPlayOld) $
promptAdd0 $ "Macro will be recorded for up to"
<+> tshow maxK
<+> "actions. Stop recording with the same key."
_ -> do
let slastRecord = LastRecord seqPrevious [] 0
modifySession $ \sess -> sess {slastRecord}
when (null lastPlayOld) $
promptAdd0 $ "Macro recording stopped after"
<+> tshow (maxK - k - 1) <+> "actions."
historyHuman :: forall m. MonadClientUI m => m ()
historyHuman = do
history <- getsSession shistory
arena <- getArenaUI
Level{lxsize, lysize} <- getLevel arena
localTime <- getsState $ getLocalTime arena
global <- getsState stime
let rh = renderHistory history
turnsGlobal = global `timeFitUp` timeTurn
turnsLocal = localTime `timeFitUp` timeTurn
msg = makeSentence
[ "You survived for"
, MU.CarWs turnsGlobal "half-second turn"
, "(this level:"
, MU.Text (tshow turnsLocal) <> ")" ]
kxs = [ (Right sn, (slotPrefix sn, 0, lxsize))
| sn <- take (length rh) intSlots ]
promptAdd0 msg
okxs <- overlayToSlideshow (lysize + 3) [K.escKM] (rh, kxs)
let displayAllHistory = do
ekm <- displayChoiceScreen "history" ColorFull True okxs
[K.spaceKM, K.escKM]
case ekm of
Left km | km == K.escKM ->
promptAdd0 "Try to survive a few seconds more, if you can."
Left km | km == K.spaceKM ->
promptAdd0 "Steady on."
Right SlotChar{..} | slotChar == 'a' ->
displayOneReport slotPrefix
_ -> error $ "" `showFailure` ekm
histBound = lengthHistory history - 1
displayOneReport :: Int -> m ()
displayOneReport histSlot = do
let timeReport = case drop histSlot rh of
[] -> error $ "" `showFailure` histSlot
tR : _ -> tR
ov0 = indentSplitAttrLine lxsize timeReport
prompt = makeSentence
[ "the", MU.Ordinal $ histSlot + 1
, "record of all history follows" ]
keys = [K.spaceKM, K.escKM] ++ [K.upKM | histSlot /= 0]
++ [K.downKM | histSlot /= histBound]
promptAdd0 prompt
slides <- overlayToSlideshow (lysize + 1) keys (ov0, [])
km <- getConfirms ColorFull keys slides
case K.key km of
K.Space -> displayAllHistory
K.Up -> displayOneReport $ histSlot - 1
K.Down -> displayOneReport $ histSlot + 1
K.Esc -> promptAdd0 "Try to learn from your previous mistakes."
_ -> error $ "" `showFailure` km
displayAllHistory
markVisionHuman :: MonadClientUI m => m ()
markVisionHuman = modifySession toggleMarkVision
markSmellHuman :: MonadClientUI m => m ()
markSmellHuman = modifySession toggleMarkSmell
markSuspectHuman :: MonadClientUI m => m ()
markSuspectHuman = do
invalidateBfsAll
modifyClient cycleMarkSuspect
printScreenHuman :: MonadClientUI m => m ()
printScreenHuman = printScreen
cancelHuman :: MonadClientUI m => m ()
cancelHuman = do
saimMode <- getsSession saimMode
when (isJust saimMode) $ do
clearAimMode
promptAdd1 "Target not set."
acceptHuman :: MonadClientUI m => m ()
acceptHuman = do
endAiming
endAimingMsg
clearAimMode
endAiming :: MonadClientUI m => m ()
endAiming = do
leader <- getLeaderUI
sxhair <- getsSession sxhair
modifyClient $ updateTarget leader $ const $ Just sxhair
endAimingMsg :: MonadClientUI m => m ()
endAimingMsg = do
leader <- getLeaderUI
(mtargetMsg, _) <- targetDescLeader leader
let targetMsg = fromJust mtargetMsg
subject <- partAidLeader leader
promptAdd1 $
makeSentence [MU.SubjectVerbSg subject "target", MU.Text targetMsg]
tgtClearHuman :: MonadClientUI m => m ()
tgtClearHuman = do
leader <- getLeaderUI
tgt <- getsClient $ getTarget leader
case tgt of
Just _ -> modifyClient $ updateTarget leader (const Nothing)
Nothing -> do
clearXhair
doLook
itemClearHuman :: MonadClientUI m => m ()
itemClearHuman = modifySession $ \sess -> sess {sitemSel = Nothing}
doLook :: MonadClientUI m => m ()
doLook = do
saimMode <- getsSession saimMode
case saimMode of
Nothing -> return ()
Just aimMode -> do
leader <- getLeaderUI
let lidV = aimLevelId aimMode
xhairPos <- xhairToPos
per <- getPerFid lidV
b <- getsState $ getActorBody leader
let p = fromMaybe (bpos b) xhairPos
canSee = ES.member p (totalVisible per)
tileBlurb <- lookAtTile canSee p leader lidV
actorsBlurb <- lookAtActors p lidV
itemsBlurb <- lookAtItems canSee p leader
promptAdd1 $! tileBlurb <+> actorsBlurb <+> itemsBlurb
moveXhairHuman :: MonadClientUI m => Vector -> Int -> m MError
moveXhairHuman dir n = do
leader <- getLeaderUI
saimMode <- getsSession saimMode
let lidV = maybe (error $ "" `showFailure` leader) aimLevelId saimMode
Level{lxsize, lysize} <- getLevel lidV
lpos <- getsState $ bpos . getActorBody leader
sxhair <- getsSession sxhair
xhairPos <- xhairToPos
let cpos = fromMaybe lpos xhairPos
shiftB pos = shiftBounded lxsize lysize pos dir
newPos = iterate shiftB cpos !! n
if newPos == cpos then failMsg "never mind"
else do
let tgt = case sxhair of
TVector{} -> TVector $ newPos `vectorToFrom` lpos
_ -> TPoint TAny lidV newPos
modifySession $ \sess -> sess {sxhair = tgt}
doLook
return Nothing
aimTgtHuman :: MonadClientUI m => m MError
aimTgtHuman = do
lidV <- viewedLevelUI
modifySession $ \sess -> sess {saimMode = Just $ AimMode lidV}
doLook
failMsg "aiming started"
aimFloorHuman :: MonadClientUI m => m ()
aimFloorHuman = do
lidV <- viewedLevelUI
leader <- getLeaderUI
lpos <- getsState $ bpos . getActorBody leader
xhairPos <- xhairToPos
sxhair <- getsSession sxhair
saimMode <- getsSession saimMode
bsAll <- getsState $ actorAssocs (const True) lidV
let xhair = fromMaybe lpos xhairPos
tgt = case sxhair of
_ | isNothing saimMode ->
sxhair
TEnemy a True -> TEnemy a False
TEnemy{} -> TPoint TAny lidV xhair
TPoint{} -> TVector $ xhair `vectorToFrom` lpos
TVector{} ->
case find (\(_, m) -> Just (bpos m) == xhairPos) bsAll of
Just (im, _) -> TEnemy im True
Nothing -> TPoint TAny lidV xhair
modifySession $ \sess -> sess {saimMode = Just $ AimMode lidV}
modifySession $ \sess -> sess {sxhair = tgt}
doLook
aimEnemyHuman :: MonadClientUI m => m ()
aimEnemyHuman = do
lidV <- viewedLevelUI
leader <- getLeaderUI
lpos <- getsState $ bpos . getActorBody leader
xhairPos <- xhairToPos
sxhair <- getsSession sxhair
saimMode <- getsSession saimMode
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
bsAll <- getsState $ actorAssocs (const True) lidV
let ordPos (_, b) = (chessDist lpos $ bpos b, bpos b)
dbs = sortBy (comparing ordPos) bsAll
pickUnderXhair =
let i = fromMaybe (-1)
$ findIndex ((== xhairPos) . Just . bpos . snd) dbs
in splitAt i dbs
(permitAnyActor, (lt, gt)) = case sxhair of
TEnemy a permit | isJust saimMode ->
let i = fromMaybe (-1) $ findIndex ((== a) . fst) dbs
in (permit, splitAt (i + 1) dbs)
TEnemy a permit ->
let i = fromMaybe (-1) $ findIndex ((== a) . fst) dbs
in (permit, splitAt i dbs)
TPoint (TEnemyPos _ permit) _ _ -> (permit, pickUnderXhair)
_ -> (False, pickUnderXhair)
gtlt = gt ++ lt
isEnemy b = isFoe side fact (bfid b)
&& not (bproj b)
&& bhp b > 0
lf = filter (isEnemy . snd) gtlt
tgt | permitAnyActor = case gtlt of
(a, _) : _ -> TEnemy a True
[] -> sxhair
| otherwise = case lf of
(a, _) : _ -> TEnemy a False
[] -> sxhair
modifySession $ \sess -> sess {saimMode = Just $ AimMode lidV}
modifySession $ \sess -> sess {sxhair = tgt}
doLook
aimItemHuman :: MonadClientUI m => m ()
aimItemHuman = do
lidV <- viewedLevelUI
leader <- getLeaderUI
lpos <- getsState $ bpos . getActorBody leader
xhairPos <- xhairToPos
sxhair <- getsSession sxhair
saimMode <- getsSession saimMode
bsAll <- getsState $ EM.keys . lfloor . (EM.! lidV) . sdungeon
let ordPos p = (chessDist lpos p, p)
dbs = sortBy (comparing ordPos) bsAll
pickUnderXhair =
let i = fromMaybe (-1)
$ findIndex ((== xhairPos) . Just) dbs
in splitAt i dbs
(lt, gt) = case sxhair of
TPoint _ lid pos | isJust saimMode && lid == lidV ->
let i = fromMaybe (-1) $ findIndex (== pos) dbs
in splitAt (i + 1) dbs
TPoint _ lid pos | lid == lidV ->
let i = fromMaybe (-1) $ findIndex (== pos) dbs
in splitAt i dbs
_ -> pickUnderXhair
gtlt = gt ++ lt
tgt = case gtlt of
p : _ -> TPoint TAny lidV p
[] -> sxhair
modifySession $ \sess -> sess {saimMode = Just $ AimMode lidV}
modifySession $ \sess -> sess {sxhair = tgt}
doLook
aimAscendHuman :: MonadClientUI m => Int -> m MError
aimAscendHuman k = do
dungeon <- getsState sdungeon
lidV <- viewedLevelUI
let up = k > 0
case ascendInBranch dungeon up lidV of
[] -> failMsg "no more levels in this direction"
_ : _ -> do
let ascendOne lid = case ascendInBranch dungeon up lid of
[] -> lid
nlid : _ -> nlid
lidK = iterate ascendOne lidV !! abs k
leader <- getLeaderUI
lpos <- getsState $ bpos . getActorBody leader
xhairPos <- xhairToPos
let cpos = fromMaybe lpos xhairPos
tgt = TPoint TAny lidK cpos
modifySession $ \sess -> sess { saimMode = Just (AimMode lidK)
, sxhair = tgt }
doLook
return Nothing
epsIncrHuman :: MonadClientUI m => Bool -> m ()
epsIncrHuman b = do
saimMode <- getsSession saimMode
lidV <- viewedLevelUI
modifySession $ \sess -> sess {saimMode = Just $ AimMode lidV}
modifyClient $ \cli -> cli {seps = seps cli + if b then 1 else -1}
invalidateBfsAll
flashAiming
modifySession $ \sess -> sess {saimMode}
flashAiming :: MonadClientUI m => m ()
flashAiming = do
lidV <- viewedLevelUI
animate lidV pushAndDelay
xhairUnknownHuman :: MonadClientUI m => m MError
xhairUnknownHuman = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
mpos <- closestUnknown leader
case mpos of
Nothing -> failMsg "no more unknown spots left"
Just p -> do
let sxhair = TPoint TUnknown (blid b) p
modifySession $ \sess -> sess {sxhair}
doLook
return Nothing
xhairItemHuman :: MonadClientUI m => m MError
xhairItemHuman = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
items <- closestItems leader
case items of
[] -> failMsg "no more items remembered or visible"
_ -> do
let (_, (p, bag)) = maximumBy (comparing fst) items
sxhair = TPoint (TItem bag) (blid b) p
modifySession $ \sess -> sess {sxhair}
doLook
return Nothing
xhairStairHuman :: MonadClientUI m => Bool -> m MError
xhairStairHuman up = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
stairs <- closestTriggers (if up then ViaStairsUp else ViaStairsDown) leader
case stairs of
[] -> failMsg $ "no stairs" <+> if up then "up" else "down"
_ -> do
let (_, (p, (p0, bag))) = maximumBy (comparing fst) stairs
sxhair = TPoint (TEmbed bag p0) (blid b) p
modifySession $ \sess -> sess {sxhair}
doLook
return Nothing
xhairPointerFloorHuman :: MonadClientUI m => m ()
xhairPointerFloorHuman = do
saimMode <- getsSession saimMode
xhairPointerFloor False
modifySession $ \sess -> sess {saimMode}
xhairPointerFloor :: MonadClientUI m => Bool -> m ()
xhairPointerFloor verbose = do
lidV <- viewedLevelUI
Level{lxsize, lysize} <- getLevel lidV
Point{..} <- getsSession spointer
if px >= 0 && py - mapStartY >= 0
&& px < lxsize && py - mapStartY < lysize
then do
oldXhair <- getsSession sxhair
let sxhair = TPoint TAny lidV $ Point px (py - mapStartY)
sxhairMoused = sxhair /= oldXhair
modifySession $ \sess ->
sess { saimMode = Just $ AimMode lidV
, sxhair
, sxhairMoused }
if verbose then doLook else flashAiming
else stopPlayBack
xhairPointerEnemyHuman :: MonadClientUI m => m ()
xhairPointerEnemyHuman = do
saimMode <- getsSession saimMode
xhairPointerEnemy False
modifySession $ \sess -> sess {saimMode}
xhairPointerEnemy :: MonadClientUI m => Bool -> m ()
xhairPointerEnemy verbose = do
lidV <- viewedLevelUI
Level{lxsize, lysize} <- getLevel lidV
Point{..} <- getsSession spointer
if px >= 0 && py - mapStartY >= 0
&& px < lxsize && py - mapStartY < lysize
then do
bsAll <- getsState $ actorAssocs (const True) lidV
oldXhair <- getsSession sxhair
let newPos = Point px (py - mapStartY)
sxhair =
case find (\(_, m) -> bpos m == newPos) bsAll of
Just (im, _) -> TEnemy im True
Nothing -> TPoint TAny lidV newPos
sxhairMoused = sxhair /= oldXhair
modifySession $ \sess ->
sess { saimMode = Just $ AimMode lidV
, sxhairMoused }
modifySession $ \sess -> sess {sxhair}
if verbose then doLook else flashAiming
else stopPlayBack
aimPointerFloorHuman :: MonadClientUI m => m ()
aimPointerFloorHuman = xhairPointerFloor True
aimPointerEnemyHuman :: MonadClientUI m => m ()
aimPointerEnemyHuman = xhairPointerEnemy True