module Game.LambdaHack.Client.UI.HandleHelperM
( FailError, showFailError, MError, mergeMError, FailOrCmd, failWith
, failSer, failMsg, weaveJust, sortSlots
, memberCycle, memberBack, partyAfterLeader, pickLeader, pickLeaderWithPointer
, itemOverlay, skillsOverlay, placesFromState, placeParts, placesOverlay
, pickNumber, lookAtItems, lookAtPosition
, displayItemLore, viewLoreItems, cycleLore, spoilsBlurb
#ifdef EXPOSE_INTERNAL
, lookAtTile, lookAtActors
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import qualified Data.Char as Char
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import qualified Data.Text as T
import qualified NLP.Miniutter.English as MU
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.Content.Screen
import Game.LambdaHack.Client.UI.ContentClientUI
import Game.LambdaHack.Client.UI.EffectDescription
import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd
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.Slideshow
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.Perception
import Game.LambdaHack.Common.ReqFailure
import Game.LambdaHack.Common.State
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Common.Types
import qualified Game.LambdaHack.Content.ItemKind as IK
import qualified Game.LambdaHack.Content.PlaceKind as PK
import qualified Game.LambdaHack.Content.TileKind as TK
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Definition.Ability as Ability
import qualified Game.LambdaHack.Definition.Color as Color
import Game.LambdaHack.Definition.Defs
newtype FailError = FailError {failError :: Text}
deriving Show
showFailError :: FailError -> Text
showFailError (FailError err) = "*" <> err <> "*"
type MError = Maybe FailError
mergeMError :: MError -> MError -> MError
mergeMError Nothing Nothing = Nothing
mergeMError merr1@Just{} Nothing = merr1
mergeMError Nothing merr2@Just{} = merr2
mergeMError (Just err1) (Just err2) =
Just $ FailError $ failError err1 <+> "and" <+> failError err2
type FailOrCmd a = Either FailError a
failWith :: MonadClientUI m => Text -> m (FailOrCmd a)
failWith err = assert (not $ T.null err) $ return $ Left $ FailError err
failSer :: MonadClientUI m => ReqFailure -> m (FailOrCmd a)
failSer = failWith . showReqFailure
failMsg :: MonadClientUI m => Text -> m MError
failMsg err = assert (not $ T.null err) $ return $ Just $ FailError err
weaveJust :: FailOrCmd a -> Either MError a
weaveJust (Left ferr) = Left $ Just ferr
weaveJust (Right a) = Right a
sortSlots :: MonadClientUI m => m ()
sortSlots = do
itemToF <- getsState $ flip itemToFull
ItemSlots itemSlots <- getsSession sslots
let newSlots = ItemSlots $ EM.map (sortSlotMap itemToF) itemSlots
modifySession $ \sess -> sess {sslots = newSlots}
memberCycle :: MonadClientUI m => Bool -> m MError
memberCycle verbose = do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
lidV <- viewedLevelUI
leader <- getLeaderUI
body <- getsState $ getActorBody leader
hs <- partyAfterLeader leader
let (autoDun, _) = autoDungeonLevel fact
case filter (\(_, b, _) -> blid b == lidV) hs of
_ | autoDun && lidV /= blid body ->
failMsg $ showReqFailure NoChangeDunLeader
[] -> failMsg "cannot pick any other member on this level"
(np, b, _) : _ -> do
success <- pickLeader verbose np
let !_A = assert (success `blame` "same leader"
`swith` (leader, np, b)) ()
return Nothing
memberBack :: MonadClientUI m => Bool -> m MError
memberBack verbose = do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
leader <- getLeaderUI
hs <- partyAfterLeader leader
let (autoDun, _) = autoDungeonLevel fact
case reverse hs of
_ | autoDun -> failMsg $ showReqFailure NoChangeDunLeader
[] -> failMsg "no other member in the party"
(np, b, _) : _ -> do
success <- pickLeader verbose np
let !_A = assert (success `blame` "same leader"
`swith` (leader, np, b)) ()
return Nothing
partyAfterLeader :: MonadClientUI m => ActorId -> m [(ActorId, Actor, ActorUI)]
partyAfterLeader leader = do
side <- getsState $ bfid . getActorBody leader
sactorUI <- getsSession sactorUI
allOurs <- getsState $ fidActorNotProjGlobalAssocs side
let allOursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) allOurs
hs = sortOn keySelected allOursUI
i = fromMaybe (-1) $ findIndex (\(aid, _, _) -> aid == leader) hs
(lt, gt) = (take i hs, drop (i + 1) hs)
return $! gt ++ lt
pickLeader :: MonadClientUI m => Bool -> ActorId -> m Bool
pickLeader verbose aid = do
leader <- getLeaderUI
saimMode <- getsSession saimMode
if leader == aid
then return False
else do
body <- getsState $ getActorBody aid
bodyUI <- getsSession $ getActorUI aid
let !_A = assert (not (bproj body)
`blame` "projectile chosen as the leader"
`swith` (aid, body)) ()
let subject = partActor bodyUI
when verbose $
msgAdd MsgDone $ makeSentence [subject, "picked as a leader"]
updateClientLeader aid
case saimMode of
Nothing -> return ()
Just _ ->
modifySession $ \sess -> sess {saimMode = Just $ AimMode $ blid body}
itemsBlurb <- lookAtItems True (bpos body) aid
when verbose $ msgAdd MsgAtFeet itemsBlurb
return True
pickLeaderWithPointer :: MonadClientUI m => m MError
pickLeaderWithPointer = do
CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui
lidV <- viewedLevelUI
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
arena <- getArenaUI
sactorUI <- getsSession sactorUI
ours <- getsState $ filter (not . bproj . snd)
. actorAssocs (== side) lidV
let oursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) ours
viewed = sortOn keySelected oursUI
(autoDun, _) = autoDungeonLevel fact
pick (aid, b) =
if | blid b /= arena && autoDun ->
failMsg $ showReqFailure NoChangeDunLeader
| otherwise -> do
void $ pickLeader True aid
return Nothing
Point{..} <- getsSession spointer
if | py == rheight - 1 && px == 0 -> memberBack True
| py == rheight - 1 ->
case drop (px - 1) viewed of
[] -> return Nothing
(aid, b, _) : _ -> pick (aid, b)
| otherwise ->
case find (\(_, b, _) -> bpos b == Point px (py - mapStartY)) oursUI of
Nothing -> failMsg "not pointing at an actor"
Just (aid, b, _) -> pick (aid, b)
itemOverlay :: MonadClientUI m => SingleItemSlots -> LevelId -> ItemBag -> m OKX
itemOverlay lSlots lid bag = do
localTime <- getsState $ getLocalTime lid
itemToF <- getsState $ flip itemToFull
side <- getsClient sside
factionD <- getsState sfactionD
combGround <- getsState $ combinedGround side
combOrgan <- getsState $ combinedOrgan side
combEqp <- getsState $ combinedEqp side
combInv <- getsState $ combinedInv side
shaBag <- getsState $ \s -> gsha $ sfactionD s EM.! side
discoBenefit <- getsClient sdiscoBenefit
let !_A = assert (all (`elem` EM.elems lSlots) (EM.keys bag)
`blame` (lid, bag, lSlots)) ()
markEqp iid t =
if | (iid `EM.member` combOrgan
|| iid `EM.member` combEqp)
&& iid `EM.notMember` combInv
&& iid `EM.notMember` shaBag
&& iid `EM.notMember` combGround -> T.snoc (T.init t) ']'
| iid `EM.member` shaBag -> T.snoc (T.init t) '}'
| otherwise -> t
pr (l, iid) =
case EM.lookup iid bag of
Nothing -> Nothing
Just kit@(k, _) ->
let itemFull = itemToF iid
colorSymbol =
if isJust $ lookup "condition" $ IK.ifreq $ itemKind itemFull
then let color = if benInEqp (discoBenefit EM.! iid)
then Color.BrGreen
else Color.BrRed
in Color.attrChar2ToW32 color
(IK.isymbol $ itemKind itemFull)
else viewItem itemFull
phrase = makePhrase
[partItemWsRanged side factionD k localTime itemFull kit]
al = textToAL (markEqp iid $ slotLabel l)
<+:> [colorSymbol]
<+:> textToAL phrase
kx = (Right l, (undefined, 0, length al))
in Just ([al], kx)
(ts, kxs) = unzip $ mapMaybe pr $ EM.assocs lSlots
renumber y (km, (_, x1, x2)) = (km, (y, x1, x2))
return (concat ts, zipWith renumber [0..] kxs)
skillsOverlay :: MonadClientRead m => ActorId -> m OKX
skillsOverlay aid = do
b <- getsState $ getActorBody aid
actorMaxSk <- getsState $ getActorMaxSkills aid
let prSlot :: (Y, SlotChar) -> Ability.Skill -> (Text, KYX)
prSlot (y, c) skill =
let skName = skillName skill
fullText t =
makePhrase [ MU.Text $ slotLabel c
, MU.Text $ T.justifyLeft 22 ' ' skName
, MU.Text t ]
valueText = skillToDecorator skill b
$ Ability.getSk skill actorMaxSk
ft = fullText valueText
in (ft, (Right c, (y, 0, T.length ft)))
(ts, kxs) = unzip $ zipWith prSlot (zip [0..] allSlots) skillSlots
return (map textToAL ts, kxs)
placesFromState :: ContentData PK.PlaceKind -> ClientOptions -> State
-> EM.EnumMap (ContentId PK.PlaceKind)
(ES.EnumSet LevelId, Int, Int, Int)
placesFromState coplace ClientOptions{sexposePlaces} =
let addEntries (es1, ne1, na1, nd1) (es2, ne2, na2, nd2) =
(ES.union es1 es2, ne1 + ne2, na1 + na2, nd1 + nd2)
insertZeros !em !pk _ = EM.insert pk (ES.empty, 0, 0, 0) em
initialPlaces | not sexposePlaces = EM.empty
| otherwise = ofoldlWithKey' coplace insertZeros EM.empty
placesFromLevel :: (LevelId, Level)
-> EM.EnumMap (ContentId PK.PlaceKind)
(ES.EnumSet LevelId, Int, Int, Int)
placesFromLevel (lid, Level{lentry}) =
let f (PK.PEntry pk) em =
EM.insertWith addEntries pk (ES.singleton lid, 1, 0, 0) em
f (PK.PAround pk) em =
EM.insertWith addEntries pk (ES.singleton lid, 0, 1, 0) em
f (PK.PEnd pk) em =
EM.insertWith addEntries pk (ES.singleton lid, 0, 0, 1) em
in EM.foldr' f initialPlaces lentry
in EM.unionsWith addEntries . map placesFromLevel . EM.assocs . sdungeon
placeParts :: (ES.EnumSet LevelId, Int, Int, Int) -> [MU.Part]
placeParts (_, ne, na, nd) =
["(" <> MU.CarWs ne "entrance" <> ")" | ne > 0]
++ ["(" <> MU.CarWs na "surrounding" <> ")" | na > 0]
++ ["(" <> MU.CarWs nd "end" <> ")" | nd > 0]
placesOverlay :: MonadClientRead m => m OKX
placesOverlay = do
COps{coplace} <- getsState scops
soptions <- getsClient soptions
places <- getsState $ placesFromState coplace soptions
let prSlot :: (Y, SlotChar)
-> (ContentId PK.PlaceKind, (ES.EnumSet LevelId, Int, Int, Int))
-> (Text, KYX)
prSlot (y, c) (pk, (es, ne, na, nd)) =
let placeName = PK.pname $ okind coplace pk
parts = placeParts (es, ne, na, nd)
markPlace t = if ne + na + nd == 0
then T.snoc (T.init t) '>'
else t
ft = makePhrase $ MU.Text (markPlace $ slotLabel c)
: MU.Text placeName
: parts
in (ft, (Right c, (y, 0, T.length ft)))
(ts, kxs) = unzip $ zipWith prSlot (zip [0..] allSlots) $ EM.assocs places
return (map textToAL ts, kxs)
pickNumber :: MonadClientUI m => Bool -> Int -> m (Either MError Int)
pickNumber askNumber kAll = assert (kAll >= 1) $ do
let shownKeys = [ K.returnKM, K.spaceKM, K.mkChar '+', K.mkChar '-'
, K.backspaceKM, K.escKM ]
frontKeyKeys = shownKeys ++ map K.mkChar ['0'..'9']
gatherNumber kCur = assert (1 <= kCur && kCur <= kAll) $ do
let kprompt = "Choose number:" <+> tshow kCur
promptAdd0 kprompt
sli <- reportToSlideshow shownKeys
ekkm <- displayChoiceScreen "" ColorFull False
sli frontKeyKeys
case ekkm of
Left kkm ->
case K.key kkm of
K.Char '+' ->
gatherNumber $ if kCur + 1 > kAll then 1 else kCur + 1
K.Char '-' ->
gatherNumber $ if kCur - 1 < 1 then kAll else kCur - 1
K.Char l | kCur * 10 + Char.digitToInt l > kAll ->
gatherNumber $ if Char.digitToInt l == 0
then kAll
else min kAll (Char.digitToInt l)
K.Char l -> gatherNumber $ kCur * 10 + Char.digitToInt l
K.BackSpace -> gatherNumber $ max 1 (kCur `div` 10)
K.Return -> return $ Right kCur
K.Esc -> weaveJust <$> failWith "never mind"
K.Space -> return $ Left Nothing
_ -> error $ "unexpected key" `showFailure` kkm
Right sc -> error $ "unexpected slot char" `showFailure` sc
if | kAll == 1 || not askNumber -> return $ Right kAll
| otherwise -> do
res <- gatherNumber kAll
case res of
Right k | k <= 0 -> error $ "" `showFailure` (res, kAll)
_ -> return res
lookAtTile :: MonadClientUI m
=> Bool
-> Point
-> ActorId
-> LevelId
-> m Text
lookAtTile canSee p aid lidV = do
cops@COps{cotile, coplace} <- getsState scops
side <- getsClient sside
factionD <- getsState sfactionD
b <- getsState $ getActorBody aid
lvl <- getLevel lidV
embeds <- getsState $ getEmbedBag lidV p
itemToF <- getsState $ flip itemToFull
seps <- getsClient seps
mnewEps <- makeLine False b p seps
localTime <- getsState $ getLocalTime lidV
getKind <- getsState $ flip getIidKind
let aims = isJust mnewEps
tkid = lvl `at` p
tile = okind cotile tkid
vis | TK.tname tile == "unknown space" = "that is"
| not canSee = "you remember"
| not aims = "you are aware of"
| otherwise = "you see"
tilePart = MU.AW $ MU.Text $ TK.tname tile
entrySentence pk blurb =
makeSentence [blurb, MU.Text $ PK.pname $ okind coplace pk]
elooks = case EM.lookup p $ lentry lvl of
Nothing -> ""
Just (PK.PEntry pk) -> entrySentence pk "it is an entrance to"
Just (PK.PAround pk) -> entrySentence pk "it surrounds"
Just (PK.PEnd pk) -> entrySentence pk "it ends"
itemLook (iid, kit@(k, _)) =
let itemFull = itemToF iid
arItem = aspectRecordFull itemFull
nWs = partItemWs side factionD k localTime itemFull kit
verb = if k == 1 || IA.checkFlag Ability.Condition arItem
then "is"
else "are"
ik = itemKind itemFull
desc = IK.idesc ik
in makeSentence ["There", verb, nWs] <+> desc
ilooks = T.intercalate " " $ map itemLook
$ sortEmbeds cops getKind tkid embeds
return $! makeSentence [vis, tilePart] <+> elooks <+> ilooks
lookAtActors :: MonadClientUI m
=> Point
-> LevelId
-> m Text
lookAtActors p lidV = do
side <- getsClient sside
inhabitants <- getsState $ \s -> posToAidAssocs p lidV s
sactorUI <- getsSession sactorUI
let inhabitantsUI =
map (\(aid2, b2) -> (aid2, b2, sactorUI EM.! aid2)) inhabitants
factionD <- getsState sfactionD
localTime <- getsState $ getLocalTime lidV
s <- getState
let actorsBlurb = case inhabitants of
[] -> ""
(_, body) : rest ->
let itemFull = itemToFull (btrunk body) s
bfact = factionD EM.! bfid body
subjects = map (\(_, _, bUI) -> partActor bUI)
inhabitantsUI
(subject, person) = squashedWWandW subjects
resideVerb = case bwatch body of
WWatch -> "be here"
WWait 0 -> "idle here"
WWait _ -> "brace for impact"
WSleep -> "sleep here"
WWake -> "be waking up"
guardVerbs = guardItemVerbs body bfact s
verbs = resideVerb : guardVerbs
projDesc | not $ bproj body = ""
| otherwise =
let kit = beqp body EM.! btrunk body
ps = [partItemMediumAW side factionD localTime itemFull kit]
tailWords = tail . T.words . makePhrase
in if tailWords ps == tailWords subjects
then ""
else makeSentence $ "this is" : ps
factDesc = case jfid $ itemBase itemFull of
Just tfid | tfid /= bfid body ->
let dominatedBy = if bfid body == side
then "us"
else gname bfact
tfact = factionD EM.! tfid
in "Originally of" <+> gname tfact
<> ", now fighting for" <+> dominatedBy <> "."
_ | bfid body == side -> ""
_ | bproj body -> "Launched by" <+> gname bfact <> "."
_ -> "One of" <+> gname bfact <> "."
idesc = IK.idesc $ itemKind itemFull
sameTrunks = all (\(_, b) -> btrunk b == btrunk body) rest
desc = if sameTrunks then projDesc <+> factDesc <+> idesc else ""
pdesc = if desc == "" then "" else "(" <> desc <> ")"
onlyIs = bwatch body == WWatch && null guardVerbs
in if | bhp body <= 0 && not (bproj body) ->
makeSentence
(MU.SubjectVerbSg (head subjects) "lie here"
: if null guardVerbs
then []
else [ MU.SubjectVVxV "and" MU.Sg3rd MU.No
"and" guardVerbs
, "any more" ])
<+> case subjects of
_ : projs@(_ : _) ->
let (subjectProjs, personProjs) = squashedWWandW projs
in makeSentence
[MU.SubjectVerb personProjs MU.Yes
subjectProjs "can be seen"]
_ -> ""
| null rest || onlyIs ->
makeSentence
[MU.SubjectVVxV "and" person MU.Yes subject verbs]
<+> pdesc
| otherwise ->
makeSentence [subject, "can be seen"]
<+> if onlyIs
then ""
else makeSentence [MU.SubjectVVxV "and" MU.Sg3rd MU.Yes
(head subjects) verbs]
return $! actorsBlurb
guardItemVerbs :: Actor -> Faction -> State -> [MU.Part]
guardItemVerbs body _fact s =
let toReport iid =
let itemKind = getIidKind iid s
in fromMaybe 0 (lookup "unreported inventory" (IK.ifreq itemKind)) <= 0
itemsSize = length $ filter toReport
$ EM.keys (beqp body) ++ EM.keys (binv body)
belongingsVerbs | itemsSize == 1 = ["fondle a trinket"]
| itemsSize > 1 = ["guard a hoard"]
| otherwise = []
in if bproj body
then []
else belongingsVerbs
lookAtItems :: MonadClientUI m
=> Bool
-> Point
-> ActorId
-> m Text
lookAtItems canSee p aid = do
itemToF <- getsState $ flip itemToFull
b <- getsState $ getActorBody aid
saimMode <- getsSession saimMode
let lidV = maybe (blid b) aimLevelId saimMode
localTime <- getsState $ getLocalTime lidV
subject <- partActorLeader aid
is <- getsState $ getFloorBag lidV p
side <- getsClient sside
factionD <- getsState sfactionD
let standingOn = p == bpos b && lidV == blid b
verb = MU.Text $ if | standingOn -> "stand on"
| canSee -> "notice"
| otherwise -> "remember"
nWs (iid, kit@(k, _)) =
partItemWs side factionD k localTime (itemToF iid) kit
object = case EM.assocs is of
ii : _ : _ : _ | standingOn && bfid b == side ->
MU.Phrase [nWs ii, "and other items"]
iis -> MU.WWandW $ map nWs iis
return $! if EM.null is
then ""
else makeSentence [MU.SubjectVerbSg subject verb, object]
lookAtPosition :: MonadClientUI m => LevelId -> Point -> m Text
lookAtPosition lidV p = do
leader <- getLeaderUI
per <- getPerFid lidV
let canSee = ES.member p (totalVisible per)
tileBlurb <- lookAtTile canSee p leader lidV
actorsBlurb <- lookAtActors p lidV
itemsBlurb <- lookAtItems canSee p leader
Level{lsmell, ltime} <- getLevel lidV
let smellBlurb = case EM.lookup p lsmell of
Just sml | sml > ltime ->
let Delta t = smellTimeout `timeDeltaSubtract`
(sml `timeDeltaToFrom` ltime)
seconds = t `timeFitUp` timeSecond
in "A smelly body passed here around" <+> tshow seconds <> "s ago."
_ -> ""
return $! tileBlurb <+> actorsBlurb <+> itemsBlurb <+> smellBlurb
displayItemLore :: MonadClientUI m
=> ItemBag -> Int -> (ItemId -> ItemFull -> Int -> Text) -> Int
-> SingleItemSlots
-> m Bool
displayItemLore itemBag meleeSkill promptFun slotIndex lSlots = do
CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui
side <- getsClient sside
arena <- getArenaUI
let lSlotsElems = EM.elems lSlots
lSlotsBound = length lSlotsElems - 1
iid2 = lSlotsElems !! slotIndex
kit2@(k, _) = itemBag EM.! iid2
itemFull2 <- getsState $ itemToFull iid2
localTime <- getsState $ getLocalTime arena
factionD <- getsState sfactionD
jlid <- getsSession $ fromMaybe (toEnum 0) <$> EM.lookup iid2 . sitemUI
let attrLine = itemDesc True side factionD meleeSkill
CGround localTime jlid itemFull2 kit2
ov = splitAttrLine rwidth attrLine
keys = [K.spaceKM, K.escKM]
++ [K.upKM | slotIndex /= 0]
++ [K.downKM | slotIndex /= lSlotsBound]
promptAdd0 $ promptFun iid2 itemFull2 k
slides <- overlayToSlideshow (rheight - 2) keys (ov, [])
km <- getConfirms ColorFull keys slides
case K.key km of
K.Space -> return True
K.Up ->
displayItemLore itemBag meleeSkill promptFun (slotIndex - 1) lSlots
K.Down ->
displayItemLore itemBag meleeSkill promptFun (slotIndex + 1) lSlots
K.Esc -> return False
_ -> error $ "" `showFailure` km
viewLoreItems :: MonadClientUI m
=> Bool -> String -> SingleItemSlots -> ItemBag -> Text
-> (Int -> SingleItemSlots -> m Bool)
-> m K.KM
viewLoreItems enableSorting menuName lSlotsRaw trunkBag prompt examItem = do
CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui
arena <- getArenaUI
revCmd <- revCmdMap
itemToF <- getsState $ flip itemToFull
let caretKey = revCmd (K.KM K.NoModifier $ K.Char '^')
HumanCmd.SortSlots
keysPre = [K.spaceKM, K.mkChar '/', K.mkChar '?', K.escKM]
++ [caretKey | enableSorting]
lSlots = if enableSorting
then lSlotsRaw
else sortSlotMap itemToF lSlotsRaw
promptAdd0 prompt
io <- itemOverlay lSlots arena trunkBag
itemSlides <- overlayToSlideshow (rheight - 2) keysPre io
let keyOfEKM (Left km) = km
keyOfEKM (Right SlotChar{slotChar}) = [K.mkChar slotChar]
allOKX = concatMap snd $ slideshow itemSlides
keysMain = keysPre ++ concatMap (keyOfEKM . fst) allOKX
viewAtSlot slot = do
let ix0 = fromMaybe (error $ show slot)
(findIndex (== slot) $ EM.keys lSlots)
go2 <- examItem ix0 lSlots
if go2
then viewLoreItems enableSorting menuName lSlots
trunkBag prompt examItem
else return K.escKM
ekm <- displayChoiceScreen menuName ColorFull False itemSlides keysMain
case ekm of
Left km | km == K.spaceKM -> return km
Left km | km == K.mkChar '/' -> return km
Left km | km == K.mkChar '?' -> return km
Left km | km == caretKey ->
viewLoreItems False menuName (sortSlotMap itemToF lSlotsRaw)
trunkBag prompt examItem
Left km | km == K.escKM -> return km
Left K.KM{key=K.Char l} -> viewAtSlot $ SlotChar 0 l
Left km -> error $ "" `showFailure` km
Right slot -> viewAtSlot slot
cycleLore :: MonadClientUI m => [m K.KM] -> [m K.KM] -> m ()
cycleLore _ [] = return ()
cycleLore seen (m : rest) = do
km <- m
if | km == K.spaceKM -> cycleLore (m : seen) rest
| km == K.mkChar '/' -> if null rest
then cycleLore [] (reverse $ m : seen)
else cycleLore (m : seen) rest
| km == K.mkChar '?' -> case seen of
prev : ps -> cycleLore ps (prev : m : rest)
[] -> case reverse (m : rest) of
prev : ps -> cycleLore ps [prev]
[] -> error "cycleLore: screens disappeared"
| km == K.escKM -> return ()
| otherwise -> error "cycleLore: unexpected key"
spoilsBlurb :: Text -> Int -> Int -> Text
spoilsBlurb currencyName total dungeonTotal =
if | dungeonTotal == 0 -> "All your spoils are of the practical kind."
| total == 0 -> "You haven't found any genuine treasure."
| otherwise -> makeSentence
[ "your spoils are worth"
, MU.CarAWs total $ MU.Text currencyName
, "out of the rumoured total"
, MU.Cardinal dungeonTotal ]