-- {-# 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
  ( targetDesc, targetDescXhair, drawHudFrame
  , checkWarningHP, checkWarningCalm
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , 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.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.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.FactionKind as FK
import qualified Game.LambdaHack.Content.ItemKind as IK
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
import qualified Game.LambdaHack.Definition.DefsInternal as DefsInternal

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 (4 - n) "_"
                        <> T.replicate 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  -- 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 $! "spot" <+> tshow p
              [(iid, kit@(k, _))] -> do
                localTime <- getsState $ getLocalTime lid
                itemFull <- getsState $ itemToFull iid
                side <- getsClient sside
                factionD <- getsState sfactionD
                CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui
                let (name, powers) =
                      partItem rwidth 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{} -> do
      mtgtPos <- getsState $ aidTgtToPos mleader lidV mtarget
      let invalidMsg = "a relative shift"
          validMsg p = "shift to" <+> tshow p
      return (Just $ maybe invalidMsg validMsg mtgtPos, Nothing)
    Nothing -> return (Nothing, Nothing)

targetDescXhair :: MonadClientUI m
                => m (Maybe Text, Maybe Text, Maybe Watchfulness)
targetDescXhair = do
  sxhair <- getsSession sxhair
  (mhairDesc, mxhairHP) <- targetDesc sxhair
  let maid = case sxhair of
        Just (TEnemy a) -> Just a
        Just (TNonEnemy a) -> Just a
        _ -> Nothing
  case maid of
    Nothing -> return (mhairDesc, mxhairHP, Nothing)
    Just aid -> do
      watchfulness <- bwatch <$> getsState (getActorBody aid)
      return (mhairDesc, mxhairHP, Just watchfulness)

drawFrameTerrain :: forall m. MonadClientUI m => LevelId -> m (U.Vector Word32)
drawFrameTerrain drawnLevelId = do
  COps{corule=RuleContent{rWidthMax}, cotile, coTileSpeedup} <- getsState scops
  StateClient{smarkSuspect} <- getClient
  -- Not @ScreenContent@, because indexing in level's data.
  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
            -- @smarkSuspect@ can be turned off easily, so let's overlay it
            -- over both visible and remembered tiles.
            fg :: Color.Color
            fg | smarkSuspect > 0
                 && Tile.isSuspect coTileSpeedup tile = Color.BrMagenta
               | smarkSuspect > 1
                 && Tile.isHideAs coTileSpeedup tile = Color.Magenta
               | -- Converting maps is cheaper than converting points
                 -- and this function is a bottleneck, so we hack a bit.
                 pI `IS.member` ES.enumSetToIntSet totVisible
                 -- If all embeds spent, mark it with darker colour.
                 && 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 (DefsInternal.toContentId tile)
      caveVector :: U.Vector Word32
      caveVector = U.imap g avector
      messageVector =
        U.replicate rWidthMax (Color.attrCharW32 Color.spaceAttrW32)
      statusVector = U.fromListN (2 * rWidthMax) $ map Color.attrCharW32 frameStatus
  -- The vector package is so smart that the 3 vectors are not allocated
  -- separately at all, but written to the big vector at once.
  -- But even with double allocation it would be faster than writing
  -- to a mutable vector via @FrameForall@.
  return $ U.concat [messageVector, caveVector, statusVector]

drawFrameContent :: forall m. MonadClientUI m => LevelId -> m FrameForall
drawFrameContent drawnLevelId = do
  COps{corule=RuleContent{rWidthMax}} <- getsState scops
  SessionUI{smarkSmell} <- getSession
  -- Not @ScreenContent@, because indexing in level's data.
  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 + rWidthMax) w
        mapM_ g l
      -- We don't usually show embedded items, because normally we don't
      -- want them to clutter the display. If they are really important,
      -- the tile they reside on has special colours and changes as soon
      -- as the item disappears. In the remaining cases, the main menu
      -- UI setting for suspect terrain highlights most tiles with embeds.
      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, FrameForall)
drawFramePath drawnLevelId = do
 SessionUI{saimMode} <- getSession
 sreportNull <- getsSession sreportNull
 let frameForallId = FrameForall $ const $ return ()
 case saimMode of
   Just AimMode{detailLevel} | not sreportNull
                               && detailLevel /= DetailHigh
                               && detailLevel /= DetailLow -> do
     COps{corule=RuleContent{rWidthMax, rHeightMax}, coTileSpeedup}
       <- getsState scops
     StateClient{seps} <- getClient
     -- Not @ScreenContent@, because pathing in level's map.
     Level{ltile=PointArray.Array{avector}} <- getLevel drawnLevelId
     totVisible <- totalVisible <$> getPerFid drawnLevelId
     mleader <- getsClient sleader
     xhairPos <- xhairToPos
     bline <- case mleader of
       Just leader -> do
         Actor{bpos, blid} <- getsState $ getActorBody leader
         return $! if blid /= drawnLevelId
                   then []
                   else fromMaybe []
                        $ bresenhamsLineAlgorithm 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 shiftedBTrajectory = case assocsAtxhair of
           (_, Actor{btrajectory = Just p, bpos = prPos}) : _
             | detailLevel == defaultDetailLevel ->
               trajectoryToPath prPos (fst p)
           _ -> []
         shiftedLine =
           delete xhairPos
           $ takeWhile (insideP (0, 0, rWidthMax - 1, rHeightMax - 1))
           $ if null shiftedBTrajectory
             then bline
             else shiftedBTrajectory
         lpath = if not (null bline) && null shiftedBTrajectory
                 then delete xhairPos $ maybe [] pathList mpath
                 else []
         acOnPathOrLine :: 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 = fromEnum p0
                     tile = avector U.! pI
                     w = Color.attrCharW32
                         $ f p0 (DefsInternal.toContentId tile)
                 VM.write v (pI + rWidthMax) w
           mapM_ g l
         upd :: FrameForall
         upd = FrameForall $ \v -> do
           mapVTL (acOnPathOrLine ';') lpath v
           mapVTL (acOnPathOrLine '*') shiftedLine v  -- overwrites path
     return (upd, if null shiftedBTrajectory then frameForallId else upd)
   _ -> return (frameForallId, frameForallId)

drawFrameActor :: forall m. MonadClientUI m => LevelId -> m FrameForall
drawFrameActor drawnLevelId = do
  COps{corule=RuleContent{rWidthMax}} <- getsState scops
  SessionUI{sactorUI, sselected, sUIOptions} <- getSession
  -- Not @ScreenContent@, because indexing in level's data.
  Level{lbig, lproj} <- getLevel drawnLevelId
  side <- getsClient sside
  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
              bg = if | bwatch == WSleep -> Color.HighlightBlue
                      | dominated -> if bfid == side  -- dominated by us
                                     then Color.HighlightCyan
                                     else Color.HighlightBrown
                      | ES.member aid sselected -> Color.HighlightGreen
                      | 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 + rWidthMax) 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
          -- big actor overlay projectiles
  return upd

drawFrameExtra :: forall m. MonadClientUI m
               => ColorMode -> LevelId -> m FrameForall
drawFrameExtra dm drawnLevelId = do
  -- Not @ScreenContent@, because indexing in level's data.
  COps{corule=RuleContent{rWidthMax, rHeightMax}} <- getsState scops
  SessionUI{saimMode, smarkVision} <- getSession
  mleader <- getsClient sleader
  mbody <- getsState $ \s -> flip getActorBody s <$> mleader
  totVisible <- totalVisible <$> getPerFid drawnLevelId
  mxhairPos <- mxhairToPos
  mtgtPos <- do
    mtgt <- getsClient $ maybe (const Nothing) getTarget mleader
    getsState $ aidTgtToPos mleader drawnLevelId mtgt
  side <- getsClient sside
  factionD <- getsState sfactionD
  let visionMarks = IS.toList $ ES.enumSetToIntSet totVisible
      backlightVision :: Color.AttrChar -> Color.AttrChar
      backlightVision ac = case ac of
        Color.AttrChar (Color.Attr fg Color.HighlightNone) ch ->
          Color.AttrChar (Color.Attr fg Color.HighlightBackground) ch
        _ -> ac
      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 + rWidthMax)
              let w = Color.attrCharW32 . Color.attrCharToW32
                      . f . Color.attrCharFromW32 . Color.AttrCharW32 $ w0
              VM.write v (pI + rWidthMax) w
        mapM_ g l
      -- Here @rWidthMax@ and @rHeightMax@ are correct, because we are not
      -- turning the whole screen into black&white, but only the level map.
      lDungeon = [0..rWidthMax * rHeightMax - 1]
      leaderColor = if isJust saimMode
                    then Color.HighlightYellowAim
                    else Color.HighlightYellow
      xhairColor = if isJust saimMode
                   then Color.HighlightRedAim
                   else Color.HighlightRed
      locateStash (fid, fact) = case gstash fact of
        Just (lid, pos) | lid == drawnLevelId ->
          let stashColor = if fid == side
                           then Color.HighlightWhite
                           else Color.HighlightMagenta
          in Just (pos, stashColor)
        _ -> Nothing
      stashesToDisplay = mapMaybe locateStash $ EM.assocs factionD
      upd :: FrameForall
      upd = FrameForall $ \v -> do
        when (isJust saimMode && smarkVision >= 1 || smarkVision == 2) $
          mapVL backlightVision visionMarks v
        case mtgtPos of
          Nothing -> return ()
          Just p -> mapVL (writeSquare Color.HighlightGrey) [fromEnum p] v
        mapM_ (\(pos, color) -> mapVL (writeSquare color) [fromEnum pos] v)
              stashesToDisplay
        case mbody of  -- overwrites target
          Just body | drawnLevelId == blid body ->
            mapVL (writeSquare leaderColor) [fromEnum $ bpos body] v
          _ -> return ()
        case mxhairPos of  -- overwrites target and non-aim leader box
          Nothing -> return ()
          Just p -> mapVL (writeSquare xhairColor) [fromEnum p] v
        when (dm == ColorBW) $ mapVL turnBW lDungeon v
  return upd

drawFrameStatus :: MonadClientUI m => LevelId -> m AttrString
drawFrameStatus drawnLevelId = do
  cops@COps{corule=RuleContent{rWidthMax=_rWidthMax}} <- getsState scops
  SessionUI{sselected, saimMode, swaitTimes, sitemSel} <- getSession
  mleader <- getsClient sleader
  mxhairPos <- mxhairToPos
  mbfs <- maybe (return Nothing) (fmap Just . getCacheBfs) mleader
  (mhairDesc, mxhairHP, mxhairWatchfulness) <- 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
      actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
      kitAssRaw <- getsState $ kitAssocs leader [CEqp, COrgan]
      let speed = Ability.getSk Ability.SkSpeed actorCurAndMaxSk
          unknownBonus = unknownSpeedBonus $ map (fst . snd) kitAssRaw
          speedString = displaySpeed speed ++ if unknownBonus then "?" else ""
          conditionBonus = conditionSpeedBonus $ map snd kitAssRaw
          cspeed = case compare conditionBonus 0 of
            LT -> Color.Red
            EQ -> Color.White
            GT -> Color.Green
      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
      -- The indicators must fit, they are the actual information.
      pathCsr = displayPathText mxhairPos mxhairHP
      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 <> "..."
      -- The indicators must fit, they are the actual information.
      widthXhairOrItem = widthTgt - T.length pathCsr
      nMember = MU.Ord $ 1 + sum (EM.elems $ gvictims fact)
      fallback = if FK.fhasPointman (gkind fact)
                 then makePhrase
                        ["Waiting for", nMember, "team member to spawn"]
                 else "This faction never picks a pointman"
      leaderName bUI = trimTgtDesc (widthTgt - 10) (bname bUI)
      leaderBlurbLong = maybe fallback (\bUI ->
        "Pointman:" <+> leaderName bUI) mbodyUI
      leaderBlurbShort = maybe fallback leaderName mbodyUI
  ours <- getsState $ fidActorNotProjGlobalAssocs side
  ns <- getsState $ EM.size . getFactionStashBag side
  let na = length ours
      nl = ES.size $ ES.fromList $ map (blid . snd) ours
      -- To be replaced by something more useful.
      teamBlurb = textToAS $ trimTgtDesc widthTgt $
        makePhrase [ "Team:"
                   , MU.CarWs na "actor", "on"
                   , MU.CarWs nl "level" <> ","
                   , "stash", MU.Car ns ]
      markSleepTgtDesc
        | mxhairWatchfulness /= Just WSleep = textToAS
        | otherwise = textFgToAS Color.cSleep
      xdetail AimMode{detailLevel} =
        "x" <> tshow (1 + fromEnum detailLevel)
      xhairName aimMode = "Crosshair" <+> xdetail aimMode
      xhairBlurb =
        maybe
          teamBlurb
          (\t -> case saimMode of
             Just aimMode ->
               textToAS (xhairName aimMode <> ":")
               <+:> markSleepTgtDesc (trimTgtDesc (widthXhairOrItem - 14) t)
             Nothing -> 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
                CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui
                let (name, powers) =
                      partItem rwidth (bfid b) factionD localTime itemFull kit
                    t = makePhrase [MU.Car1Ws k name, powers]
                    xhairHP = maybe "" (" " <>) mxhairHP
                    (xItemWidth, xItemText) = case saimMode of
                      Just aimMode -> (9, "Item" <+> xdetail aimMode)
                      Nothing -> (6, "Item")
                    trimTD =
                      trimTgtDesc (widthTgt - T.length xhairHP - xItemWidth) t
                return (textToAS $ xItemText <> ":" <+> trimTD, xhairHP)
        | 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 = blankAttrString
                  $ widthTgt - damageStatusWidth - T.length leaderBottom
      xhairGap = blankAttrString (widthTgt - T.length pathXhairOrNull
                                         - length xhairLine)
      xhairStatus = xhairLine ++ xhairGap ++ textToAS pathXhairOrNull
      selectedGap = blankAttrString (widthStatus - leaderStatusWidth
                                               - selectedStatusWidth
                                               - length speedStatus)
      status = arenaStatus
               <> [Color.spaceAttrW32]
               <> xhairStatus
               <> selectedStatus ++ selectedGap ++ speedStatus ++ leaderStatus
               <> [Color.spaceAttrW32]
               <> (textToAS leaderBottom ++ damageGap ++ damageStatus)
  -- Keep it at least partially lazy, to avoid allocating the whole list:
  return
#ifdef WITH_EXPENSIVE_ASSERTIONS
    $ assert (length status == 2 * _rWidthMax
              `blame` attrStringToString status)
#endif
        status

-- | Draw the whole screen: level map and status area.
drawHudFrame :: MonadClientUI m => ColorMode -> LevelId -> m PreFrame
drawHudFrame dm drawnLevelId = do
  baseTerrain <- drawFrameTerrain drawnLevelId
  updContent <- drawFrameContent drawnLevelId
  (updPath, updTrajectory) <- drawFramePath drawnLevelId
  updActor <- drawFrameActor drawnLevelId
  updExtra <- drawFrameExtra dm drawnLevelId
  soptions <- getsClient soptions
  let upd = FrameForall $ \v -> do
        unFrameForall updContent v
        -- ANSI frontend is screen-reader friendly, so avoid visual fluff
        unless (frontendName soptions == "ANSI") $ unFrameForall updPath v
        unFrameForall updActor v
        unFrameForall updTrajectory v
        unFrameForall updExtra v
  return (baseTerrain, upd)

-- Comfortably accomodates 3-digit level numbers and 25-character
-- level descriptions (currently enforced max).
--
-- Sometimes the level seems fully explored, but the display shows
-- 99% or even goes from 100% to 99% at some moment.
-- This is due to monsters, e.g., clearning rubble or burning bush,
-- and so creating a new explorable terrain.
drawArenaStatus :: COps -> Level -> Int -> AttrString
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 = tshow seenN <> "%"
      lvlN = T.justifyLeft 2 ' ' (tshow ld)
      seenStatus = "[" <> seenTxt <+> "seen]"
  in textToAS $ T.take (width - 10)
                       (T.justifyLeft (width - 10) ' ' (lvlN <+> cname ck))
                <> T.justifyRight 10 ' ' seenStatus

drawLeaderStatus :: MonadClientUI m => Int -> m AttrString
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
      actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
      (hpCheckWarning, calmCheckWarning)
        <- getsState $ checkWarnings sUIOptions leader
      bdark <- getsState $ not . actorInAmbient b
      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
          -- This is a valuable feedback for the otherwise hard to observe
          -- 'wait' command or for passing of time when sole leader sleeps.
          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  -- alarming news have priority
            | snd resCurrentTurn > 0 || snd resPreviousTurn > 0
              = addColor Color.BrGreen
            | otherwise = stringToAS  -- only if nothing at all noteworthy
          checkSleep body resDelta
            | bwatch body == WSleep = addColor Color.cSleep
            | otherwise = checkDelta resDelta
          calmAddAttr = checkSleep b $ bcalmDelta b
          -- 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 | bdark = "."
                   | otherwise = ":"
          calmHeader = calmAddAttr $ calmHeaderText <> darkPick
          maxCalm = max 0 $ Ability.getSk Ability.SkMaxCalm actorCurAndMaxSk
          calmText = showTrunc (bcalm b `divUp` oneM)
                     <> (if bdark then slashPick else "/")
                     <> showTrunc maxCalm
          bracePick | actorWaits b = "}"
                    | otherwise = ":"
          hpAddAttr = checkDelta $ bhpDelta b
          hpHeader = hpAddAttr $ hpHeaderText <> bracePick
          maxHP = max 0 $ Ability.getSk Ability.SkMaxHP actorCurAndMaxSk
          hpText = showTrunc (bhp b `divUp` oneM)
                   <> (if not bdark then slashPick else "/")
                   <> showTrunc maxHP
          justifyRight n t = replicate (n - length t) ' ' ++ t
          colorWarning w enough full | w = addColor Color.Red
                                     | not enough = addColor Color.Brown
                                     | full = addColor Color.Magenta
                                     | otherwise = stringToAS
      return $! calmHeader
                <> colorWarning calmCheckWarning
                                (calmEnough b actorCurAndMaxSk)
                                (bcalm b > xM maxCalm)
                                (justifyRight 7 calmText)
                <+:> hpHeader
                <> colorWarning hpCheckWarning
                                True
                                (bhp b > xM maxHP)
                                (justifyRight 7 hpText)
    Nothing -> do
      -- This is a valuable feedback for passing of time while faction
      -- leaderless and especially while temporarily actor-less..
      let slashPick = slashes !! (max 0 waitGlobal `mod` length slashes)
      return $! stringToAS (calmHeaderText ++ ":  --" ++ slashPick ++ "--")
                <+:> stringToAS (hpHeaderText <> ":  --/--")

drawLeaderDamage :: MonadClientUI m => Int -> ActorId -> m AttrString
drawLeaderDamage width leader = do
  kitAssRaw <- getsState $ kitAssocs leader [CEqp, COrgan]
  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
  let unBurn (IK.Burn d) = Just d
      unBurn _ = Nothing
      unRefillHP (IK.RefillHP n) = Just n
      unRefillHP _ = Nothing
      hasNonDamagesEffect itemFull =
        any (\eff -> IK.forApplyEffect eff && not (IK.forDamageEffect eff))
            (IK.ieffects $ itemKind itemFull)
      ppDice :: Bool -> (Bool, Int, Int, ItemFullKit)
             -> [(Bool, (AttrString, AttrString))]
      ppDice showInBrief (hasEffect, timeout, ncha, (itemFull, (k, _))) =
        let dice = IK.idamage $ itemKind itemFull
            tdice = case Dice.reduceDice dice of
              Just d | showInBrief -> show d
              _ -> show dice
            -- We ignore nested effects because they are, in general, avoidable.
            -- We also ignore repeated effect kinds for HUD simplicity.
            tBurn = maybe "" (('+' :) . show)  $ listToMaybe $ mapMaybe unBurn
                                               $ IK.ieffects $ itemKind itemFull
            nRefillHP = maybe 0 (min 0) $ listToMaybe $ mapMaybe unRefillHP
                                        $ IK.ieffects $ itemKind itemFull
            tRefillHP | nRefillHP < 0 = '+' : show (- nRefillHP)
                      | otherwise = ""
            tdiceEffect = if hasEffect && hasNonDamagesEffect itemFull
                          then map Char.toUpper tdice
                          else tdice
            ldice color = map (Color.attrChar2ToW32 color) tdiceEffect
            lBurnHP charged =
              let cburn = if charged then Color.BrRed else Color.Red
                  chp = if charged then Color.BrMagenta else Color.Magenta
              in map (Color.attrChar2ToW32 cburn) tBurn
                 ++ map (Color.attrChar2ToW32 chp) tRefillHP
            possiblyHasTimeout = timeout > 0 || itemSuspect itemFull
        in if possiblyHasTimeout
           then replicate (k - ncha)
                          (False, (ldice Color.Cyan, lBurnHP False))
                ++ replicate ncha (True, (ldice Color.BrCyan, lBurnHP True))
           else [(True, (ldice Color.BrBlue, lBurnHP True))]
      lbonus :: AttrString
      lbonus =
        let bonusRaw = Ability.getSk Ability.SkHurtMelee actorCurAndMaxSk
            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
              LT -> Color.Red
              EQ -> Color.White
              GT -> Color.Green
        in map (Color.attrChar2ToW32 cbonus) tbonus
  let kitAssOnlyWeapons =
        filter (IA.checkFlag Ability.Meleeable
                . aspectRecordFull . fst . snd) kitAssRaw
  discoBenefit <- getsClient sdiscoBenefit
  strongest <-
    map (\(_, hasEffect, timeout, ncha, _, itemFullKit) ->
          (hasEffect, timeout, ncha, itemFullKit))
    <$> pickWeaponM True (Just discoBenefit) kitAssOnlyWeapons
                    actorCurAndMaxSk leader
  let possiblyHasTimeout (_, timeout, _, (itemFull, _)) =
        timeout > 0 || itemSuspect itemFull
      (lT, lTrest) = span possiblyHasTimeout strongest
      strongestToDisplay = lT ++ case lTrest of
        [] -> []
        noTimeout : lTrest2 -> noTimeout : filter possiblyHasTimeout lTrest2
          -- the second portion of timeout weapons won't ever be used
          -- but often it's the player's mistake, so show them anyway
      showStrongest showInBrief l =
        let lToDisplay = concatMap (ppDice showInBrief) l
            (ldischarged, lrest) = break fst lToDisplay
            lWithBonus = case map snd lrest of
              [] -> []  -- no timeout-free organ, e.g., rattlesnake or hornet
              (ldmg, lextra) : rest -> (ldmg ++ lbonus, lextra) : rest
            displayDmgAndExtra (ldmg, lextra) =
              if attrStringToString ldmg == "0"
              then case lextra of
                [] -> ldmg
                _plus : lextraRest -> lextraRest
              else ldmg ++ lextra
        in intercalate [Color.spaceAttrW32]
           $ map displayDmgAndExtra $ map snd ldischarged ++ lWithBonus
      lFull = showStrongest False strongestToDisplay
      lBrief = showStrongest True strongestToDisplay
      lFits | length lFull <= width = lFull
                -- the prevailing case, so optimized for this case only
            | length lBrief <= width = lBrief
            | otherwise = take (width - 3) lBrief ++ stringToAS "..."
  return $! lFits

drawSelected :: MonadClientUI m
             => LevelId -> Int -> ES.EnumSet ActorId -> m (Int, AttrString)
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}) =
        -- Sleep considered before being selected, because sleeping
        -- actors can't move, so selection is mostly irrelevant.
        -- Domination not considered at all, because map already shows it
        -- and so here is the only place where selection is conveyed.
        let bg = if | mleader == Just aid -> Color.HighlightYellow
                    | bwatch == WSleep -> Color.HighlightBlue
                    | ES.member aid selected -> Color.HighlightGreen
                    | 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 actorCurAndMaxSk = getActorMaxSkills leader s
      maxHp = Ability.getSk Ability.SkMaxHP actorCurAndMaxSk
  in hp <= xM (uhpWarningPercent * maxHp `div` 100)

checkWarningCalm :: UIOptions -> ActorId -> Int64 -> State -> Bool
checkWarningCalm UIOptions{uhpWarningPercent} leader calm s =
  let b = getActorBody leader s
      actorCurAndMaxSk = getActorMaxSkills leader s
      isImpression iid =
        maybe False (> 0) $ lookup IK.S_IMPRESSED $ IK.ifreq $ getIidKind iid s
      isImpressed = any isImpression $ EM.keys $ borgan b
      maxCalm = Ability.getSk Ability.SkMaxCalm actorCurAndMaxSk
  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 )