-- {-# OPTIONS_GHC -fprof-auto #-} -- | Display game data on the screen using one of the available frontends -- (determined at compile time with cabal flags). module Game.LambdaHack.Client.UI.DrawM ( targetDescLeader, drawBaseFrame #ifdef EXPOSE_INTERNAL -- * Internal operations , targetDesc, targetDescXhair, drawFrameTerrain, drawFrameContent , drawFramePath, drawFrameActor, drawFrameExtra, drawFrameStatus , drawArenaStatus, drawLeaderStatus, drawLeaderDamage, drawSelected #endif ) where import Prelude () import Game.LambdaHack.Common.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.Ord 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) import Game.LambdaHack.Client.UI.UIOptions import GHC.Exts (inline) import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Client.Bfs import Game.LambdaHack.Client.BfsM import Game.LambdaHack.Client.CommonM import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI.ActorUI import Game.LambdaHack.Client.UI.Frame 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.Common.Actor import Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.ContentData import qualified Game.LambdaHack.Common.Dice as Dice 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.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.TileKind (TileKind, isUknownSpace) import qualified Game.LambdaHack.Content.TileKind as TK targetDesc :: MonadClientUI m => Maybe Target -> m (Maybe Text, Maybe Text) targetDesc mtarget = do arena <- getArenaUI lidV <- viewedLevelUI mleader <- getsClient sleader case mtarget of Just (TEnemy aid _) -> do side <- getsClient sside b <- getsState $ getActorBody aid bUI <- getsSession $ getActorUI aid ar <- getsState $ getActorAspect aid let percentage = 100 * bhp b `div` xM (max 5 $ IA.aMaxHP ar) 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) 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 -- the other goals can be invalidated by now anyway and it's -- better to say what there is rather than what there isn't 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, stats) = partItem side factionD localTime itemFull kit return $! makePhrase $ if k == 1 then [name, stats] -- "a sword" too wordy else [MU.CarWs k name, stats] _ -> return $! "many items at" <+> tshow p else return $! "an exact spot on level" <+> tshow (abs $ fromEnum lid) return (Just pointedText, Nothing) Just target@TVector{} -> case mleader of Nothing -> return (Just "a relative shift", Nothing) Just aid -> do tgtPos <- getsState $ aidTgtToPos aid lidV target let invalidMsg = "an invalid relative shift" validMsg p = "shift to" <+> tshow p return (Just $ maybe invalidMsg validMsg tgtPos, Nothing) Nothing -> return (Nothing, Nothing) targetDescLeader :: MonadClientUI m => ActorId -> m (Maybe Text, Maybe Text) targetDescLeader leader = do tgt <- getsClient $ getTarget leader targetDesc tgt targetDescXhair :: MonadClientUI m => m (Text, Maybe Text) targetDescXhair = do sxhair <- getsSession sxhair first fromJust <$> targetDesc (Just sxhair) drawFrameTerrain :: forall m. MonadClientUI m => LevelId -> m FrameForall drawFrameTerrain drawnLevelId = do COps{coTileSpeedup, cotile} <- getsState scops StateClient{smarkSuspect} <- getClient Level{lxsize, ltile=PointArray.Array{avector}} <- getLevel drawnLevelId totVisible <- totalVisible <$> getPerFid drawnLevelId let dis :: Int -> ContentId TileKind -> Color.AttrCharW32 {-# INLINE dis #-} dis pI tile = case okind cotile tile of TK.TileKind{tsymbol, tcolor, tcolor2} -> -- Passing @p0@ as arg in place of @pI@ is much more costly. let p0 :: Point {-# INLINE p0 #-} p0 = PointArray.punindex lxsize pI -- @smarkSuspect@ can be turned off easily, so let's overlay it -- over both visible and remembered tiles. fg :: Color.Color {-# INLINE fg #-} fg | smarkSuspect > 0 && Tile.isSuspect coTileSpeedup tile = Color.BrMagenta | smarkSuspect > 1 && Tile.isHideAs coTileSpeedup tile = Color.Magenta | ES.member p0 totVisible = tcolor | otherwise = tcolor2 in Color.attrChar2ToW32 fg tsymbol mapVT :: forall s. (Int -> ContentId TileKind -> Color.AttrCharW32) -> FrameST s {-# INLINE mapVT #-} mapVT f v = do let g :: Int -> Word16 -> ST s () g !pI !tile = do let w = Color.attrCharW32 $ f pI (ContentId tile) VM.write v (pI + lxsize) w U.imapM_ g avector upd :: FrameForall upd = FrameForall $ \v -> mapVT dis v -- should be eta-expanded; lazy return upd drawFrameContent :: forall m. MonadClientUI m => LevelId -> m FrameForall drawFrameContent drawnLevelId = do SessionUI{smarkSmell} <- getSession Level{lxsize, 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 :: Point -> Time -> Color.AttrCharW32 {-# INLINE viewSmell #-} viewSmell p0 sml = let fg = toEnum $ fromEnum p0 `rem` 14 + 1 smlt = sml `timeDeltaToFrom` ltime in Color.attrChar2ToW32 fg (timeDeltaToDigit smellTimeout smlt) mapVAL :: forall a s. (Point -> a -> Color.AttrCharW32) -> [(Point, a)] -> FrameST s {-# INLINE mapVAL #-} mapVAL f l v = do let g :: (Point, a) -> ST s () g (!p0, !a0) = do let pI = PointArray.pindex lxsize p0 w = Color.attrCharW32 $ f p0 a0 VM.write v (pI + lxsize) w mapM_ g l upd :: FrameForall upd = FrameForall $ \v -> do mapVAL viewItemBag (EM.assocs lfloor) v when smarkSmell $ mapVAL viewSmell (filter ((> ltime) . snd) $ EM.assocs 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{coTileSpeedup} <- getsState scops StateClient{seps} <- getClient Level{lxsize, lysize, ltile=PointArray.Array{avector}} <- getLevel drawnLevelId totVisible <- totalVisible <$> getPerFid drawnLevelId mleader <- getsClient sleader xhairPosRaw <- xhairToPos let xhairPos = fromMaybe originPoint xhairPosRaw s <- getState bline <- case mleader of Just leader -> do Actor{bpos, blid} <- getsState $ getActorBody leader return $! if blid /= drawnLevelId then [] else fromMaybe [] $ bla lxsize lysize seps bpos xhairPos _ -> return [] mpath <- maybe (return Nothing) (\aid -> Just <$> do mtgtMPath <- getsClient $ EM.lookup aid . stargetD case mtgtMPath of Just TgtAndPath{tapPath=tapPath@AndPath{pathGoal}} | pathGoal == xhairPos -> return tapPath _ -> getCachePath aid xhairPos) mleader let lpath = if null bline then [] else maybe [] (\case NoPath -> [] AndPath {pathList} -> pathList) mpath xhairHere = find (\(_, m) -> xhairPos == bpos m) (inline actorAssocs (const True) drawnLevelId s) shiftedBTrajectory = case xhairHere of Just (_, 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.BrRed (False, True) -> Color.Green (False, False) -> Color.Red 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 = PointArray.pindex lxsize p0 tile = avector U.! pI w = Color.attrCharW32 $ f p0 (ContentId tile) VM.write v (pI + lxsize) w mapM_ g l upd :: FrameForall upd = FrameForall $ \v -> do mapVTL (acOnPathOrLine ';') lpath v mapVTL (acOnPathOrLine '*') shiftedLine v -- overwrites path return upd drawFrameActor :: forall m. MonadClientUI m => LevelId -> m FrameForall drawFrameActor drawnLevelId = do SessionUI{sselected} <- getSession Level{lxsize, lactor} <- getLevel drawnLevelId side <- getsClient sside mleader <- getsClient sleader s <- getState sactorUI <- getsSession sactorUI let {-# INLINE viewActor #-} viewActor _ as = case as of aid : _ -> let Actor{bhp, bproj, bfid, btrunk} = getActorBody aid s ActorUI{bsymbol, bcolor} = sactorUI EM.! aid Item{jfid} = getItemBody btrunk s symbol | bhp > 0 || bproj = bsymbol | otherwise = '%' dominated = maybe False (/= bfid) jfid bg = if bproj then Color.HighlightNone else case mleader of Just leader | aid == leader -> Color.HighlightRed _ -> if | aid `ES.member` sselected -> Color.HighlightBlue | dominated -> if bfid == side -- dominated by us then Color.HighlightWhite else Color.HighlightMagenta | otherwise -> Color.HighlightNone in Color.attrCharToW32 $ Color.AttrChar Color.Attr{fg=bcolor, bg} symbol [] -> error $ "lactor not sparse" `showFailure` () mapVAL :: forall a s. (Point -> a -> Color.AttrCharW32) -> [(Point, a)] -> FrameST s {-# INLINE mapVAL #-} mapVAL f l v = do let g :: (Point, a) -> ST s () g (!p0, !a0) = do let pI = PointArray.pindex lxsize p0 w = Color.attrCharW32 $ f p0 a0 VM.write v (pI + lxsize) w mapM_ g l upd :: FrameForall upd = FrameForall $ \v -> mapVAL viewActor (EM.assocs lactor) v return upd drawFrameExtra :: forall m. MonadClientUI m => ColorMode -> LevelId -> m FrameForall drawFrameExtra dm drawnLevelId = do SessionUI{saimMode, smarkVision} <- getSession Level{lxsize, lysize} <- getLevel drawnLevelId totVisible <- totalVisible <$> getPerFid drawnLevelId mxhairPos <- xhairToPos mtgtPos <- do mleader <- getsClient sleader case mleader of Nothing -> return Nothing Just leader -> do mtgt <- getsClient $ getTarget leader case mtgt of Nothing -> return Nothing Just tgt -> getsState $ aidTgtToPos leader drawnLevelId tgt let visionMarks = if smarkVision then map (PointArray.pindex lxsize) $ ES.toList 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.HighlightRed = 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) -> [Int] -> FrameST s mapVL f l v = do let g :: Int -> ST s () g !pI = do w0 <- VM.read v (pI + lxsize) let w = Color.attrCharW32 . Color.attrCharToW32 . f . Color.attrCharFromW32 . Color.AttrCharW32 $ w0 VM.write v (pI + lxsize) w mapM_ g l lDungeon = [0..lxsize * lysize - 1] upd :: FrameForall upd = FrameForall $ \v -> do when (isJust saimMode) $ mapVL backlightVision visionMarks v case mtgtPos of Nothing -> return () Just p -> mapVL (writeSquare Color.HighlightGrey) [PointArray.pindex lxsize p] v case mxhairPos of -- overwrites target Nothing -> return () Just p -> mapVL (writeSquare Color.HighlightYellow) [PointArray.pindex lxsize p] v when (dm == ColorBW) $ mapVL turnBW lDungeon v return upd drawFrameStatus :: MonadClientUI m => LevelId -> m AttrLine drawFrameStatus drawnLevelId = do cops <- getsState scops SessionUI{sselected, saimMode, swaitTimes, sitemSel} <- getSession mleader <- getsClient sleader xhairPos <- xhairToPos tgtPos <- leaderTgtToPos mbfs <- maybe (return Nothing) (\aid -> Just <$> getCacheBfs aid) mleader (mtgtDesc, mtargetHP) <- maybe (return (Nothing, Nothing)) targetDescLeader mleader (xhairDesc, mxhairHP) <- targetDescXhair lvl <- getLevel drawnLevelId (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 widthStats = widthX - widthTgt - 1 arenaStatus = drawArenaStatus cops lvl widthStats displayPathText mp mt = let (plen, llen) = case (mp, mbfs, mbpos) of (Just target, Just bfs, Just bpos) | mblid == Just drawnLevelId -> (fromMaybe 0 (accessBfs bfs target), chessDist bpos target) _ -> (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 -- The indicators must fit, they are the actual information. pathCsr = displayPathText xhairPos mxhairHP trimTgtDesc n t = assert (not (T.null t) && n > 2 `blame` (t, n)) $ if T.length t <= n then t else let ellipsis = "..." fitsPlusOne = T.take (n - T.length ellipsis + 1) t fits = if T.last fitsPlusOne == ' ' then T.init fitsPlusOne else let lw = T.words fitsPlusOne in T.unwords $ init lw in fits <> ellipsis xhairText = let n = widthTgt - T.length pathCsr - 8 in (if isJust saimMode then "x-hair>" else "X-hair:") <+> trimTgtDesc n xhairDesc xhairGap = emptyAttrLine (widthTgt - T.length pathCsr - T.length xhairText) xhairStatus = textToAL xhairText ++ xhairGap ++ textToAL pathCsr leaderStatusWidth = 23 leaderStatus <- drawLeaderStatus swaitTimes (selectedStatusWidth, selectedStatus) <- drawSelected drawnLevelId (widthStats - leaderStatusWidth) sselected damageStatus <- drawLeaderDamage (widthStats - leaderStatusWidth - selectedStatusWidth) side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD let statusGap = emptyAttrLine (widthStats - leaderStatusWidth - selectedStatusWidth - length damageStatus) tgtOrItem n = do let fallback = if MK.fleaderMode (gplayer fact) == MK.LeaderNull then "This faction never picks a leader" else "Waiting for a team member to spawn" leaderName = maybe fallback (\body -> "Leader:" <+> trimTgtDesc n (bname body)) mbodyUI tgtBlurb = maybe leaderName (\t -> "Target:" <+> trimTgtDesc n t) mtgtDesc case (sitemSel, mleader) of (Just (iid, fromCStore, _), Just leader) -> do b <- getsState $ getActorBody leader bag <- getsState $ getBodyStoreBag b fromCStore case iid `EM.lookup` bag of Nothing -> return $! tgtBlurb Just kit@(k, _) -> do localTime <- getsState $ getLocalTime (blid b) itemFull <- getsState $ itemToFull iid factionD <- getsState sfactionD let (_, _, name, stats) = partItem (bfid b) factionD localTime itemFull kit t = makePhrase $ if k == 1 then [name, stats] -- "a sword" too wordy else [MU.CarWs k name, stats] return $! "Item:" <+> trimTgtDesc n t _ -> return $! tgtBlurb -- The indicators must fit, they are the actual information. pathTgt = displayPathText tgtPos mtargetHP targetText <- tgtOrItem $ widthTgt - T.length pathTgt - 8 let targetGap = emptyAttrLine (widthTgt - T.length pathTgt - T.length targetText) targetStatus = textToAL targetText ++ targetGap ++ textToAL pathTgt return $! arenaStatus <+:> xhairStatus <> selectedStatus ++ statusGap ++ damageStatus ++ leaderStatus <+:> targetStatus -- | Draw the whole screen: level map and status area. drawBaseFrame :: MonadClientUI m => ColorMode -> LevelId -> m FrameForall drawBaseFrame dm drawnLevelId = do Level{lxsize, lysize} <- getLevel drawnLevelId updTerrain <- drawFrameTerrain drawnLevelId updContent <- drawFrameContent drawnLevelId updPath <- drawFramePath drawnLevelId updActor <- drawFrameActor drawnLevelId updExtra <- drawFrameExtra dm drawnLevelId frameStatus <- drawFrameStatus drawnLevelId let !_A = assert (length frameStatus == 2 * lxsize `blame` map Color.charFromW32 frameStatus) () upd = FrameForall $ \v -> do unFrameForall updTerrain v unFrameForall updContent v unFrameForall updPath v unFrameForall updActor v unFrameForall updExtra v unFrameForall (writeLine (lxsize * (lysize + 1)) frameStatus) v return upd -- Comfortably accomodates 3-digit level numbers and 25-character -- level descriptions (currently enforced max). 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 let calmHeaderText = "Calm" hpHeaderText = "HP" UIOptions{uhpWarningPercent} <- getsSession sUIOptions mleader <- getsClient sleader case mleader of Just leader -> do ar <- getsState $ getActorAspect leader s <- getState let showTrunc x = let t = show x in if length t > 3 then if x > 0 then "***" else "---" else t (bhpM, darkL, bracedL, hpDelta, calmDelta, ahpS, bhpS, acalmS, bcalmS) = let b@Actor{bhp, bcalm} = getActorBody leader s in ( bhp, not (actorInAmbient b s) , braced b, bhpDelta b, bcalmDelta b , showTrunc $ max 0 $ IA.aMaxHP ar , showTrunc (bhp `divUp` oneM) , showTrunc $ max 0 $ IA.aMaxCalm ar , showTrunc (bcalm `divUp` oneM)) -- This is a valuable feedback for the otherwise hard to observe -- 'wait' command. slashes = ["/", "|", "\\", "|"] slashPick = slashes !! (max 0 waitT `mod` length slashes) addColor c = map (Color.attrChar2ToW32 c) checkDelta ResDelta{..} | fst resCurrentTurn < 0 || fst resPreviousTurn < 0 = addColor Color.BrRed -- alarming news have priority | snd resCurrentTurn > 0 || snd resPreviousTurn > 0 = addColor Color.BrGreen | otherwise = stringToAL -- only if nothing at all noteworthy checkWarning = if bhpM <= xM (uhpWarningPercent * IA.aMaxHP ar `div` 100) then addColor Color.Red else stringToAL calmAddAttr = checkDelta calmDelta -- We only show ambient light, because in fact client can't tell -- if a tile is lit, because it it's seen it may be due to ambient -- or dynamic light or due to infravision. darkPick | darkL = "." | otherwise = ":" calmHeader = calmAddAttr $ calmHeaderText <> darkPick calmText = bcalmS <> (if darkL || not bracedL then slashPick else "/") <> acalmS bracePick | bracedL = "}" | otherwise = ":" hpAddAttr = checkDelta hpDelta hpHeader = hpAddAttr $ hpHeaderText <> bracePick hpText = bhpS <> (if bracedL || not darkL then slashPick else "/") <> ahpS justifyRight n t = replicate (n - length t) ' ' ++ t return $! calmHeader <> stringToAL (justifyRight 7 calmText) <+:> hpHeader <> checkWarning (justifyRight 7 hpText) Nothing -> return $! stringToAL (calmHeaderText ++ ": --/--") <+:> stringToAL (hpHeaderText <> ": --/--") drawLeaderDamage :: MonadClientUI m => Int -> m AttrLine drawLeaderDamage width = do mleader <- getsClient sleader (tdice, tbonus, cbonus) <- case mleader of Just leader -> do kitAssRaw <- getsState $ kitAssocs leader [CEqp, COrgan] actorSk <- leaderSkillsClientUI actorAspect <- getsState sactorAspect let kitAssOnlyWeapons = filter (IK.isMelee . itemKind . fst . snd) kitAssRaw strongest <- pickWeaponM Nothing kitAssOnlyWeapons actorSk leader let damage = case strongest of [] -> ("0", "", Color.White) (_, (_, (itemFull, _))) : _ -> let tdice = show $ IK.idamage $ itemKind itemFull bonusRaw = IA.aHurtMelee $ actorAspect EM.! leader 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 "%" tmpBonus = tmpMeleeBonus $ map snd kitAssRaw cbonus = case compare tmpBonus 0 of EQ -> Color.White GT -> Color.Green LT -> Color.Red in (tdice, tbonus, cbonus) return $! damage Nothing -> return ("", "", Color.White) let addColorDice = map (Color.attrChar2ToW32 Color.BrCyan) addColorBonus = map (Color.attrChar2ToW32 cbonus) return $! if null tdice || length tdice + length tbonus >= width then [] else addColorDice tdice ++ addColorBonus tbonus ++ [Color.spaceAttrW32] 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}, ActorUI{bsymbol, bcolor}) = let bg = if | mleader == Just aid -> Color.HighlightRed | 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 $ sortBy (comparing keySelected) oursUI return (min width (len + 2), [star] ++ viewed ++ [Color.spaceAttrW32])