module Game.LambdaHack.Client.UI.DrawM
( targetDesc, targetDescXhair, drawHudFrame
, checkWarningHP, checkWarningCalm
#ifdef EXPOSE_INTERNAL
, drawFrameTerrain, drawFrameContent
, drawFramePath, drawFrameActor, drawFrameExtra, drawFrameStatus
, drawArenaStatus, drawLeaderStatus, drawLeaderDamage, drawSelected
, checkWarnings
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import Control.Monad.ST.Strict
import qualified Data.Char as Char
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Int (Int64)
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
import qualified Data.Text as T
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Unboxed.Mutable as VM
import Data.Word (Word16, Word32)
import GHC.Exts (inline)
import qualified NLP.Miniutter.English as MU
import Game.LambdaHack.Client.Bfs
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.Frame
import Game.LambdaHack.Client.UI.Frontend (frontendName)
import Game.LambdaHack.Client.UI.ItemDescription
import Game.LambdaHack.Client.UI.MonadClientUI
import Game.LambdaHack.Client.UI.Overlay
import Game.LambdaHack.Client.UI.SessionUI
import Game.LambdaHack.Client.UI.UIOptions
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.ItemAspect as IA
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
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 Game.LambdaHack.Content.CaveKind (cname)
import qualified Game.LambdaHack.Content.ItemKind as IK
import qualified Game.LambdaHack.Content.ModeKind as MK
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Content.TileKind (TileKind, isUknownSpace)
import qualified Game.LambdaHack.Content.TileKind as TK
import qualified Game.LambdaHack.Core.Dice as Dice
import qualified Game.LambdaHack.Definition.Ability as Ability
import qualified Game.LambdaHack.Definition.Color as Color
import Game.LambdaHack.Definition.Defs
targetDesc :: MonadClientUI m => Maybe Target -> m (Maybe Text, Maybe Text)
targetDesc mtarget = do
arena <- getArenaUI
lidV <- viewedLevelUI
mleader <- getsClient sleader
let describeActorTarget aid = do
side <- getsClient sside
b <- getsState $ getActorBody aid
bUI <- getsSession $ getActorUI aid
actorMaxSk <- getsState $ getActorMaxSkills aid
let percentage =
100 * bhp b
`div` xM (max 5 $ Ability.getSk Ability.SkMaxHP actorMaxSk)
chs n = "[" <> T.replicate n "*"
<> T.replicate (4 - n) "_" <> "]"
stars = chs $ fromEnum $ max 0 $ min 4 $ percentage `div` 20
hpIndicator = if bfid b == side then Nothing else Just stars
return (Just $ bname bUI, hpIndicator)
case mtarget of
Just (TEnemy aid) -> describeActorTarget aid
Just (TNonEnemy aid) -> describeActorTarget aid
Just (TPoint tgoal lid p) -> case tgoal of
TEnemyPos{} -> do
let hotText = if lid == lidV && arena == lidV
then "hot spot" <+> tshow p
else "a hot spot on level" <+> tshow (abs $ fromEnum lid)
return (Just hotText, Nothing)
_ -> do
pointedText <-
if lid == lidV && arena == lidV
then do
bag <- getsState $ getFloorBag lid p
case EM.assocs bag of
[] -> return $! "exact spot" <+> tshow p
[(iid, kit@(k, _))] -> do
localTime <- getsState $ getLocalTime lid
itemFull <- getsState $ itemToFull iid
side <- getsClient sside
factionD <- getsState sfactionD
let (name, powers) =
partItem side factionD localTime itemFull kit
return $! makePhrase [MU.Car1Ws k name, powers]
_ -> return $! "many items at" <+> tshow p
else return $! "an exact spot on level" <+> tshow (abs $ fromEnum lid)
return (Just pointedText, Nothing)
Just TVector{} ->
case mleader of
Nothing -> return (Just "a relative shift", Nothing)
Just aid -> do
tgtPos <- getsState $ aidTgtToPos aid lidV mtarget
let invalidMsg = "an invalid relative shift"
validMsg p = "shift to" <+> tshow p
return (Just $ maybe invalidMsg validMsg tgtPos, Nothing)
Nothing -> return (Nothing, Nothing)
targetDescXhair :: MonadClientUI m => m (Maybe Text, Maybe (Text, Watchfulness))
targetDescXhair = do
sxhair <- getsSession sxhair
(mhairDesc, mxhairHP) <- targetDesc sxhair
case mxhairHP of
Nothing -> return (mhairDesc, Nothing)
Just tHP -> do
let aid = case sxhair of
Just (TEnemy a) -> a
Just (TNonEnemy a) -> a
_ -> error $ "HP text for non-actor target" `showFailure` sxhair
watchfulness <- bwatch <$> getsState (getActorBody aid)
return $ (mhairDesc, Just (tHP, watchfulness))
drawFrameTerrain :: forall m. MonadClientUI m => LevelId -> m (U.Vector Word32)
drawFrameTerrain drawnLevelId = do
COps{corule=RuleContent{rXmax}, cotile, coTileSpeedup} <- getsState scops
StateClient{smarkSuspect} <- getClient
Level{ltile=PointArray.Array{avector}, lembed} <- getLevel drawnLevelId
totVisible <- totalVisible <$> getPerFid drawnLevelId
frameStatus <- drawFrameStatus drawnLevelId
let dis :: PointI -> ContentId TileKind -> Color.AttrCharW32
{-# INLINE dis #-}
dis pI tile =
let TK.TileKind{tsymbol, tcolor, tcolor2} = okind cotile tile
fg :: Color.Color
fg | smarkSuspect > 0
&& Tile.isSuspect coTileSpeedup tile = Color.BrMagenta
| smarkSuspect > 1
&& Tile.isHideAs coTileSpeedup tile = Color.Magenta
|
pI `IS.member` ES.enumSetToIntSet totVisible
&& not (Tile.isEmbed coTileSpeedup tile
&& pI `IM.notMember`
EM.enumMapToIntMap lembed) = tcolor
| otherwise = tcolor2
in Color.attrChar2ToW32 fg tsymbol
g :: PointI -> Word16 -> Word32
g !pI !tile = Color.attrCharW32 $ dis pI (toContentId tile)
caveVector :: U.Vector Word32
caveVector = U.imap g avector
messageVector =
U.replicate rXmax (Color.attrCharW32 Color.spaceAttrW32)
statusVector = U.fromListN (2 * rXmax) $ map Color.attrCharW32 frameStatus
return $ U.concat [messageVector, caveVector, statusVector]
drawFrameContent :: forall m. MonadClientUI m => LevelId -> m FrameForall
drawFrameContent drawnLevelId = do
COps{corule=RuleContent{rXmax}} <- getsState scops
SessionUI{smarkSmell} <- getSession
Level{lsmell, ltime, lfloor} <- getLevel drawnLevelId
itemToF <- getsState $ flip itemToFull
let {-# INLINE viewItemBag #-}
viewItemBag _ floorBag = case EM.toDescList floorBag of
(iid, _kit) : _ -> viewItem $ itemToF iid
[] -> error $ "lfloor not sparse" `showFailure` ()
viewSmell :: PointI -> Time -> Color.AttrCharW32
{-# INLINE viewSmell #-}
viewSmell pI sml =
let fg = toEnum $ pI `rem` 13 + 2
smlt = smellTimeout `timeDeltaSubtract`
(sml `timeDeltaToFrom` ltime)
in Color.attrChar2ToW32 fg (timeDeltaToDigit smellTimeout smlt)
mapVAL :: forall a s. (PointI -> a -> Color.AttrCharW32) -> [(PointI, a)]
-> FrameST s
{-# INLINE mapVAL #-}
mapVAL f l v = do
let g :: (PointI, a) -> ST s ()
g (!pI, !a0) = do
let w = Color.attrCharW32 $ f pI a0
VM.write v (pI + rXmax) w
mapM_ g l
upd :: FrameForall
upd = FrameForall $ \v -> do
mapVAL viewItemBag (IM.assocs $ EM.enumMapToIntMap lfloor) v
when smarkSmell $
mapVAL viewSmell (filter ((> ltime) . snd)
$ IM.assocs $ EM.enumMapToIntMap lsmell) v
return upd
drawFramePath :: forall m. MonadClientUI m => LevelId -> m FrameForall
drawFramePath drawnLevelId = do
SessionUI{saimMode} <- getSession
if isNothing saimMode then return $! FrameForall $ \_ -> return () else do
COps{corule=RuleContent{rXmax, rYmax}, coTileSpeedup} <- getsState scops
StateClient{seps} <- getClient
Level{ltile=PointArray.Array{avector}} <- getLevel drawnLevelId
totVisible <- totalVisible <$> getPerFid drawnLevelId
mleader <- getsClient sleader
mpos <- getsState $ \s -> bpos . (`getActorBody` s) <$> mleader
xhairPosRaw <- xhairToPos
let xhairPos = fromMaybe (fromMaybe originPoint mpos) xhairPosRaw
bline <- case mleader of
Just leader -> do
Actor{bpos, blid} <- getsState $ getActorBody leader
return $! if blid /= drawnLevelId
then []
else fromMaybe [] $ bla rXmax rYmax seps bpos xhairPos
_ -> return []
mpath <- maybe (return Nothing) (\aid -> do
mtgtMPath <- getsClient $ EM.lookup aid . stargetD
case mtgtMPath of
Just TgtAndPath{tapPath=tapPath@(Just AndPath{pathGoal})}
| pathGoal == xhairPos -> return tapPath
_ -> getCachePath aid xhairPos) mleader
assocsAtxhair <- getsState $ posToAidAssocs xhairPos drawnLevelId
let lpath = if null bline then [] else maybe [] pathList mpath
shiftedBTrajectory = case assocsAtxhair of
(_, Actor{btrajectory = Just p, bpos = prPos}) : _->
trajectoryToPath prPos (fst p)
_ -> []
shiftedLine = if null shiftedBTrajectory
then bline
else shiftedBTrajectory
acOnPathOrLine :: Char.Char -> Point -> ContentId TileKind
-> Color.AttrCharW32
acOnPathOrLine !ch !p0 !tile =
let fgOnPathOrLine =
case ( ES.member p0 totVisible
, Tile.isWalkable coTileSpeedup tile ) of
_ | isUknownSpace tile -> Color.BrBlack
_ | Tile.isSuspect coTileSpeedup tile -> Color.BrMagenta
(True, True) -> Color.BrGreen
(True, False) -> Color.BrCyan
(False, True) -> Color.Green
(False, False) -> Color.Cyan
in Color.attrChar2ToW32 fgOnPathOrLine ch
mapVTL :: forall s. (Point -> ContentId TileKind -> Color.AttrCharW32)
-> [Point]
-> FrameST s
mapVTL f l v = do
let g :: Point -> ST s ()
g !p0 = do
let pI = fromEnum p0
tile = avector U.! pI
w = Color.attrCharW32 $ f p0 (toContentId tile)
VM.write v (pI + rXmax) w
mapM_ g l
upd :: FrameForall
upd = FrameForall $ \v -> do
mapVTL (acOnPathOrLine ';') lpath v
mapVTL (acOnPathOrLine '*') shiftedLine v
return upd
drawFrameActor :: forall m. MonadClientUI m => LevelId -> m FrameForall
drawFrameActor drawnLevelId = do
COps{corule=RuleContent{rXmax}} <- getsState scops
SessionUI{sactorUI, sselected, sUIOptions} <- getSession
Level{lbig, lproj} <- getLevel drawnLevelId
SessionUI{saimMode} <- getSession
side <- getsClient sside
mleader <- getsClient sleader
s <- getState
let {-# INLINE viewBig #-}
viewBig aid =
let Actor{bhp, bfid, btrunk, bwatch} = getActorBody aid s
ActorUI{bsymbol, bcolor} = sactorUI EM.! aid
Item{jfid} = getItemBody btrunk s
symbol | bhp > 0 = bsymbol
| otherwise = '%'
dominated = maybe False (/= bfid) jfid
leaderColor = if isJust saimMode
then Color.HighlightYellowAim
else Color.HighlightYellow
bg = if | mleader == Just aid -> leaderColor
| bwatch == WSleep -> Color.HighlightGreen
| dominated -> if bfid == side
then Color.HighlightWhite
else Color.HighlightMagenta
| ES.member aid sselected -> Color.HighlightBlue
| otherwise -> Color.HighlightNone
fg | bfid /= side || bhp <= 0 = bcolor
| otherwise =
let (hpCheckWarning, calmCheckWarning) =
checkWarnings sUIOptions aid s
in if hpCheckWarning || calmCheckWarning
then Color.Red
else bcolor
in Color.attrCharToW32 $ Color.AttrChar Color.Attr{..} symbol
{-# INLINE viewProj #-}
viewProj as = case as of
aid : _ ->
let ActorUI{bsymbol, bcolor} = sactorUI EM.! aid
bg = Color.HighlightNone
fg = bcolor
in Color.attrCharToW32 $ Color.AttrChar Color.Attr{..} bsymbol
[] -> error $ "lproj not sparse" `showFailure` ()
mapVAL :: forall a s. (a -> Color.AttrCharW32) -> [(PointI, a)]
-> FrameST s
{-# INLINE mapVAL #-}
mapVAL f l v = do
let g :: (PointI, a) -> ST s ()
g (!pI, !a0) = do
let w = Color.attrCharW32 $ f a0
VM.write v (pI + rXmax) w
mapM_ g l
upd :: FrameForall
upd = FrameForall $ \v -> do
mapVAL viewProj (IM.assocs $ EM.enumMapToIntMap lproj) v
mapVAL viewBig (IM.assocs $ EM.enumMapToIntMap lbig) v
return upd
drawFrameExtra :: forall m. MonadClientUI m
=> ColorMode -> LevelId -> m FrameForall
drawFrameExtra dm drawnLevelId = do
COps{corule=RuleContent{rXmax, rYmax}} <- getsState scops
SessionUI{saimMode, smarkVision} <- getSession
totVisible <- totalVisible <$> getPerFid drawnLevelId
mxhairPos <- xhairToPos
mtgtPos <- do
mleader <- getsClient sleader
case mleader of
Nothing -> return Nothing
Just leader -> do
mtgt <- getsClient $ getTarget leader
getsState $ aidTgtToPos leader drawnLevelId mtgt
let visionMarks =
if smarkVision
then IS.toList $ ES.enumSetToIntSet totVisible
else []
backlightVision :: Color.AttrChar -> Color.AttrChar
backlightVision ac = case ac of
Color.AttrChar (Color.Attr fg _) ch ->
Color.AttrChar (Color.Attr fg Color.HighlightGrey) ch
writeSquare !hi (Color.AttrChar (Color.Attr fg bg) ch) =
let hiUnlessLeader | bg == Color.HighlightYellow = bg
| otherwise = hi
in Color.AttrChar (Color.Attr fg hiUnlessLeader) ch
turnBW (Color.AttrChar _ ch) = Color.AttrChar Color.defAttr ch
mapVL :: forall s. (Color.AttrChar -> Color.AttrChar) -> [PointI]
-> FrameST s
mapVL f l v = do
let g :: PointI -> ST s ()
g !pI = do
w0 <- VM.read v (pI + rXmax)
let w = Color.attrCharW32 . Color.attrCharToW32
. f . Color.attrCharFromW32 . Color.AttrCharW32 $ w0
VM.write v (pI + rXmax) w
mapM_ g l
lDungeon = [0..rXmax * rYmax - 1]
xhairColor = if isJust saimMode
then Color.HighlightRedAim
else Color.HighlightRed
upd :: FrameForall
upd = FrameForall $ \v -> do
when (isJust saimMode) $ mapVL backlightVision visionMarks v
case mtgtPos of
Nothing -> return ()
Just p -> mapVL (writeSquare Color.HighlightGrey)
[fromEnum p] v
case mxhairPos of
Nothing -> return ()
Just p -> mapVL (writeSquare xhairColor)
[fromEnum p] v
when (dm == ColorBW) $ mapVL turnBW lDungeon v
return upd
drawFrameStatus :: MonadClientUI m => LevelId -> m AttrLine
drawFrameStatus drawnLevelId = do
cops@COps{corule=RuleContent{rXmax=_rXmax}} <- getsState scops
SessionUI{sselected, saimMode, swaitTimes, sitemSel} <- getSession
mleader <- getsClient sleader
xhairPos <- xhairToPos
mbfs <- maybe (return Nothing) (\aid -> Just <$> getCacheBfs aid) mleader
(mhairDesc, mxhairHPWatchfulness) <- targetDescXhair
lvl <- getLevel drawnLevelId
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
(mblid, mbpos, mbodyUI) <- case mleader of
Just leader -> do
Actor{bpos, blid} <- getsState $ getActorBody leader
bodyUI <- getsSession $ getActorUI leader
return (Just blid, Just bpos, Just bodyUI)
Nothing -> return (Nothing, Nothing, Nothing)
let widthX = 80
widthTgt = 39
widthStatus = widthX - widthTgt - 1
arenaStatus = drawArenaStatus cops lvl widthStatus
leaderStatusWidth = 23
leaderStatus <- drawLeaderStatus swaitTimes
(selectedStatusWidth, selectedStatus)
<- drawSelected drawnLevelId (widthStatus - leaderStatusWidth) sselected
let speedStatusWidth = widthStatus - leaderStatusWidth - selectedStatusWidth
speedDisplay <- case mleader of
Nothing -> return []
Just leader -> do
actorMaxSk <- getsState $ getActorMaxSkills leader
kitAssRaw <- getsState $ kitAssocs leader [CEqp, COrgan]
let speed = Ability.getSk Ability.SkSpeed actorMaxSk
unknownBonus = unknownSpeedBonus $ map (fst . snd) kitAssRaw
speedString = displaySpeed speed ++ if unknownBonus then "?" else ""
conditionBonus = conditionSpeedBonus $ map snd kitAssRaw
cspeed = case compare conditionBonus 0 of
EQ -> Color.White
GT -> Color.Green
LT -> Color.Red
return $! map (Color.attrChar2ToW32 cspeed) speedString
let speedStatus = if length speedDisplay >= speedStatusWidth
then []
else speedDisplay ++ [Color.spaceAttrW32]
displayPathText mp mt =
let (plen, llen) | Just target <- mp
, Just bfs <- mbfs
, Just bpos <- mbpos
, mblid == Just drawnLevelId
= ( fromMaybe 0 (accessBfs bfs target)
, chessDist bpos target )
| otherwise = (0, 0)
pText | plen == 0 = ""
| otherwise = "p" <> tshow plen
lText | llen == 0 = ""
| otherwise = "l" <> tshow llen
text = fromMaybe (pText <+> lText) mt
in if T.null text then "" else " " <> text
pathCsr = displayPathText xhairPos (fst <$> mxhairHPWatchfulness)
trimTgtDesc n t = assert (not (T.null t) && n > 2 `blame` (t, n)) $
if T.length t <= n then t else T.take (n - 3) t <> "..."
widthXhairOrItem = widthTgt - T.length pathCsr - 8
nMember = MU.Ord $ 1 + sum (EM.elems $ gvictims fact)
fallback = if MK.fleaderMode (gplayer fact) == MK.LeaderNull
then "This faction never picks a leader"
else makePhrase
["Waiting for", nMember, "team member to spawn"]
leaderName bUI = trimTgtDesc (widthTgt - 8) (bname bUI)
leaderBlurbLong = maybe fallback (\bUI ->
"Leader:" <+> leaderName bUI) mbodyUI
leaderBlurbShort = maybe fallback leaderName mbodyUI
ours <- getsState $ fidActorNotProjGlobalAssocs side
let na = length ours
nl = ES.size $ ES.fromList $ map (blid . snd) ours
ns = EM.size $ gsha fact
teamBlurb = textToAL $ trimTgtDesc widthTgt $
makePhrase [ "Team:"
, MU.CarWs na "actor", "on"
, MU.CarWs nl "level" <> ","
, "stash", MU.Car ns ]
markSleepTgtDesc
| (snd <$> mxhairHPWatchfulness) /= Just WSleep = textToAL
| otherwise = textFgToAL Color.Green
xhairBlurb =
maybe teamBlurb (\t ->
textToAL (if isJust saimMode then "x-hair>" else "X-hair:")
<+:> markSleepTgtDesc (trimTgtDesc widthXhairOrItem t))
mhairDesc
tgtOrItem
| Just (iid, fromCStore, _) <- sitemSel
, Just leader <- mleader
= do
b <- getsState $ getActorBody leader
bag <- getsState $ getBodyStoreBag b fromCStore
case iid `EM.lookup` bag of
Nothing -> return (xhairBlurb, pathCsr)
Just kit@(k, _) -> do
localTime <- getsState $ getLocalTime (blid b)
itemFull <- getsState $ itemToFull iid
factionD <- getsState sfactionD
let (name, powers) =
partItem (bfid b) factionD localTime itemFull kit
t = makePhrase [MU.Car1Ws k name, powers]
return (textToAL $ "Item:" <+> trimTgtDesc (widthTgt - 6) t, "")
| otherwise =
return (xhairBlurb, pathCsr)
(xhairLine, pathXhairOrNull) <- tgtOrItem
damageStatus <- maybe (return []) (drawLeaderDamage widthTgt) mleader
let damageStatusWidth = length damageStatus
withForLeader = widthTgt - damageStatusWidth - 1
leaderBottom =
if | T.length leaderBlurbShort > withForLeader -> ""
| T.length leaderBlurbLong > withForLeader -> leaderBlurbShort
| otherwise -> leaderBlurbLong
damageGap = emptyAttrLine
$ widthTgt - damageStatusWidth - T.length leaderBottom
xhairGap = emptyAttrLine (widthTgt - T.length pathXhairOrNull
- length xhairLine)
xhairStatus = xhairLine ++ xhairGap ++ textToAL pathXhairOrNull
selectedGap = emptyAttrLine (widthStatus - leaderStatusWidth
- selectedStatusWidth
- length speedStatus)
status = arenaStatus
<+:> xhairStatus
<> selectedStatus ++ selectedGap ++ speedStatus ++ leaderStatus
<+:> (textToAL leaderBottom ++ damageGap ++ damageStatus)
return
#ifdef WITH_EXPENSIVE_ASSERTIONS
$ assert (length status == 2 * _rXmax
`blame` map Color.charFromW32 status)
#endif
status
drawHudFrame :: MonadClientUI m => ColorMode -> LevelId -> m PreFrame
drawHudFrame dm drawnLevelId = do
baseTerrain <- drawFrameTerrain drawnLevelId
updContent <- drawFrameContent drawnLevelId
updPath <- drawFramePath drawnLevelId
updActor <- drawFrameActor drawnLevelId
updExtra <- drawFrameExtra dm drawnLevelId
let upd = FrameForall $ \v -> do
unFrameForall updContent v
unless (frontendName == "vty") $ unFrameForall updPath v
unFrameForall updActor v
unFrameForall updExtra v
return (baseTerrain, upd)
drawArenaStatus :: COps -> Level -> Int -> AttrLine
drawArenaStatus COps{cocave}
Level{lkind, ldepth=Dice.AbsDepth ld, lseen, lexpl}
width =
let ck = okind cocave lkind
seenN = 100 * lseen `div` max 1 lexpl
seenTxt | seenN >= 100 = "all"
| otherwise = T.justifyLeft 3 ' ' (tshow seenN <> "%")
lvlN = T.justifyLeft 2 ' ' (tshow ld)
seenStatus = "[" <> seenTxt <+> "seen]"
in textToAL $ T.justifyLeft width ' '
$ T.take 29 (lvlN <+> T.justifyLeft 26 ' ' (cname ck))
<+> seenStatus
drawLeaderStatus :: MonadClientUI m => Int -> m AttrLine
drawLeaderStatus waitT = do
time <- getsState stime
let calmHeaderText = "Calm"
hpHeaderText = "HP"
slashes = ["/", "|", "\\", "|"]
waitGlobal = timeFit time timeTurn
sUIOptions <- getsSession sUIOptions
mleader <- getsClient sleader
case mleader of
Just leader -> do
b <- getsState $ getActorBody leader
actorMaxSk <- getsState $ getActorMaxSkills leader
(hpCheckWarning, calmCheckWarning)
<- getsState $ checkWarnings sUIOptions leader
bdark <- getsState $ \s -> not (actorInAmbient b s)
let showTrunc x = let t = show x
in if length t > 3
then if x > 0 then "***" else "---"
else t
waitSlash | bwatch b == WSleep = waitGlobal
| otherwise = abs waitT
slashPick = slashes !! (max 0 waitSlash `mod` length slashes)
addColor c = map (Color.attrChar2ToW32 c)
checkDelta ResDelta{..}
| fst resCurrentTurn < 0 || fst resPreviousTurn < 0
= addColor Color.BrRed
| snd resCurrentTurn > 0 || snd resPreviousTurn > 0
= addColor Color.BrGreen
| otherwise = stringToAL
checkSleep body resDelta
| bwatch body == WSleep = addColor Color.Green
| otherwise = checkDelta resDelta
calmAddAttr = checkSleep b $ bcalmDelta b
darkPick | bdark = "."
| otherwise = ":"
calmHeader = calmAddAttr $ calmHeaderText <> darkPick
calmText = showTrunc (bcalm b `divUp` oneM)
<> (if bdark then slashPick else "/")
<> showTrunc (max 0 $ Ability.getSk Ability.SkMaxCalm
actorMaxSk)
bracePick | actorWaits b = "}"
| otherwise = ":"
hpAddAttr = checkDelta $ bhpDelta b
hpHeader = hpAddAttr $ hpHeaderText <> bracePick
hpText = showTrunc (bhp b `divUp` oneM)
<> (if not bdark then slashPick else "/")
<> showTrunc (max 0 $ Ability.getSk Ability.SkMaxHP
actorMaxSk)
justifyRight n t = replicate (n - length t) ' ' ++ t
colorWarning w = if w then addColor Color.Red else stringToAL
return $! calmHeader
<> colorWarning calmCheckWarning (justifyRight 7 calmText)
<+:> hpHeader
<> colorWarning hpCheckWarning (justifyRight 7 hpText)
Nothing -> do
let slashPick = slashes !! (max 0 waitGlobal `mod` length slashes)
return $! stringToAL (calmHeaderText ++ ": --" ++ slashPick ++ "--")
<+:> stringToAL (hpHeaderText <> ": --/--")
drawLeaderDamage :: MonadClientUI m => Int -> ActorId -> m AttrLine
drawLeaderDamage width leader = do
kitAssRaw <- getsState $ kitAssocs leader [CEqp, COrgan]
actorSk <- leaderSkillsClientUI
actorMaxSk <- getsState $ getActorMaxSkills leader
let hasTimeout itemFull =
let arItem = aspectRecordFull itemFull
timeout = IA.aTimeout arItem
in timeout > 0
hasEffect itemFull =
any IK.forApplyEffect $ IK.ieffects $ itemKind itemFull
ppDice :: (Int, ItemFullKit) -> [(Bool, AttrLine)]
ppDice (nch, (itemFull, (k, _))) =
let tdice = show $ IK.idamage $ itemKind itemFull
tdiceEffect = if hasEffect itemFull
then map Char.toUpper tdice
else tdice
in if hasTimeout itemFull
then replicate (k - nch)
(False, map (Color.attrChar2ToW32 Color.Cyan) tdiceEffect)
++ replicate nch
(True, map (Color.attrChar2ToW32 Color.BrCyan) tdiceEffect)
else [(True, map (Color.attrChar2ToW32 Color.BrBlue) tdiceEffect)]
lbonus :: AttrLine
lbonus =
let bonusRaw = Ability.getSk Ability.SkHurtMelee actorMaxSk
bonus = min 200 $ max (-200) bonusRaw
unknownBonus = unknownMeleeBonus $ map (fst . snd) kitAssRaw
tbonus = if bonus == 0
then if unknownBonus then "+?" else ""
else (if bonus > 0 then "+" else "")
<> show bonus
<> (if bonus /= bonusRaw then "$" else "")
<> if unknownBonus then "%?" else "%"
conditionBonus = conditionMeleeBonus $ map snd kitAssRaw
cbonus = case compare conditionBonus 0 of
EQ -> Color.White
GT -> Color.Green
LT -> Color.Red
in map (Color.attrChar2ToW32 cbonus) tbonus
let kitAssOnlyWeapons =
filter (IA.checkFlag Ability.Meleeable
. aspectRecordFull . fst . snd) kitAssRaw
discoBenefit <- getsClient sdiscoBenefit
strongest <- map (second snd . snd) <$>
pickWeaponM True (Just discoBenefit) kitAssOnlyWeapons actorSk leader
let (lT, lRatherNoT) = span (hasTimeout . fst . snd) strongest
strongestToDisplay = lT ++ take 1 lRatherNoT
lToDisplay = concatMap ppDice strongestToDisplay
(ldischarged, lrest) = span (not . fst) lToDisplay
lWithBonus = case map snd lrest of
[] -> []
l1 : rest -> (l1 ++ lbonus) : rest
lFlat = intercalate [Color.spaceAttrW32]
$ map snd ldischarged ++ lWithBonus
lFits = if length lFlat > width
then take (width - 3) lFlat ++ stringToAL "..."
else lFlat
return $! lFits
drawSelected :: MonadClientUI m
=> LevelId -> Int -> ES.EnumSet ActorId -> m (Int, AttrLine)
drawSelected drawnLevelId width selected = do
mleader <- getsClient sleader
side <- getsClient sside
sactorUI <- getsSession sactorUI
ours <- getsState $ filter (not . bproj . snd)
. inline actorAssocs (== side) drawnLevelId
let oursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) ours
viewOurs (aid, Actor{bhp, bwatch}, ActorUI{bsymbol, bcolor}) =
let bg = if | mleader == Just aid -> Color.HighlightYellow
| bwatch == WSleep -> Color.HighlightGreen
| ES.member aid selected -> Color.HighlightBlue
| otherwise -> Color.HighlightNone
sattr = Color.Attr {Color.fg = bcolor, bg}
in Color.attrCharToW32 $ Color.AttrChar sattr
$ if bhp > 0 then bsymbol else '%'
maxViewed = width - 2
len = length oursUI
star = let fg = case ES.size selected of
0 -> Color.BrBlack
n | n == len -> Color.BrWhite
_ -> Color.defFG
char = if len > maxViewed then '$' else '*'
in Color.attrChar2ToW32 fg char
viewed = map viewOurs $ take maxViewed
$ sortOn keySelected oursUI
return (min width (len + 2), [star] ++ viewed ++ [Color.spaceAttrW32])
checkWarningHP :: UIOptions -> ActorId -> Int64 -> State -> Bool
checkWarningHP UIOptions{uhpWarningPercent} leader hp s =
let actorMaxSk = getActorMaxSkills leader s
maxHp = Ability.getSk Ability.SkMaxHP actorMaxSk
in hp <= xM (uhpWarningPercent * maxHp `div` 100)
checkWarningCalm :: UIOptions -> ActorId -> Int64 -> State -> Bool
checkWarningCalm UIOptions{uhpWarningPercent} leader calm s =
let b = getActorBody leader s
actorMaxSk = getActorMaxSkills leader s
isImpression iid =
maybe False (> 0) $ lookup "impressed" $ IK.ifreq $ getIidKind iid s
isImpressed = any isImpression $ EM.keys $ borgan b
maxCalm = Ability.getSk Ability.SkMaxCalm actorMaxSk
in calm <= xM (uhpWarningPercent * maxCalm `div` 100)
&& isImpressed
checkWarnings :: UIOptions -> ActorId -> State -> (Bool, Bool)
checkWarnings uiOptions leader s =
let b = getActorBody leader s
in ( checkWarningHP uiOptions leader (bhp b) s
, checkWarningCalm uiOptions leader (bcalm b) s )