-- {-# 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.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  -- 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, 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
  -- 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 (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
  -- 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{rXmax}} <- 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 + rXmax) 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
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
  -- Not @ScreenContent@, because pathing in level's map.
  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  -- overwrites path
  return upd

drawFrameActor :: forall m. MonadClientUI m => LevelId -> m FrameForall
drawFrameActor drawnLevelId = do
  COps{corule=RuleContent{rXmax}} <- getsState scops
  SessionUI{sactorUI, sselected, sUIOptions} <- getSession
  -- Not @ScreenContent@, because indexing in level's data.
  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  -- dominated by us
                                     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
          -- big actor overlay projectiles
  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
  -- Not @ScreenContent@, because indexing in level's data.
  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
      -- Here @rXmax@ and @rYmax@ are correct, because we are not
      -- turning the whole screen into black&white, but only the level map.
      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  -- overwrites target
          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
      -- The indicators must fit, they are the actual information.
      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 <> "..."
      -- The indicators must fit, they are the actual information.
      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
      -- To be replaced by something more useful.
      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)
  -- Keep it at least partially lazy, to avoid allocating the whole list:
  return
#ifdef WITH_EXPENSIVE_ASSERTIONS
    $ assert (length status == 2 * _rXmax
              `blame` map Color.charFromW32 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 <- drawFramePath drawnLevelId
  updActor <- drawFrameActor drawnLevelId
  updExtra <- drawFrameExtra dm drawnLevelId
  let upd = FrameForall $ \v -> do
        unFrameForall updContent v
        -- vty frontend is screen-reader friendly, so avoid visual fluff
        unless (frontendName == "vty") $ unFrameForall updPath v
        unFrameForall updActor v
        unFrameForall updExtra v
  return (baseTerrain, 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
  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
          -- 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 = stringToAL  -- only if nothing at all noteworthy
          checkSleep body resDelta
            | bwatch body == WSleep = addColor Color.Green
            | 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
          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
      -- 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 $! 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
        [] -> []  -- unlikely; means no timeout-free organ
        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}) =
        -- 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.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 )
