-- | Helper functions for both inventory management and human commands. module Game.LambdaHack.Client.UI.HandleHelperM ( FailError, showFailError, MError, mergeMError, FailOrCmd, failWith , failSer, failMsg, weaveJust , pointmanCycle, pointmanCycleLevel, partyAfterLeader , pickLeader, doLook, pickLeaderWithPointer , itemOverlay, skillsOverlay, placesFromState, placesOverlay , factionsFromState, factionsOverlay , describeMode, modesOverlay , pickNumber, guardItemSize, lookAtItems, lookAtStash, lookAtPosition , displayOneMenuItem, okxItemLoreInline, okxItemLoreMsg, itemDescOverlays , cycleLore, spoilsBlurb, ppContainerWownW, nxtGameMode #ifdef EXPOSE_INTERNAL -- * Internal operations , itemOverlayFromState, lookAtTile, lookAtActors, guardItemVerbs #endif ) where import Prelude () import Game.LambdaHack.Core.Prelude import Control.Applicative import qualified Data.Char as Char 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 qualified NLP.Miniutter.English as MU 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 Game.LambdaHack.Client.UI.Frame import Game.LambdaHack.Client.UI.ItemDescription 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.PointUI 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.ClientOptions import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.HighScore as HighScore 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 Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types import qualified Game.LambdaHack.Content.FactionKind as FK import qualified Game.LambdaHack.Content.ItemKind as IK import qualified Game.LambdaHack.Content.ModeKind as MK import qualified Game.LambdaHack.Content.PlaceKind as PK import qualified Game.LambdaHack.Content.TileKind as TK import qualified Game.LambdaHack.Definition.Ability as Ability import qualified Game.LambdaHack.Definition.Color as Color import Game.LambdaHack.Definition.Defs -- | Message describing the cause of failure of human command. newtype FailError = FailError {failError :: Text} deriving (Show, Eq) 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 -- | Switches current pointman to the next on the level, if any, wrapping. pointmanCycleLevel :: MonadClientUI m => ActorId -> Bool -> Direction -> m MError pointmanCycleLevel leader verbose direction = do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD lidV <- viewedLevelUI body <- getsState $ getActorBody leader hs <- partyAfterLeader leader let banned = bannedPointmanSwitchBetweenLevels fact hsSort = case direction of Forward -> hs Backward -> reverse hs case filter (\(_, b, _) -> blid b == lidV) hsSort of _ | banned && lidV /= blid body -> failMsg $ showReqFailure NoChangeDunLeader [] -> failMsg "cannot pick any other pointman on this level" (np, _b, _) : _ -> do _success <- pickLeader verbose np -- This apparently crashes rarely, probably becuase @leader@ gets out of sync -- with the leader in client state, during nested UI manipulations. -- The worst that can happen is TAB doing nothing and having to be repeated -- or perhaps item manipulation needs to be exited for TAB to work again. -- let !_A = assert (success `blame` "same leader" -- `swith` (leader, np, b)) () return Nothing -- | Switches current pointman to the previous in the whole dungeon, wrapping. pointmanCycle :: MonadClientUI m => ActorId -> Bool -> Direction -> m MError pointmanCycle leader verbose direction = do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD hs <- partyAfterLeader leader let banned = bannedPointmanSwitchBetweenLevels fact hsSort = case direction of Forward -> hs Backward -> reverse hs case hsSort of _ | banned -> 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 <- getsClient sside sactorUI <- getsSession sactorUI allOurs <- getsState $ fidActorNotProjGlobalAssocs side -- not only on level 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 -- | Select a faction leader. False, if nothing to do. pickLeader :: MonadClientUI m => Bool -> ActorId -> m Bool pickLeader verbose aid = do mleader <- getsClient sleader if mleader == Just aid then return False -- already picked else do body <- getsState $ getActorBody aid bodyUI <- getsSession $ getActorUI aid let !_A = assert (not (bproj body) `blame` "projectile chosen as the pointman" `swith` (aid, body)) () -- Even if it's already the leader, give his proper name, not 'you'. let subject = partActor bodyUI when verbose $ msgAdd MsgPointmanSwap $ makeSentence [subject, "picked as a pointman"] -- Update client state. updateClientLeader aid -- Move the xhair, if active, to the new level. modifySession $ \sess -> sess {saimMode = (\aimMode -> aimMode {aimLevelId = blid body}) <$> saimMode sess} -- Inform about items, etc. saimMode <- getsSession saimMode when verbose $ if isJust saimMode then doLook else do (itemsBlurb, _) <- lookAtItems True (bpos body) (blid body) (Just aid) Nothing stashBlurb <- lookAtStash (bpos body) (blid body) msgAdd MsgAtFeetMinor $ stashBlurb <+> itemsBlurb return True -- | Perform look around in the current position of the xhair. -- Does nothing outside aiming mode. doLook :: MonadClientUI m => m () doLook = do saimMode <- getsSession saimMode case saimMode of Just aimMode -> do let lidV = aimLevelId aimMode mxhairPos <- mxhairToPos xhairPos <- xhairToPos blurb <- lookAtPosition xhairPos lidV itemSel <- getsSession sitemSel mleader <- getsClient sleader outOfRangeBlurb <- case (itemSel, mxhairPos, mleader) of (Just (iid, _, _), Just pos, Just leader) -> do b <- getsState $ getActorBody leader if lidV /= blid b -- no range warnings on remote levels || detailLevel aimMode < DetailHigh -- no spam then return [] else do itemFull <- getsState $ itemToFull iid let arItem = aspectRecordFull itemFull return [ (MsgPromptGeneric, "This position is out of range when flinging the selected item.") | 1 + IA.totalRange arItem (itemKind itemFull) < chessDist (bpos b) pos ] _ -> return [] mapM_ (uncurry msgAdd) $ blurb ++ outOfRangeBlurb _ -> return () pickLeaderWithPointer :: MonadClientUI m => ActorId -> m MError pickLeaderWithPointer leader = 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 banned = bannedPointmanSwitchBetweenLevels fact pick (aid, b) = if blid b /= arena && banned then failMsg $ showReqFailure NoChangeDunLeader else do void $ pickLeader True aid return Nothing pUI <- getsSession spointer let p@(Point px py) = squareToMap $ uiToSquare pUI -- Pick even if no space in status line for the actor's symbol. if | py == rheight - 2 && px == 0 -> pointmanCycle leader True Forward | py == rheight - 2 -> case drop (px - 1) viewed of [] -> return Nothing -- relaxed, due to subtleties of display of selected actors (aid, b, _) : _ -> pick (aid, b) | otherwise -> case find (\(_, b, _) -> bpos b == p) oursUI of Nothing -> failMsg "not pointing at an actor" Just (aid, b, _) -> pick (aid, b) itemOverlayFromState :: LevelId -> [(ItemId, ItemQuant)] -> Bool -> CCUI -> FactionId -> DiscoveryBenefit -> FontSetup -> State -> OKX itemOverlayFromState arena iids displayRanged sccui side discoBenefit FontSetup{..} s = let CCUI{coscreen=ScreenContent{rwidth}} = sccui localTime = getLocalTime arena s itemToF = flip itemToFull s factionD = sfactionD s attrCursor = Color.defAttr {Color.bg = Color.HighlightNoneCursor} markEqp periodic k ncha = if | periodic -> '"' -- if equipped, no charges | ncha == 0 -> '-' -- no charges left | k > ncha -> '~' -- not all charges left | otherwise -> '+' pr :: MenuSlot -> (ItemId, ItemQuant) -> (AttrString, AttrString, KeyOrSlot) pr c (iid, kit@(k, _)) = let itemFull = itemToF iid arItem = aspectRecordFull itemFull colorSymbol = if IA.checkFlag Ability.Condition arItem then viewItemBenefitColored discoBenefit iid itemFull else viewItem itemFull phrase = makePhrase [partItemWsRanged rwidth side factionD displayRanged DetailLow 4 k localTime itemFull kit] ncha = ncharges localTime kit periodic = IA.checkFlag Ability.Periodic arItem !cLab = Color.AttrChar { acAttr = attrCursor , acChar = markEqp periodic k ncha } asLab = [Color.attrCharToW32 cLab] ++ [Color.spaceAttrW32 | isSquareFont propFont] ++ [colorSymbol] !tDesc = " " <> phrase in (asLab, textToAS tDesc, Right c) l = zipWith pr natSlots iids in labDescOKX squareFont propFont l -- | Extract whole-dungeon statistics for each place kind, -- counting the number of occurrences of each type of -- `Game.LambdaHack.Content.PlaceKind.PlaceEntry` -- for the given place kind and gathering the set of levels -- on which any entry for that place kind can be found. placesFromState :: ContentData PK.PlaceKind -> Bool -> State -> EM.EnumMap (ContentId PK.PlaceKind) (ES.EnumSet LevelId, Int, Int, Int) placesFromState coplace sexposePlaces s = let addEntries (!es1, !nEntries1, !nArounds1, !nExists1) (!es2, !nEntries2, !nArounds2, !nExists2) = let !es = ES.union es1 es2 !nEntries = nEntries1 + nEntries2 !nArounds = nArounds1 + nArounds2 !nExists = nExists1 + nExists2 in (es, nEntries, nArounds, nExists) 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.PExists pk) em = EM.insertWith addEntries pk (ES.singleton lid, 0, 0, 1) em in EM.foldr' f EM.empty lentry -- go through place entrances and depending on the place -- add an entry for it, whether Entry/Around/Exists, -- the effect being we're counting #s of each type insertZeros !em !pk _ = EM.insert pk (ES.empty, 0, 0, 0) em -- The initial places are overwritten except for those -- that have no entries in the dungeon at all, -- and in `sexposePlaces` debug mode these will be shown even though -- the stats will be zeros (which is a valuable warning!). initialPlaces | not sexposePlaces = EM.empty | otherwise = ofoldlWithKey' coplace insertZeros EM.empty in EM.unionWith addEntries initialPlaces (EM.unionsWith addEntries $ map placesFromLevel $ EM.assocs $ sdungeon s) -- gather per-place-kind statistics for each level, -- then aggregate them over all levels, remembering that the place -- appeared on the given level (but not how man times) -- TODO: if faction not known, it's info should not be updated -- by the server. But let's wait until server sends general state diffs -- and then block diffs that don't apply, because faction is missing. factionsFromState :: ItemRoles -> State -> [(FactionId, Faction)] factionsFromState (ItemRoles itemRoles) s = let seenTrunks = ES.toList $ itemRoles EM.! STrunk trunkBelongs fid iid = jfid (getItemBody iid s) == Just fid factionSeen (fid, fact) = not (EM.null (gvictims fact)) -- shortcut || any (trunkBelongs fid) seenTrunks in filter factionSeen $ EM.assocs $ sfactionD s itemOverlay :: MonadClientUI m => [(ItemId, ItemQuant)] -> ItemDialogMode -> m OKX itemOverlay iids dmode = do sccui <- getsSession sccui side <- getsClient sside arena <- getArenaUI discoBenefit <- getsClient sdiscoBenefit fontSetup <- getFontSetup let displayRanged = dmode `elem` [ MStore CGround, MStore CEqp, MStore CStash , MOwned, MLore SItem, MLore SBlast ] okx <- getsState $ itemOverlayFromState arena iids displayRanged sccui side discoBenefit fontSetup return $! okx skillsOverlay :: MonadClientUI m => ActorId -> m OKX skillsOverlay aid = do b <- getsState $ getActorBody aid actorMaxSk <- getsState $ getActorMaxSkills aid FontSetup{..} <- getFontSetup let prSlot :: MenuSlot -> Ability.Skill -> ((AttrLine, (Int, AttrLine), (Int, AttrLine)), KYX) prSlot c skill = let skName = " " <> skillName skill attrCursor = Color.defAttr {Color.bg = Color.HighlightNoneCursor} labAc = Color.AttrChar { acAttr = attrCursor , acChar = '+' } lab = attrStringToAL [Color.attrCharToW32 labAc] labLen = textSize squareFont $ attrLine lab indentation = if isSquareFont propFont then 52 else 26 valueText = skillToDecorator skill b $ Ability.getSk skill actorMaxSk triple = ( lab , (labLen, textToAL skName) , (indentation, textToAL valueText) ) lenButton = 26 + T.length valueText in (triple, (Right c, ( PointUI 0 (fromEnum c) , ButtonWidth propFont lenButton ))) (ts, kxs) = unzip $ zipWith prSlot natSlots skillsInDisplayOrder (skLab, skDescr, skValue) = unzip3 ts skillLab = EM.singleton squareFont $ offsetOverlay skLab skillDescr = EM.singleton propFont $ offsetOverlayX skDescr skillValue = EM.singleton monoFont $ offsetOverlayX skValue return (EM.unionsWith (++) [skillLab, skillDescr, skillValue], kxs) placesOverlay :: MonadClientUI m => m OKX placesOverlay = do COps{coplace} <- getsState scops soptions <- getsClient soptions FontSetup{..} <- getFontSetup places <- getsState $ placesFromState coplace (sexposePlaces soptions) let prSlot :: MenuSlot -> (ContentId PK.PlaceKind, (ES.EnumSet LevelId, Int, Int, Int)) -> (AttrString, AttrString, KeyOrSlot) prSlot c (pk, (es, _, _, _)) = let name = PK.pname $ okind coplace pk labChar = if ES.null es then '-' else '+' attrCursor = Color.defAttr {Color.bg = Color.HighlightNoneCursor} labAc = Color.AttrChar { acAttr = attrCursor , acChar = labChar } -- Bang required to free @places@ as you go. !asLab = [Color.attrCharToW32 labAc] !tDesc = " " <> name <+> if ES.null es then "" else "(" <> makePhrase [MU.CarWs (ES.size es) "level"] <> ")" in (asLab, textToAS tDesc, Right c) l = zipWith prSlot natSlots $ EM.assocs places return $! labDescOKX squareFont propFont l factionsOverlay :: MonadClientUI m => m OKX factionsOverlay = do FontSetup{..} <- getFontSetup sroles <- getsSession sroles factions <- getsState $ factionsFromState sroles let prSlot :: MenuSlot -> (FactionId, Faction) -> (AttrString, AttrString, KeyOrSlot) prSlot c (_, fact) = let name = FK.fname $ gkind fact -- we ignore "Controlled", etc. gameOver = isJust $ gquit fact labChar = if gameOver then '-' else '+' attrCursor = Color.defAttr {Color.bg = Color.HighlightNoneCursor} labAc = Color.AttrChar { acAttr = attrCursor , acChar = labChar } !asLab = [Color.attrCharToW32 labAc] !tDesc = " " <> name <+> case gquit fact of Just Status{stOutcome} | not $ isHorrorFact fact -> "(" <> FK.nameOutcomePast stOutcome <> ")" _ -> "" in (asLab, textToAS tDesc, Right c) l = zipWith prSlot natSlots factions return $! labDescOKX squareFont propFont l modesOverlay :: MonadClientUI m => m OKX modesOverlay = do COps{comode} <- getsState scops FontSetup{..} <- getFontSetup svictories <- getsSession svictories nxtChal <- getsClient snxtChal -- mark victories only for current difficulty let f !acc _p !i !a = (i, a) : acc campaignModes = ofoldlGroup' comode MK.CAMPAIGN_SCENARIO f [] prSlot :: MenuSlot -> (ContentId MK.ModeKind, MK.ModeKind) -> (AttrString, AttrString, KeyOrSlot) prSlot c (gameModeId, gameMode) = let modeName = MK.mname gameMode victories = case EM.lookup gameModeId svictories of Nothing -> 0 Just cm -> fromMaybe 0 (M.lookup nxtChal cm) labChar = if victories > 0 then '-' else '+' attrCursor = Color.defAttr {Color.bg = Color.HighlightNoneCursor} labAc = Color.AttrChar { acAttr = attrCursor , acChar = labChar } !asLab = [Color.attrCharToW32 labAc] !tDesc = " " <> modeName in (asLab, textToAS tDesc, Right c) l = zipWith prSlot natSlots campaignModes return $! labDescOKX squareFont propFont l describeMode :: MonadClientUI m => Bool -> ContentId MK.ModeKind -> m (EM.EnumMap DisplayFont Overlay) describeMode addTitle gameModeId = do COps{comode} <- getsState scops CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui FontSetup{..} <- getFontSetup scoreDict <- getsState shigh scampings <- getsSession scampings srestarts <- getsSession srestarts side <- getsClient sside total <- getsState $ snd . calculateTotal side dungeonTotal <- getsState sgold let screensaverBlurb = "This is one of the screensaver scenarios, not available from the main menu, with all factions controlled by AI. Feel free to take over or relinquish control at any moment, but to register a legitimate high score, choose a standard scenario instead.\n" let gameMode = okind comode gameModeId duplicateEOL '\n' = "\n\n" duplicateEOL c = T.singleton c sections = [ ( textFgToAS Color.BrGreen "The story so far:" , T.concatMap duplicateEOL (MK.mdesc gameMode) ) , ( textFgToAS Color.cMeta "Rules of the game:" , MK.mrules gameMode ) , ( textFgToAS Color.BrCyan "Running commentary:" , T.concatMap duplicateEOL (if MK.mattract gameMode then screensaverBlurb <> MK.mreason gameMode else MK.mreason gameMode) ) , ( textFgToAS Color.cGreed "Hints, not needed unless stuck:" , T.concatMap duplicateEOL (MK.mhint gameMode) ) ] renderSection :: (AttrString, Text) -> Maybe [(DisplayFont, AttrString)] renderSection (header, desc) = if T.null desc then Nothing else Just [(monoFont, header), (propFont, textToAS desc)] survivingHow = if | total == 0 -> "(barely)" | total < dungeonTotal `div` 2 -> "(so far)" | otherwise -> "" title = if addTitle then "\nYou are" <+> survivingHow <+> "surviving the '" <> MK.mname gameMode <> "' adventure.\n" else "" blurb = map (second $ splitAttrString (rwidth - 2) (rwidth - 2)) $ (propFont, textToAS (title <> "\n")) : intercalate [(monoFont, textToAS "\n")] (mapMaybe renderSection sections) -- Colour is used to delimit the section when displayed in one -- column, when using square fonts only. blurbEnd = map (second $ splitAttrString (rwidth - 2) (rwidth - 2)) $ ( propFont , textFgToAS Color.Brown "\nThis adventure's endings experienced so far:\n\n" ) : if null sectionsEndAS then [(monoFont, textToAS "*none*")] else sectionsEndAS sectionsEndAS = intercalate [(monoFont, textToAS "\n")] (mapMaybe renderSection sectionsEnd) sectionsEnd = map outcomeSection [minBound..maxBound] outcomeSection :: FK.Outcome -> (AttrString, Text) outcomeSection outcome = ( renderOutcome outcome , if not (outcomeSeen outcome) then "" -- a possible spoiler and lack of sense of progression else T.concatMap duplicateEOL $ fromMaybe "" $ lookup outcome $ MK.mendMsg gameMode ++ endMsgDefault -- left-biased ) -- These are not added to @mendMsg@, because they only fit here. endMsgDefault = [ (FK.Restart, "No shame there is in noble defeat and there is honour in perseverance. Sometimes there are ways and places to turn rout into victory.") , (FK.Camping, "Don't fear to take breaks. While you move, others move, even on distant floors, but while you stay still, the world stays still.") ] scoreRecords = maybe [] HighScore.unTable $ EM.lookup gameModeId scoreDict -- This doesn't use @svictories@, but high scores, because high scores -- are more persistent and granular (per-outcome). OTOH, @svictories@ -- are per-challenge, which is important in other cases. -- @Camping@ and @Restart@ are fine to be less persistent. outcomeSeen :: FK.Outcome -> Bool outcomeSeen outcome = case outcome of FK.Camping -> gameModeId `ES.member` scampings FK.Restart -> gameModeId `ES.member` srestarts _ -> outcome `elem` map (stOutcome . HighScore.getStatus) scoreRecords -- Camping not taken into account. lastOutcome :: FK.Outcome lastOutcome = if null scoreRecords then FK.Restart -- only if nothing else else stOutcome . HighScore.getStatus $ maximumBy (comparing HighScore.getDate) scoreRecords renderOutcome :: FK.Outcome -> AttrString renderOutcome outcome = let color | outcome `elem` FK.deafeatOutcomes = Color.cVeryBadEvent | outcome `elem` FK.victoryOutcomes = Color.cVeryGoodEvent | otherwise = Color.cNeutralEvent lastRemark | outcome /= lastOutcome = "" | outcome `elem` FK.deafeatOutcomes = "(last suffered ending)" | outcome `elem` FK.victoryOutcomes = "(last achieved ending)" | otherwise = "(last seen ending)" in textToAS "Game over message when" <+:> (textFgToAS color (T.toTitle $ FK.nameOutcomePast outcome) <+:> textToAS lastRemark) <> textToAS ":" return $! if isSquareFont propFont then EM.singleton squareFont -- single column, single font $ xtranslateOverlay 2 $ offsetOverlay $ concatMap snd $ blurb ++ blurbEnd else EM.unionWith (++) (EM.map (xtranslateOverlay 1) $ attrLinesToFontMap blurb) (EM.map (xtranslateOverlay $ rwidth + 1) $ attrLinesToFontMap blurbEnd) 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 msgAdd MsgPromptGeneric 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 slot -> error $ "unexpected menu slot" `showFailure` slot if kAll == 1 || not askNumber then return $ Right kAll else do res <- gatherNumber kAll case res of Right k | k <= 0 -> error $ "" `showFailure` (res, kAll) _ -> return res -- | Produces a textual description of the tile at a position. lookAtTile :: MonadClientUI m => Bool -- ^ can be seen right now? -> Point -- ^ position to describe -> LevelId -- ^ level the position is at -> Maybe ActorId -- ^ the actor that looks -> Maybe MU.Person -- ^ grammatical person of the item(s), if any -> m (Text, Text, [(Int, MU.Part)]) lookAtTile canSee p lidV maid mperson = do CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui cops@COps{cotile, coplace} <- getsState scops side <- getsClient sside factionD <- getsState sfactionD mb <- getsState $ \s -> flip getActorBody s <$> maid lvl <- getLevel lidV saimMode <- getsSession saimMode embeds <- getsState $ getEmbedBag lidV p itemToF <- getsState $ flip itemToFull seps <- getsClient seps localTime <- getsState $ getLocalTime lidV getKind <- getsState $ flip getIidKind let inhabitants = posToAidsLvl p lvl detail = maybe DetailAll detailLevel saimMode aims = isJust $ (\b -> makeLine False b p seps cops lvl) =<< mb tkid = lvl `at` p tile = okind cotile tkid vis | TK.tname tile == "unknown space" = "that is" | not (null inhabitants) && (bpos <$> mb) /= Just p = "the terrain here is" | not canSee = "you remember" | not aims = "you are aware of" -- walkable path a proxy for in LOS | otherwise = "you see" vperson = case mperson of Nothing -> vis Just MU.Sg1st -> error "an item speaks in first person" Just MU.Sg3rd -> "It is laying on" Just MU.PlEtc -> "They lay on" tilePart = MU.AW $ MU.Text $ TK.tname tile entrySentence pk blurb = makeSentence [blurb, MU.Text $ PK.pname $ okind coplace pk] placeBlurb = 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.PExists _) -> "" embedLook (iid, kit@(k, _)) = let itemFull = itemToF iid nWs = partItemWsDetail detail rwidth side factionD k localTime itemFull kit in (k, nWs) embedKindList = map (\(iid, kit) -> (getKind iid, (iid, kit))) (EM.assocs embeds) embedList = map embedLook $ sortEmbeds cops tkid embedKindList return (makeSentence [vperson, tilePart], placeBlurb, embedList) -- | Produces a textual description of actors at a position. lookAtActors :: MonadClientUI m => Point -- ^ position to describe -> LevelId -- ^ level the position is at -> m (Text, Maybe (MU.Part, Bool), Text) lookAtActors p lidV = do CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui side <- getsClient sside inhabitants <- getsState $ posToAidAssocs p lidV factionD <- getsState sfactionD localTime <- getsState $ getLocalTime lidV saimMode <- getsSession saimMode let detail = maybe DetailAll detailLevel saimMode case inhabitants of [] -> return ("", Nothing, "") (aid, body) : rest -> do actorPronoun <- partPronounLeader aid itemFull <- getsState $ itemToFull $ btrunk body guardVerbs <- getsState $ guardItemVerbs body subjects <- mapM (partActorLeader . fst) inhabitants let bfact = factionD EM.! bfid body -- No "a" prefix even if singular and inanimate, to distinguish -- from items lying on the floor (and to simplify code). (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" flyVerb | bproj body = "zip through here" | isJust $ btrajectory body = "move through here" | otherwise = resideVerb verbs = flyVerb : guardVerbs projDesc | not (bproj body) || detail < DetailHigh = "" | otherwise = let kit = beqp body EM.! btrunk body ps = [partItemMediumAW rwidth 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 <> "." _ | detail < DetailHigh -> "" -- only domination worth spamming _ | bfid body == side -> "" -- just one of us _ | bproj body -> "Launched by" <+> gname bfact <> "." _ -> "One of" <+> gname bfact <> "." idesc = if detail < DetailHigh then "" else IK.idesc $ itemKind itemFull -- If many different actors, only list names. sameTrunks = all (\(_, b) -> btrunk b == btrunk body) rest desc = wrapInParens $ projDesc <+> factDesc <+> idesc onlyIs = bwatch body == WWatch && null guardVerbs allBlurb = makeSentence [MU.SubjectVVxV "and" person MU.Yes subject verbs] headBlurb = makeSentence [MU.SubjectVVxV "and" MU.Sg3rd MU.Yes (head subjects) verbs] andProjectiles = case subjects of _ : projs@(_ : _) -> let (subjectProjs, personProjs) = squashedWWandW projs in makeSentence [MU.SubjectVerb personProjs MU.Yes subjectProjs "can be seen"] _ -> "" actorAlive = bhp body >= 0 mactorPronounAlive = if bproj body then Nothing else Just (actorPronoun, actorAlive) return $! if | not actorAlive && 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" ]) , mactorPronounAlive , wrapInParens desc <+> andProjectiles ) | sameTrunks -> -- only non-proj or several similar projectiles ( allBlurb , mactorPronounAlive , desc ) | not (bproj body) && onlyIs -> ( headBlurb , mactorPronounAlive , desc <+> andProjectiles ) | not (bproj body) -> ( makeSentence [subject, "can be seen"] <+> headBlurb , mactorPronounAlive , desc ) | otherwise -> assert (bproj body && not (null rest)) ( makeSentence [subject, "can be seen"] , Nothing , "" ) guardItemVerbs :: Actor -> State -> [MU.Part] guardItemVerbs body s = -- We only hint while, in reality, currently the client knows -- all the items in eqp of the foe. But we may remove the knowledge -- in the future and, anyway, it would require a dedicated -- UI mode beyond a couple of items per actor. let itemsSize = guardItemSize body s belongingsVerbs | itemsSize == 1 = ["fondle a trinket"] | itemsSize > 1 = ["haul a hoard"] | otherwise = [] in if bproj body then [] else belongingsVerbs guardItemSize :: Actor -> State -> Int guardItemSize body s = let toReport iid = let itemKind = getIidKind iid s in fromMaybe 0 (lookup IK.UNREPORTED_INVENTORY (IK.ifreq itemKind)) <= 0 in length $ filter toReport $ EM.keys (beqp body) -- | Produces a textual description of items at a position. lookAtItems :: MonadClientUI m => Bool -- ^ can be seen right now? -> Point -- ^ position to describe -> LevelId -- ^ level the position is at -> Maybe ActorId -- ^ the actor that looks -> Maybe (MU.Part, Bool) -- ^ pronoun for the big actor at the position, if any, -- and whether the big actor is alive -> m (Text, Maybe MU.Person) lookAtItems canSee p lidV maid mactorPronounAlive = do CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui side <- getsClient sside itemToF <- getsState $ flip itemToFull mb <- getsState $ \s -> flip getActorBody s <$> maid -- Not using @viewedLevelUI@, because @aid@ may be temporarily not a leader. saimMode <- getsSession saimMode let standingOn = Just p == (bpos <$> mb) && Just lidV == (blid <$> mb) -- In exploration mode the detail level depends on whether the actor -- that looks stand over the items, because then he can check details -- with inventory commands (or look in aiming mode). detailExploration = if standingOn && Just side == (bfid <$> mb) then DetailLow else DetailAll detail = maybe detailExploration detailLevel saimMode localTime <- getsState $ getLocalTime lidV is <- getsState $ getFloorBag lidV p factionD <- getsState sfactionD globalTime <- getsState stime getKind <- getsState $ flip getIidKindId mLeader <- case maid of Just aid | standingOn -> do leaderPronoun <- partPronounLeader aid return $ Just (leaderPronoun, (bhp <$> mb) >= Just 0) _ -> return Nothing let mactorPronounAliveLeader = mactorPronounAlive <|> mLeader (subject, verb) <- case mactorPronounAliveLeader of Just (actorPronoun, actorAlive) -> return (actorPronoun, if actorAlive then "stand over" else "fall over") Nothing -> case maid of Just aid -> do subjectAid <- partActorLeader aid return (subjectAid, if canSee then "notice" else "remember") Nothing -> return ("one", if canSee then "can see" else "may remember") let nWs (iid, kit@(k, _)) = partItemWsDetail detail rwidth side factionD k localTime (itemToF iid) kit (object, person) = case EM.assocs is of ii : _ : _ : _ | detail <= DetailMedium -> (MU.Phrase [nWs ii, "and other items"], MU.PlEtc) [ii@(_, (1, _))] -> (nWs ii, MU.Sg3rd) iis -> (MU.WWandW $ map nWs $ sortOn (getKind . fst) iis, MU.PlEtc) -- Here @squashedWWandW@ is not needed, because identical items at the same -- position are already merged in the floor item bag and multiple identical -- messages concerning different positions are merged with -- to distinguish from a stack of items at a single position. return ( if EM.null is || globalTime == timeZero then "" else makeSentence [MU.SubjectVerbSg subject (MU.Text verb), object] , if isNothing mactorPronounAlive then Just person else Nothing ) lookAtStash :: MonadClientUI m => Point -> LevelId -> m Text lookAtStash p lidV = do side <- getsClient sside factionD <- getsState sfactionD let locateStash (fid, fact) = case gstash fact of Just (lid, pos) | lid == lidV && pos == p -> Just $ if fid == side then "Here is the shared inventory stash of your team." else gname fact <+> "set up their shared inventory stash here." _ -> Nothing return $! T.intercalate " " $ mapMaybe locateStash $ EM.assocs factionD -- | Produces a textual description of everything at the requested -- level's position. lookAtPosition :: MonadClientUI m => Point -> LevelId -> m [(MsgClassShow, Text)] lookAtPosition p lidV = do COps{cotile} <- getsState scops side <- getsClient sside per <- getPerFid lidV let canSee = ES.member p (totalVisible per) (actorsBlurb, mactorPronounAlive, actorsDesc) <- lookAtActors p lidV mleader <- getsClient sleader (itemsBlurb, mperson) <- lookAtItems canSee p lidV mleader mactorPronounAlive let tperson = if T.null itemsBlurb then Nothing else mperson (tileBlurb, placeBlurb, embedsList) <- lookAtTile canSee p lidV mleader tperson inhabitants <- getsState $ posToAidAssocs p lidV let actorMsgClass = if (bfid . snd <$> inhabitants) == [side] then MsgPromptGeneric -- our single proj or non-proj; tame else MsgPromptActors stashBlurb <- lookAtStash p lidV lvl@Level{lsmell, ltime} <- getLevel lidV saimMode <- getsSession saimMode let detail = maybe DetailAll detailLevel saimMode 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." _ -> "" embeds <- getsState $ getEmbedBag lidV p getKind <- getsState $ flip getIidKind let ppEmbedName :: (Int, MU.Part) -> Text ppEmbedName (k, part) = let verb = if k == 1 then "is" else "are" in makeSentence ["There", verb, part] embedKindList = map (\(iid, kit) -> (getKind iid, (iid, kit))) (EM.assocs embeds) feats = TK.tfeature $ okind cotile $ lvl `at` p tileActions = mapMaybe (parseTileAction False False embedKindList) feats isEmbedAction EmbedAction{} = True isEmbedAction _ = False embedVerb = [ "activated" | any isEmbedAction tileActions && any (\(itemKind, _) -> not $ null $ IK.ieffects itemKind) embedKindList ] isToAction ToAction{} = True isToAction _ = False isWithAction WithAction{} = True isWithAction _ = False isEmptyWithAction (WithAction [] _) = True isEmptyWithAction _ = False alterVerb | any isEmptyWithAction tileActions = ["very easily modified"] | any isToAction tileActions = ["easily modified"] | any isWithAction tileActions = ["potentially modified"] | otherwise = [] verbs = embedVerb ++ alterVerb alterBlurb = if null verbs then "" else makeSentence ["can be", MU.WWandW verbs] toolFromAction (WithAction grps _) = Just grps toolFromAction _ = Nothing toolsToAlterWith = mapMaybe toolFromAction tileActions tItems = describeToolsAlternative toolsToAlterWith transformBlurb = if T.null tItems then "" else "The following items on the ground or in equipment enable special transformations:" <+> tItems <> "." -- not telling to what terrain modifyBlurb = alterBlurb <+> transformBlurb midEOL = if detail < DetailMedium || T.null stashBlurb && T.null actorsDesc || T.null smellBlurb && T.null itemsBlurb || null embedsList && T.null modifyBlurb then "" else "\n" ms = [ (MsgPromptAction, stashBlurb) , (actorMsgClass, actorsBlurb) , (MsgPromptGeneric, actorsDesc <> midEOL) ] ++ [(MsgPromptGeneric, smellBlurb) | detail >= DetailMedium] ++ [(MsgPromptItems, itemsBlurb <> midEOL)] ++ [(MsgPromptFocus, tileBlurb) | detail >= DetailMedium || detail == DetailLow && not (null embedsList)] ++ [(MsgPromptGeneric, placeBlurb) | detail >= DetailMedium] ++ case detail of DetailLow -> [] -- not to obscure aiming line _ -> let n = sum $ map fst embedsList wWandW = MU.WWandW $ map snd embedsList in [(MsgPromptMention, ppEmbedName (n, wWandW)) | n > 0] ++ [(MsgPromptModify, modifyBlurb) | detail >= DetailHigh] return $! if all (T.null . snd) ms && detail > DetailLow then [(MsgPromptFocus, tileBlurb)] else ms displayOneMenuItem :: MonadClientUI m => (MenuSlot -> m OKX) -> [K.KM] -> Int -> MenuSlot -> m K.KM displayOneMenuItem renderOneItem extraKeys slotBound slot = do CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui let keys = [K.spaceKM, K.escKM] ++ [K.upKM | fromEnum slot > 0] ++ [K.downKM | fromEnum slot < slotBound] ++ extraKeys okx <- renderOneItem slot slides <- overlayToSlideshow (rheight - 2) keys okx km <- getConfirms ColorFull keys slides case K.key km of K.Up -> displayOneMenuItem renderOneItem extraKeys slotBound $ pred slot K.Down -> displayOneMenuItem renderOneItem extraKeys slotBound $ succ slot _ -> return km okxItemLoreInline :: MonadClientUI m => (ItemId -> ItemFull -> Int -> Text) -> Int -> ItemDialogMode -> [(ItemId, ItemQuant)] -> Int -> MenuSlot -> m OKX okxItemLoreInline promptFun meleeSkill dmode iids widthRaw slot = do FontSetup{..} <- getFontSetup let (iid, kit@(k, _)) = iids !! fromEnum slot -- Some prop fonts are wider than mono (e.g., in dejavuBold font set), -- so the width in these artificial texts full of digits and strange -- characters needs to be smaller than @rwidth - 2@ that would suffice -- for mono. width = widthRaw - 5 itemFull <- getsState $ itemToFull iid (ovLab, ovDesc) <- itemDescOverlays True meleeSkill dmode iid kit itemFull width let prompt = promptFun iid itemFull k promptBlurb | T.null prompt = [] | otherwise = offsetOverlay $ splitAttrString width width $ textFgToAS Color.Brown $ prompt <> "\n\n" len = length promptBlurb descSym2 = ytranslateOverlay len ovLab descBlurb2 = promptBlurb ++ ytranslateOverlay len ovDesc ov = EM.insertWith (++) squareFont descSym2 $ EM.singleton propFont descBlurb2 return (ov, []) okxItemLoreMsg :: MonadClientUI m => (ItemId -> ItemFull -> Int -> Text) -> Int -> ItemDialogMode -> [(ItemId, ItemQuant)] -> MenuSlot -> m OKX okxItemLoreMsg promptFun meleeSkill dmode iids slot = do CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui FontSetup{..} <- getFontSetup let (iid, kit@(k, _)) = iids !! fromEnum slot itemFull <- getsState $ itemToFull iid (ovLab, ovDesc) <- itemDescOverlays True meleeSkill dmode iid kit itemFull rwidth let prompt = promptFun iid itemFull k msgAdd MsgPromptGeneric prompt let ov = EM.insertWith (++) squareFont ovLab $ EM.singleton propFont ovDesc return (ov, []) itemDescOverlays :: MonadClientUI m => Bool -> Int -> ItemDialogMode -> ItemId -> ItemQuant -> ItemFull -> Int -> m (Overlay, Overlay) itemDescOverlays markParagraphs meleeSkill dmode iid kit itemFull width = do FontSetup{squareFont} <- getFontSetup side <- getsClient sside arena <- getArenaUI localTime <- getsState $ getLocalTime arena factionD <- getsState sfactionD -- The hacky level 0 marks items never seen, but sent by server at gameover. jlid <- getsSession $ fromMaybe (toEnum 0) <$> EM.lookup iid . sitemUI let descAs = itemDesc width markParagraphs side factionD meleeSkill dmode localTime jlid itemFull kit return $! labDescOverlay squareFont width descAs cycleLore :: MonadClientUI m => [m K.KM] -> [m K.KM] -> m () cycleLore _ [] = return () cycleLore seen (m : rest) = do -- @seen@ is needed for SPACE to end cycling 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 the spoils of your team are of the practical kind." | total == 0 -> "Your team haven't found any genuine treasure yet." | otherwise -> makeSentence [ "your team's spoils are worth" , MU.CarAWs total $ MU.Text currencyName , "out of the rumoured total" , MU.Cardinal dungeonTotal ] ppContainerWownW :: MonadClientUI m => (ActorId -> m MU.Part) -> Bool -> Container -> m [MU.Part] ppContainerWownW ownerFun addPrepositions c = case c of CFloor{} -> return ["nearby"] CEmbed{} -> return ["embedded nearby"] CActor aid store -> do side <- getsClient sside b <- getsState $ getActorBody aid owner <- ownerFun aid fidName <- getsState $ gname . (EM.! bfid b) . sfactionD let (preposition, noun) = ppCStore store prep = [MU.Text preposition | addPrepositions] return $! prep ++ case store of CGround -> MU.Text noun : if bproj b then [] else ["under", owner] CStash -> if bfid b /= side then [MU.WownW (MU.Text fidName) (MU.Text noun)] else [MU.Text noun] _ -> [MU.WownW owner (MU.Text noun)] CTrunk{} -> error $ "" `showFailure` c nxtGameMode :: COps -> Int -> (ContentId MK.ModeKind, MK.ModeKind) nxtGameMode COps{comode} snxtScenario = let f !acc _p !i !a = (i, a) : acc campaignModes = ofoldlGroup' comode MK.CAMPAIGN_SCENARIO f [] in campaignModes !! (snxtScenario `mod` length campaignModes)