module Game.LambdaHack.Client.UI.HandleHumanLocalM
(
macroHuman
, chooseItemHuman, chooseItemDialogMode
, chooseItemProjectHuman, chooseItemApplyHuman
, psuitReq, triggerSymbols, pickLeaderHuman, pickLeaderWithPointerHuman
, memberCycleHuman, memberBackHuman
, selectActorHuman, selectNoneHuman, selectWithPointerHuman
, repeatHuman, recordHuman, allHistoryHuman, lastHistoryHuman
, markVisionHuman, markSmellHuman, markSuspectHuman, printScreenHuman
, cancelHuman, acceptHuman, clearTargetIfItemClearHuman, itemClearHuman
, moveXhairHuman, aimTgtHuman, aimFloorHuman, aimEnemyHuman, aimItemHuman
, aimAscendHuman, epsIncrHuman
, xhairUnknownHuman, xhairItemHuman, xhairStairHuman
, xhairPointerFloorHuman, xhairPointerEnemyHuman
, aimPointerFloorHuman, aimPointerEnemyHuman
#ifdef EXPOSE_INTERNAL
, permittedProjectClient, projectCheck, xhairLegalEps, posFromXhair
, permittedApplyClient, selectAid, eitherHistory, endAiming, endAimingMsg
, doLook, flashAiming
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.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.ClientOptions
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.Content.Screen
import Game.LambdaHack.Client.UI.ContentClientUI
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.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.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.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.Types
import Game.LambdaHack.Common.Vector
import qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.ModeKind (fhasGender)
import qualified Game.LambdaHack.Content.PlaceKind as PK
import Game.LambdaHack.Content.RuleKind
import qualified Game.LambdaHack.Definition.Ability as Ability
import Game.LambdaHack.Definition.Defs
macroHuman :: MonadClientUI m => [String] -> m ()
macroHuman kms = do
modifySession $ \sess -> sess {slastPlay = map K.mkKM kms ++ slastPlay sess}
msgAdd MsgMacro $ "Macro activated:" <+> T.pack (intercalate " " kms)
chooseItemHuman :: MonadClientUI m => ItemDialogMode -> m MError
chooseItemHuman c = either Just (const Nothing) <$> chooseItemDialogMode c
chooseItemDialogMode :: MonadClientUI m
=> ItemDialogMode -> m (FailOrCmd ItemDialogMode)
chooseItemDialogMode c = do
CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui
COps{coitem} <- getsState scops
side <- getsClient sside
let prompt :: Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State
-> Text
prompt body bodyUI actorMaxSk c2 s =
let (tIn, t) = ppItemDialogMode c2
subject = partActor bodyUI
f (k, _) acc = k + acc
countItems store = EM.foldr' f 0 $ getBodyStoreBag body store s
in case c2 of
MStore CGround ->
let n = countItems CGround
nItems = MU.CarAWs n "item"
in makePhrase
[ MU.Capitalize $ MU.SubjectVerbSg subject "notice"
, nItems, "at"
, MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text "feet" ]
MStore CSha ->
let currencyName = IK.iname $ okind coitem
$ ouniqGroup coitem "currency"
dungeonTotal = sgold s
(_, total) = calculateTotal side s
n = countItems CSha
verbSha = if | n == 0 -> "find nothing"
| calmEnough body actorMaxSk -> "notice"
| otherwise -> "paw distractedly"
in makePhrase
[ MU.Text $ spoilsBlurb currencyName total dungeonTotal
, MU.Capitalize $ MU.SubjectVerbSg subject verbSha
, MU.Text tIn
, MU.Text t ]
MStore cstore ->
let n = countItems cstore
nItems = MU.CarAWs n "item"
in makePhrase
[ MU.Capitalize $ MU.SubjectVerbSg subject "see"
, nItems, MU.Text tIn
, MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ]
MOrgans ->
makePhrase
[ MU.Capitalize $ MU.SubjectVerbSg subject "feel"
, MU.Text tIn
, MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ]
MOwned ->
makePhrase
[ MU.Capitalize $ MU.SubjectVerbSg subject "recall"
, MU.Text tIn
, MU.Text t ]
MSkills ->
makePhrase
[ MU.Capitalize $ MU.SubjectVerbSg subject "estimate"
, MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ]
MLore{} ->
makePhrase
[ MU.Capitalize $ MU.SubjectVerbSg subject "recall"
, MU.Text t ]
MPlaces ->
makePhrase
[ MU.Capitalize $ MU.SubjectVerbSg subject "recall"
, MU.Text t ]
ggi <- getStoreItem prompt c
recordHistory
leader <- getLeaderUI
actorMaxSk <- getsState $ getActorMaxSkills leader
let meleeSkill = Ability.getSk Ability.SkHurtMelee actorMaxSk
bUI <- getsSession $ getActorUI leader
case ggi of
(Right (iid, itemBag, lSlots), (c2, _)) ->
case c2 of
MStore fromCStore -> do
modifySession $ \sess ->
sess {sitemSel = Just (iid, fromCStore, False)}
return $ Right c2
MOrgans -> do
let blurb itemFull =
if IA.checkFlag Ability.Condition $ aspectRecordFull itemFull
then "condition"
else "organ"
promptFun _ itemFull _ =
makeSentence [ partActor bUI, "can't remove"
, MU.AW $ blurb itemFull ]
ix0 = fromMaybe (error $ show iid)
$ findIndex (== iid) $ EM.elems lSlots
go <- displayItemLore itemBag meleeSkill promptFun ix0 lSlots
if go then chooseItemDialogMode c2 else failWith "never mind"
MOwned -> do
found <- getsState $ findIid leader side 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.! side) . sfactionD
let (autoDun, _) = autoDungeonLevel fact
if | newAid == leader -> return $ Right c2
| blid b2 /= arena && autoDun ->
failSer NoChangeDunLeader
| otherwise -> do
void $ pickLeader True newAid
return $ Right c2
MSkills -> error $ "" `showFailure` ggi
MLore slore -> do
let ix0 = fromMaybe (error $ show iid)
$ findIndex (== iid) $ EM.elems lSlots
promptFun _ _ _ =
makeSentence [ MU.SubjectVerbSg (partActor bUI) "remember"
, MU.AW $ MU.Text (headingSLore slore) ]
go <- displayItemLore itemBag meleeSkill promptFun ix0 lSlots
if go then chooseItemDialogMode c2 else failWith "never mind"
MPlaces -> error $ "" `showFailure` ggi
(Left err, (MSkills, ekm)) -> case ekm of
Right slot0 -> assert (err == "skills") $ do
let slotListBound = length skillSlots - 1
displayOneSlot slotIndex = do
b <- getsState $ getActorBody leader
let slot = allSlots !! slotIndex
skill = skillSlots !! fromMaybe (error $ show slot)
(elemIndex slot allSlots)
valueText =
skillToDecorator skill b $ Ability.getSk skill actorMaxSk
prompt2 = makeSentence
[ MU.WownW (partActor bUI) (MU.Text $ skillName skill)
, "is", MU.Text valueText ]
ov0 = indentSplitAttrLine rwidth $ textToAL
$ skillDesc skill
keys = [K.spaceKM, K.escKM]
++ [K.upKM | slotIndex /= 0]
++ [K.downKM | slotIndex /= slotListBound]
promptAdd0 prompt2
slides <- overlayToSlideshow (rheight - 2) keys (ov0, [])
km <- getConfirms ColorFull keys slides
case K.key km of
K.Space -> chooseItemDialogMode MSkills
K.Up -> displayOneSlot $ slotIndex - 1
K.Down -> displayOneSlot $ slotIndex + 1
K.Esc -> failWith "never mind"
_ -> error $ "" `showFailure` km
slotIndex0 = fromMaybe (error "displayOneSlot: illegal slot")
$ elemIndex slot0 allSlots
displayOneSlot slotIndex0
Left _ -> failWith "never mind"
(Left err, (MPlaces, ekm)) -> case ekm of
Right slot0 -> assert (err == "places") $ do
COps{coplace} <- getsState scops
soptions <- getsClient soptions
places <- getsState $ EM.assocs . placesFromState coplace soptions
let slotListBound = length places - 1
displayOneSlot slotIndex = do
let slot = allSlots !! slotIndex
(pk, figures@(es, _, _, _)) =
places !! fromMaybe (error $ show slot)
(elemIndex slot allSlots)
pkind = okind coplace pk
partsPhrase = makePhrase $ placeParts figures
prompt2 = makeSentence
[ MU.SubjectVerbSg (partActor bUI) "remember"
, MU.Text $ PK.pname pkind ]
freqsText = "Frequencies:" <+> T.intercalate " "
(map (\(grp, n) -> "(" <> fromGroupName grp
<> ", " <> tshow n <> ")")
$ PK.pfreq pkind)
onLevels | ES.null es = []
| otherwise =
[makeSentence
[ "Appears on"
, MU.CarWs (ES.size es) "level" <> ":"
, MU.WWandW $ map MU.Car $ sort
$ map (abs . fromEnum) $ ES.elems es ]]
ov0 = indentSplitAttrLine rwidth $ textToAL $ T.unlines $
(if sexposePlaces soptions
then [ "", partsPhrase
, "", freqsText
, "" ] ++ PK.ptopLeft pkind
else [])
++ [""] ++ onLevels
keys = [K.spaceKM, K.escKM]
++ [K.upKM | slotIndex /= 0]
++ [K.downKM | slotIndex /= slotListBound]
promptAdd0 prompt2
slides <- overlayToSlideshow (rheight - 2) keys (ov0, [])
km <- getConfirms ColorFull keys slides
case K.key km of
K.Space -> chooseItemDialogMode MPlaces
K.Up -> displayOneSlot $ slotIndex - 1
K.Down -> displayOneSlot $ slotIndex + 1
K.Esc -> failWith "never mind"
_ -> error $ "" `showFailure` km
slotIndex0 = fromMaybe (error "displayOneSlot: illegal slot")
$ elemIndex slot0 allSlots
displayOneSlot slotIndex0
Left _ -> failWith "never mind"
(Left err, _) -> failWith err
chooseItemProjectHuman :: forall m. (MonadClient m, MonadClientUI m)
=> [TriggerItem] -> m MError
chooseItemProjectHuman ts = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
actorMaxSk <- getsState $ getActorMaxSkills leader
let calmE = calmEnough b actorMaxSk
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
actorMaxSk <- getsState $ getActorMaxSkills leader
actorSk <- leaderSkillsClientUI
let skill = Ability.getSk Ability.SkProject actorSk
calmE = calmEnough b actorMaxSk
return $ permittedProject False skill calmE
projectCheck :: MonadClientUI m => Point -> m (Maybe ReqFailure)
projectCheck tpos = do
COps{corule=RuleContent{rXmax, rYmax}, coTileSpeedup} <- getsState scops
leader <- getLeaderUI
eps <- getsClient seps
sb <- getsState $ getActorBody leader
let lid = blid sb
spos = bpos sb
case bla rXmax rYmax 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 if occupiedBigLvl pos lvl
then return $ Just ProjectBlockActor
else return Nothing
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
Nothing -> return $ Left "no aim designated"
Just (TEnemy a) -> do
body <- getsState $ getActorBody a
let pos = bpos body
if blid body == lidV
then findNewEps False pos
else return $ Left "can't fling at an enemy on remote level"
Just (TNonEnemy a) -> do
body <- getsState $ getActorBody a
let pos = bpos body
if blid body == lidV
then findNewEps False pos
else return $ Left "can't fling at a non-enemy on remote level"
Just (TPoint TEnemyPos{} _ _) ->
return $ Left "selected opponent not visible"
Just (TPoint _ lid pos) ->
if lid == lidV
then findNewEps True pos
else return $ Left "can't fling at a target on remote level"
Just (TVector v) -> do
COps{corule=RuleContent{rXmax, rYmax}} <- getsState scops
let shifted = shiftBounded rXmax rYmax (bpos b) v
if shifted == bpos b && v /= Vector 0 0
then return $ Left "selected translation is void"
else findNewEps True shifted
posFromXhair :: (MonadClient m, MonadClientUI m) => m (Either Text Point)
posFromXhair = do
canAim <- xhairLegalEps
case canAim of
Right newEps -> do
modifyClient $ \cli -> cli {seps = newEps}
mpos <- xhairToPos
case mpos of
Nothing -> error $ "" `showFailure` mpos
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 :: (MonadClient m, 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 fling on remote level"
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 ->
let arItem = aspectRecordFull itemFull
in Right (pos, IA.totalRange arItem (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
actorMaxSk <- getsState $ getActorMaxSkills leader
let calmE = calmEnough b actorMaxSk
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
actorMaxSk <- getsState $ getActorMaxSkills leader
actorSk <- leaderSkillsClientUI
let skill = Ability.getSk Ability.SkApply actorSk
calmE = calmEnough b actorMaxSk
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
allOurs <- getsState $ fidActorNotProjGlobalAssocs side
let allOursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) allOurs
hs = sortOn 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
promptAdd $ 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"
promptAdd $ makeSentence [subject, if wasNone
then "selected"
else "deselected"]
selectWithPointerHuman :: MonadClientUI m => m MError
selectWithPointerHuman = do
COps{corule=RuleContent{rYmax}} <- getsState scops
lidV <- viewedLevelUI
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 = sortOn keySelected oursUI
Point{..} <- getsSession spointer
if | py == rYmax + 2 && px == 0 -> selectNoneHuman >> return Nothing
| py == rYmax + 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."
allHistoryHuman :: MonadClientUI m => m ()
allHistoryHuman = eitherHistory True
eitherHistory :: forall m. MonadClientUI m => Bool -> m ()
eitherHistory showAll = do
CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui
history <- getsSession shistory
arena <- getArenaUI
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.Car turnsLocal <> ")" ]
kxs = [ (Right sn, (slotPrefix sn, 0, rwidth))
| sn <- take (length rh) intSlots ]
promptAdd0 msg
okxs <- overlayToSlideshow rheight [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 rwidth 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 (rheight - 2) 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
if showAll then displayAllHistory else displayOneReport (length rh - 1)
lastHistoryHuman :: MonadClientUI m => m ()
lastHistoryHuman = eitherHistory False
markVisionHuman :: MonadClientUI m => m ()
markVisionHuman = modifySession toggleMarkVision
markSmellHuman :: MonadClientUI m => m ()
markSmellHuman = modifySession toggleMarkSmell
markSuspectHuman :: MonadClient m => m ()
markSuspectHuman = do
invalidateBfsAll
modifyClient cycleMarkSuspect
printScreenHuman :: MonadClientUI m => m ()
printScreenHuman = do
promptAdd "Screenshot printed."
printScreen
cancelHuman :: MonadClientUI m => m ()
cancelHuman = do
saimMode <- getsSession saimMode
when (isJust saimMode) clearAimMode
acceptHuman :: (MonadClient m, MonadClientUI m) => m ()
acceptHuman = do
endAiming
endAimingMsg
clearAimMode
endAiming :: (MonadClient m, MonadClientUI m) => m ()
endAiming = do
leader <- getLeaderUI
sxhair <- getsSession sxhair
modifyClient $ updateTarget leader $ const sxhair
endAimingMsg :: MonadClientUI m => m ()
endAimingMsg = do
leader <- getLeaderUI
subject <- partActorLeader leader
tgt <- getsClient $ getTarget leader
(mtargetMsg, _) <- targetDesc tgt
promptAdd $ case mtargetMsg of
Nothing ->
makeSentence [MU.SubjectVerbSg subject "clear target"]
Just targetMsg ->
makeSentence [MU.SubjectVerbSg subject "target", MU.Text targetMsg]
clearTargetIfItemClearHuman :: (MonadClient m, MonadClientUI m) => m ()
clearTargetIfItemClearHuman = do
itemSel <- getsSession sitemSel
when (isNothing itemSel) $ do
modifySession $ \sess -> sess {sxhair = Nothing}
leader <- getLeaderUI
modifyClient $ updateTarget leader (const Nothing)
doLook
doLook :: MonadClientUI m => m ()
doLook = do
saimMode <- getsSession saimMode
case saimMode of
Nothing -> return ()
Just aimMode -> do
leader <- getLeaderUI
let lidV = aimLevelId aimMode
mxhairPos <- xhairToPos
b <- getsState $ getActorBody leader
let xhairPos = fromMaybe (bpos b) mxhairPos
blurb <- lookAtPosition lidV xhairPos
promptAdd0 blurb
itemClearHuman :: MonadClientUI m => m ()
itemClearHuman = modifySession $ \sess -> sess {sitemSel = Nothing}
moveXhairHuman :: MonadClientUI m => Vector -> Int -> m MError
moveXhairHuman dir n = do
COps{corule=RuleContent{rXmax, rYmax}} <- getsState scops
leader <- getLeaderUI
saimMode <- getsSession saimMode
let lidV = maybe (error $ "" `showFailure` leader) aimLevelId saimMode
lpos <- getsState $ bpos . getActorBody leader
xhair <- getsSession sxhair
mxhairPos <- xhairToPos
let xhairPos = fromMaybe lpos mxhairPos
shiftB pos = shiftBounded rXmax rYmax pos dir
newPos = iterate shiftB xhairPos !! n
if newPos == xhairPos then failMsg "never mind"
else do
let sxhair = case xhair of
Just TVector{} -> Just $ TVector $ newPos `vectorToFrom` lpos
_ -> Just $ TPoint TKnown lidV newPos
modifySession $ \sess -> sess {sxhair}
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
mxhairPos <- xhairToPos
xhair <- getsSession sxhair
saimMode <- getsSession saimMode
bsAll <- getsState $ actorAssocs (const True) lidV
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
let xhairPos = fromMaybe lpos mxhairPos
sxhair = case xhair of
_ | isNothing saimMode ->
xhair
Just TEnemy{} -> Just $ TPoint TKnown lidV xhairPos
Just TNonEnemy{} -> Just $ TPoint TKnown lidV xhairPos
Just TPoint{} | xhairPos /= lpos ->
Just $ TVector $ xhairPos `vectorToFrom` lpos
Just TVector{} ->
case find (\(_, b) -> Just (bpos b) == mxhairPos) bsAll of
Just (aid, b) -> Just $ if isFoe side fact (bfid b)
then TEnemy aid
else TNonEnemy aid
Nothing -> Just $ TPoint TUnknown lidV xhairPos
_ -> xhair
modifySession $ \sess -> sess { saimMode = Just $ AimMode lidV
, sxhair }
doLook
aimEnemyHuman :: MonadClientUI m => m ()
aimEnemyHuman = do
lidV <- viewedLevelUI
leader <- getLeaderUI
lpos <- getsState $ bpos . getActorBody leader
mxhairPos <- xhairToPos
xhair <- 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, bproj b)
dbs = sortOn ordPos bsAll
pickUnderXhair =
fromMaybe (-1) $ findIndex ((== mxhairPos) . Just . bpos . snd) dbs
(pickEnemies, i) = case xhair of
Just (TEnemy a) | isJust saimMode ->
(True, 1 + fromMaybe (-1) (findIndex ((== a) . fst) dbs))
Just (TEnemy a) ->
(True, fromMaybe (-1) $ findIndex ((== a) . fst) dbs)
Just (TNonEnemy a) | isJust saimMode ->
(False, 1 + fromMaybe (-1) (findIndex ((== a) . fst) dbs))
Just (TNonEnemy a) ->
(False, fromMaybe (-1) $ findIndex ((== a) . fst) dbs)
_ -> (True, pickUnderXhair)
(lt, gt) = splitAt i dbs
isEnemy b = isFoe side fact (bfid b)
&& not (bproj b)
&& bhp b > 0
cond = if pickEnemies then isEnemy else not . isEnemy
lf = filter (cond . snd) $ gt ++ lt
sxhair = case lf of
(a, _) : _ -> Just $ if pickEnemies then TEnemy a else TNonEnemy a
[] -> xhair
modifySession $ \sess -> sess { saimMode = Just $ AimMode lidV
, sxhair }
doLook
aimItemHuman :: MonadClientUI m => m ()
aimItemHuman = do
lidV <- viewedLevelUI
leader <- getLeaderUI
lpos <- getsState $ bpos . getActorBody leader
mxhairPos <- xhairToPos
xhair <- getsSession sxhair
saimMode <- getsSession saimMode
bsAll <- getsState $ EM.keys . lfloor . (EM.! lidV) . sdungeon
let ordPos p = (chessDist lpos p, p)
dbs = sortOn ordPos bsAll
pickUnderXhair =
let i = fromMaybe (-1)
$ findIndex ((== mxhairPos) . Just) dbs
in splitAt i dbs
(lt, gt) = case xhair of
Just (TPoint _ lid pos)
| isJust saimMode && lid == lidV ->
let i = fromMaybe (-1) $ findIndex (== pos) dbs
in splitAt (i + 1) dbs
Just (TPoint _ lid pos)
| lid == lidV ->
let i = fromMaybe (-1) $ findIndex (== pos) dbs
in splitAt i dbs
_ -> pickUnderXhair
gtlt = gt ++ lt
sxhair = case gtlt of
p : _ -> Just $ TPoint TKnown lidV p
[] -> xhair
modifySession $ \sess -> sess { saimMode = Just $ AimMode lidV
, sxhair }
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
mxhairPos <- xhairToPos
let xhairPos = fromMaybe lpos mxhairPos
sxhair = Just $ TPoint TKnown lidK xhairPos
modifySession $ \sess -> sess { saimMode = Just (AimMode lidK)
, sxhair }
doLook
return Nothing
epsIncrHuman :: (MonadClient m, 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}
invalidateBfsPathAll
flashAiming
modifySession $ \sess -> sess {saimMode}
flashAiming :: MonadClientUI m => m ()
flashAiming = do
lidV <- viewedLevelUI
animate lidV pushAndDelay
xhairUnknownHuman :: (MonadClient m, 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 = Just $ TPoint TUnknown (blid b) p
modifySession $ \sess -> sess {sxhair}
doLook
return Nothing
xhairItemHuman :: (MonadClient m, MonadClientUI m) => m MError
xhairItemHuman = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
items <- closestItems leader
case items of
[] -> failMsg "no more reachable items remembered or visible"
_ -> do
let (_, (p, bag)) = maximumBy (comparing fst) items
sxhair = Just $ TPoint (TItem bag) (blid b) p
modifySession $ \sess -> sess {sxhair}
doLook
return Nothing
xhairStairHuman :: (MonadClient m, 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 reachable stairs" <+> if up then "up" else "down"
_ -> do
let (_, (p, (p0, bag))) = maximumBy (comparing fst) stairs
sxhair = Just $ TPoint (TEmbed bag p0) (blid b) p
modifySession $ \sess -> sess {sxhair}
doLook
return Nothing
xhairPointerFloorHuman :: MonadClientUI m => m ()
xhairPointerFloorHuman = do
saimMode <- getsSession saimMode
aimPointerFloorHuman
modifySession $ \sess -> sess {saimMode}
xhairPointerEnemyHuman :: MonadClientUI m => m ()
xhairPointerEnemyHuman = do
saimMode <- getsSession saimMode
aimPointerEnemyHuman
modifySession $ \sess -> sess {saimMode}
aimPointerFloorHuman :: MonadClientUI m => m ()
aimPointerFloorHuman = do
COps{corule=RuleContent{rXmax, rYmax}} <- getsState scops
lidV <- viewedLevelUI
Point{..} <- getsSession spointer
if px >= 0 && py - mapStartY >= 0
&& px < rXmax && py - mapStartY < rYmax
then do
oldXhair <- getsSession sxhair
let sxhair = Just $ TPoint TUnknown lidV $ Point px (py - mapStartY)
sxhairMoused = sxhair /= oldXhair
modifySession $ \sess ->
sess { saimMode = Just $ AimMode lidV
, sxhair
, sxhairMoused }
doLook
else stopPlayBack
aimPointerEnemyHuman :: MonadClientUI m => m ()
aimPointerEnemyHuman = do
COps{corule=RuleContent{rXmax, rYmax}} <- getsState scops
lidV <- viewedLevelUI
Point{..} <- getsSession spointer
if px >= 0 && py - mapStartY >= 0
&& px < rXmax && py - mapStartY < rYmax
then do
bsAll <- getsState $ actorAssocs (const True) lidV
oldXhair <- getsSession sxhair
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
let newPos = Point px (py - mapStartY)
sxhair =
case find (\(_, b) -> bpos b == newPos) bsAll of
Just (aid, b) -> Just $ if isFoe side fact (bfid b)
then TEnemy aid
else TNonEnemy aid
Nothing -> Just $ TPoint TUnknown lidV newPos
sxhairMoused = sxhair /= oldXhair
modifySession $ \sess ->
sess { saimMode = Just $ AimMode lidV
, sxhairMoused
, sxhair }
doLook
else stopPlayBack