{-# LANGUAGE RankNTypes, TupleSections #-}
-- | Screen overlays.
module Game.LambdaHack.Client.UI.Overlay
  ( -- * DisplayFont
    DisplayFont, isPropFont, isSquareFont, isMonoFont, textSize
  , -- * FontSetup
    FontSetup(..), multiFontSetup, singleFontSetup
  , -- * AttrString
    AttrString, blankAttrString, textToAS, textFgToAS, stringToAS
  , attrStringToString
  , (<+:>), (<\:>)
    -- * AttrLine
  , AttrLine, attrLine, emptyAttrLine, attrStringToAL, firstParagraph
  , textToAL, textFgToAL, stringToAL, linesAttr
  , splitAttrString, indentSplitAttrString
    -- * Overlay
  , Overlay, xytranslateOverlay, xtranslateOverlay, ytranslateOverlay
  , offsetOverlay, offsetOverlayX, typesetXY
  , updateLine, rectangleOfSpaces, maxYofOverlay, labDescOverlay
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , nonbreakableRev, isPrefixOfNonbreakable, breakAtSpace, splitAttrPhrase
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Data.Char (isSpace)
import qualified Data.Text as T

import           Game.LambdaHack.Client.UI.PointUI
import qualified Game.LambdaHack.Definition.Color as Color

-- * DisplayFont

-- | Three types of fonts used in the UI. Overlays (layers, more or less)
-- in proportional font are overwritten by layers in square font,
-- which are overwritten by layers in mono font.
-- All overlays overwrite the rendering of the game map, which is
-- the underlying basic UI frame, comprised of square font glyps.
--
-- This type needs to be kept abstract to ensure that frontend-enforced
-- or user config-enforced font assignments in 'FontSetup'
-- (e.g., stating that the supposedly proportional font is overriden
-- to be the square font) can't be ignored. Otherwise a programmer
-- could use arbirary @DisplayFont@, instead of the one taken from 'FontSetup',
-- and so, e.g., calculating the width of an overlay so constructed
-- in order to decide where another overlay can start would be inconsistent
-- what what font is really eventually used when rendering.
--
-- Note that the order of constructors has limited effect,
-- but it illustrates how overwriting is explicitly implemented
-- in frontends that support all fonts.
data DisplayFont = PropFont | SquareFont | MonoFont
  deriving (Show, Eq, Enum)

isPropFont, isSquareFont, isMonoFont :: DisplayFont -> Bool
isPropFont = (== PropFont)
isSquareFont = (== SquareFont)
isMonoFont = (== MonoFont)

textSize :: DisplayFont -> [a] -> Int
textSize SquareFont l = 2 * length l
textSize MonoFont l = length l
textSize PropFont _ = error "size of proportional font texts is not defined"

-- * FontSetup

data FontSetup = FontSetup
  { squareFont :: DisplayFont
  , monoFont   :: DisplayFont
  , propFont   :: DisplayFont
  }
  deriving (Eq, Show)  -- for unit tests

multiFontSetup :: FontSetup
multiFontSetup = FontSetup SquareFont MonoFont PropFont

singleFontSetup :: FontSetup
singleFontSetup = FontSetup SquareFont SquareFont SquareFont

-- * AttrString

-- | String of colourful text. End of line characters permitted.
type AttrString = [Color.AttrCharW32]

blankAttrString :: Int -> AttrString
blankAttrString w = replicate w Color.spaceAttrW32

textToAS :: Text -> AttrString
textToAS !t =
  let f c l = let !ac = Color.attrChar1ToW32 c
              in ac : l
  in T.foldr f [] t

textFgToAS :: Color.Color -> Text -> AttrString
textFgToAS !fg !t =
  let f ' ' l = Color.spaceAttrW32 : l
                  -- for speed and simplicity (testing if char is a space)
                  -- we always keep the space @White@
      f c l = let !ac = Color.attrChar2ToW32 fg c
              in ac : l
  in T.foldr f [] t

stringToAS :: String -> AttrString
stringToAS = map Color.attrChar1ToW32

-- | Transform 'AttrString' type to 'String'.
attrStringToString :: AttrString -> String
attrStringToString = map Color.charFromW32

-- Follows minimorph.<+>.
infixr 6 <+:>  -- matches Monoid.<>
(<+:>) :: AttrString -> AttrString -> AttrString
(<+:>) [] l2 = l2
(<+:>) l1 [] = l1
(<+:>) l1 l2@(c2 : _) =
  if isSpace (Color.charFromW32 c2) || isSpace (Color.charFromW32 (last l1))
  then l1 ++ l2
  else l1 ++ [Color.spaceAttrW32] ++ l2

infixr 6 <\:>  -- matches Monoid.<>
(<\:>) :: AttrString -> AttrString -> AttrString
(<\:>) [] l2 = l2
(<\:>) l1 [] = l1
(<\:>) l1 l2@(c2 : _) =
  if Color.charFromW32 c2 == '\n' || Color.charFromW32 (last l1) == '\n'
  then l1 ++ l2
  else l1 ++ stringToAS "\n" ++ l2

-- We consider only these, because they are short and form a closed category.
nonbreakableRev :: [String]
nonbreakableRev = ["eht", "a", "na", "ehT", "A", "nA", "I"]

isPrefixOfNonbreakable :: AttrString -> Bool
isPrefixOfNonbreakable s =
  let isPrefixOfNb sRev nbRev = case stripPrefix nbRev sRev of
        Nothing -> False
        Just [] -> True
        Just (c : _) -> isSpace c
  in any (isPrefixOfNb $ attrStringToString s) nonbreakableRev

breakAtSpace :: AttrString -> (AttrString, AttrString)
breakAtSpace lRev =
  let (pre, post) = break (== Color.spaceAttrW32) lRev
  in case post of
    c : rest | c == Color.spaceAttrW32 ->
      if isPrefixOfNonbreakable rest
      then let (pre2, post2) = breakAtSpace rest
           in (pre ++ c : pre2, post2)
      else (pre, post)
    _ -> (pre, post)  -- no space found, give up

-- * AttrLine

-- | Line of colourful text. End of line characters forbidden. Trailing
-- @White@ space forbidden.
newtype AttrLine = AttrLine {attrLine :: AttrString}
  deriving (Show, Eq)

emptyAttrLine :: AttrLine
emptyAttrLine = AttrLine []

attrStringToAL :: AttrString -> AttrLine
attrStringToAL s =
#ifdef WITH_EXPENSIVE_ASSERTIONS
  assert (allB (\ac -> Color.charFromW32 ac /= '\n') s) $  -- expensive in menus
  assert (null s || last s /= Color.spaceAttrW32
          `blame` attrStringToString s) $
    -- only expensive for menus, but often violated by code changes, so disabled
    -- outside test runs
#endif
    AttrLine s

firstParagraph :: AttrString -> AttrLine
firstParagraph s = case linesAttr s of
  [] -> emptyAttrLine
  l : _ -> l

textToAL :: Text -> AttrLine
textToAL !t =
  let f '\n' _ = error $ "illegal end of line in: " ++ T.unpack t
      f c l = let !ac = Color.attrChar1ToW32 c
              in ac : l
      s = T.foldr f [] t
  in AttrLine $
#ifdef WITH_EXPENSIVE_ASSERTIONS
  assert (null s || last s /= Color.spaceAttrW32 `blame` t)
#endif
    s

textFgToAL :: Color.Color -> Text -> AttrLine
textFgToAL !fg !t =
  let f '\n' _ = error $ "illegal end of line in: " ++ T.unpack t
      f ' ' l = Color.spaceAttrW32 : l
                  -- for speed and simplicity (testing if char is a space)
                  -- we always keep the space @White@
      f c l = let !ac = Color.attrChar2ToW32 fg c
              in ac : l
      s = T.foldr f [] t
  in AttrLine $
#ifdef WITH_EXPENSIVE_ASSERTIONS
  assert (null s || last s /= Color.spaceAttrW32 `blame` t)
#endif
    s

stringToAL :: String -> AttrLine
stringToAL s = attrStringToAL $ map Color.attrChar1ToW32 s

-- Mimics @lines@.
linesAttr :: AttrString -> [AttrLine]
linesAttr [] = []
linesAttr l = cons (case break (\ac -> Color.charFromW32 ac == '\n') l of
  (h, t) -> (attrStringToAL h, case t of
                                 [] -> []
                                 _ : tt -> linesAttr tt))
 where
  cons ~(h, t) = h : t

-- | Split a string into lines. Avoid breaking the line at a character
-- other than space. Remove the spaces on which lines are broken,
-- keep other spaces. In expensive assertions mode (dev debug mode)
-- fail at trailing spaces, but keep leading spaces, e.g., to make
-- distance from a text in another font. Newlines are respected.
--
-- Note that we only split wrt @White@ space, nothing else,
-- and the width, in the first argument, is calculated in characters,
-- not in UI (mono font) coordinates, so that taking and dropping characters
-- is performed correctly.
splitAttrString :: Int -> Int -> AttrString -> [AttrLine]
splitAttrString w0 w1 l = case linesAttr l of
  [] -> []
  x : xs -> splitAttrPhrase w0 w1 x ++ concatMap (splitAttrPhrase w1 w1) xs

indentSplitAttrString :: DisplayFont -> Int -> AttrString -> [AttrLine]
indentSplitAttrString font w l = assert (w > 4) $
  -- Sadly this depends on how wide the space is in propotional font,
  -- which varies wildly, so we err on the side of larger indent.
  let nspaces = case font of
        SquareFont -> 1
        MonoFont -> 2
        PropFont -> 4
      ts = splitAttrString w (w - nspaces) l
      -- Proportional spaces are very narrow.
      spaces = replicate nspaces Color.spaceAttrW32
  in case ts of
    [] -> []
    hd : tl -> hd : map (AttrLine . (spaces ++) . attrLine) tl

-- We pass empty line along for the case of appended buttons, which need
-- either space or new lines before them.
splitAttrPhrase :: Int -> Int -> AttrLine -> [AttrLine]
splitAttrPhrase w0 w1 (AttrLine xs)
  | w0 >= length xs = [AttrLine xs]  -- no problem, everything fits
  | otherwise =
      let (pre, postRaw) = splitAt w0 xs
          preRev = reverse pre
          ((ppre, ppost), post) = case postRaw of
            c : rest | c == Color.spaceAttrW32
                       && not (isPrefixOfNonbreakable preRev) ->
              (([], preRev), rest)
            _ -> (breakAtSpace preRev, postRaw)
      in if all (== Color.spaceAttrW32) ppost
         then AttrLine (reverse $ dropWhile (== Color.spaceAttrW32) preRev)
              : splitAttrPhrase w1 w1 (AttrLine post)
         else AttrLine (reverse $ dropWhile (== Color.spaceAttrW32) ppost)
              : splitAttrPhrase w1 w1 (AttrLine $ reverse ppre ++ post)

-- * Overlay

-- | A series of screen lines with start positions at which they should
-- be overlayed over the base frame or a blank screen, depending on context.
-- The position point is represented as in integer that is an index into the
-- frame character array.
-- The lines either fit the width of the screen or are intended
-- for truncation when displayed. The start positions of lines may fall outside
-- the length of the screen, too, unlike in @SingleFrame@. Then they are
-- simply not shown.
type Overlay = [(PointUI, AttrLine)]

xytranslateOverlay :: Int -> Int -> Overlay -> Overlay
xytranslateOverlay dx dy =
  map (\(PointUI x y, al) -> (PointUI (x + dx) (y + dy), al))

xtranslateOverlay :: Int -> Overlay -> Overlay
xtranslateOverlay dx = xytranslateOverlay dx 0

ytranslateOverlay :: Int -> Overlay -> Overlay
ytranslateOverlay = xytranslateOverlay 0

offsetOverlay :: [AttrLine] -> Overlay
offsetOverlay = zipWith (curry (first $ PointUI 0)) [0..]

offsetOverlayX :: [(Int, AttrLine)] -> Overlay
offsetOverlayX = zipWith (\y (x, al) -> (PointUI x y, al)) [0..]

typesetXY :: (Int, Int) -> [AttrLine] -> Overlay
typesetXY (xoffset, yoffset) =
  zipWith (\y al -> (PointUI xoffset (y + yoffset), al)) [0..]

-- @f@ should not enlarge the line beyond screen width nor introduce linebreaks.
updateLine :: Int -> (Int -> AttrString -> AttrString) -> Overlay -> Overlay
updateLine y f ov =
  let upd (p@(PointUI px py), AttrLine l) =
        if py == y then (p, AttrLine $ f px l) else (p, AttrLine l)
  in map upd ov

rectangleOfSpaces :: Int -> Int -> Overlay
rectangleOfSpaces x y =
  let blankAttrLine = AttrLine $ replicate x Color.nbspAttrW32
  in offsetOverlay $ replicate y blankAttrLine

maxYofOverlay :: Overlay -> Int
maxYofOverlay ov = let yOfOverlay (PointUI _ y, _) = y
                   in maximum $ 0 : map yOfOverlay ov

labDescOverlay :: DisplayFont -> Int -> AttrString -> (Overlay, Overlay)
labDescOverlay labFont width as =
  let (tLab, tDesc) = span (/= Color.spaceAttrW32) as
      labLen = textSize labFont tLab
      len = max 0 $ width - length tLab  -- not labLen; TODO: type more strictly
      ovLab = offsetOverlay [attrStringToAL tLab]
      ovDesc = offsetOverlayX $
        case splitAttrString len width tDesc of
          [] -> []
          l : ls -> (labLen, l) : map (0,) ls
  in (ovLab, ovDesc)