{-# LANGUAGE RankNTypes #-}
-- | Screen overlays.
module Game.LambdaHack.Client.UI.Overlay
  ( -- * AttrLine
    AttrLine, emptyAttrLine, textToAL, textFgToAL, stringToAL, (<+:>)
    -- * Overlay
  , Overlay, IntOverlay
  , splitAttrLine, indentSplitAttrLine, glueLines, updateLines
    -- * Misc
  , ColorMode(..)
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , linesAttr, splitAttrPhrase
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Data.Text as T

import qualified Game.LambdaHack.Definition.Color as Color
import           Game.LambdaHack.Definition.Defs

-- * AttrLine

-- | Line of colourful text.
type AttrLine = [Color.AttrCharW32]

emptyAttrLine :: Int -> AttrLine
emptyAttrLine :: Int -> AttrLine
emptyAttrLine w :: Int
w = Int -> AttrCharW32 -> AttrLine
forall a. Int -> a -> [a]
replicate Int
w AttrCharW32
Color.spaceAttrW32

textToAL :: Text -> AttrLine
textToAL :: Text -> AttrLine
textToAL !Text
t =
  let f :: Char -> AttrLine -> AttrLine
f c :: Char
c l :: AttrLine
l = let !ac :: AttrCharW32
ac = Char -> AttrCharW32
Color.attrChar1ToW32 Char
c
              in AttrCharW32
ac AttrCharW32 -> AttrLine -> AttrLine
forall a. a -> [a] -> [a]
: AttrLine
l
  in (Char -> AttrLine -> AttrLine) -> AttrLine -> Text -> AttrLine
forall a. (Char -> a -> a) -> a -> Text -> a
T.foldr Char -> AttrLine -> AttrLine
f [] Text
t

textFgToAL :: Color.Color -> Text -> AttrLine
textFgToAL :: Color -> Text -> AttrLine
textFgToAL !Color
fg !Text
t =
  let f :: Char -> AttrLine -> AttrLine
f ' ' l :: AttrLine
l = AttrCharW32
Color.spaceAttrW32 AttrCharW32 -> AttrLine -> AttrLine
forall a. a -> [a] -> [a]
: AttrLine
l
                  -- for speed and simplicity we always keep the space @White@
      f c :: Char
c l :: AttrLine
l = let !ac :: AttrCharW32
ac = Color -> Char -> AttrCharW32
Color.attrChar2ToW32 Color
fg Char
c
              in AttrCharW32
ac AttrCharW32 -> AttrLine -> AttrLine
forall a. a -> [a] -> [a]
: AttrLine
l
  in (Char -> AttrLine -> AttrLine) -> AttrLine -> Text -> AttrLine
forall a. (Char -> a -> a) -> a -> Text -> a
T.foldr Char -> AttrLine -> AttrLine
f [] Text
t

stringToAL :: String -> AttrLine
stringToAL :: String -> AttrLine
stringToAL = (Char -> AttrCharW32) -> String -> AttrLine
forall a b. (a -> b) -> [a] -> [b]
map Char -> AttrCharW32
Color.attrChar1ToW32

infixr 6 <+:>  -- matches Monoid.<>
(<+:>) :: AttrLine -> AttrLine -> AttrLine
<+:> :: AttrLine -> AttrLine -> AttrLine
(<+:>) [] l2 :: AttrLine
l2 = AttrLine
l2
(<+:>) l1 :: AttrLine
l1 [] = AttrLine
l1
(<+:>) l1 :: AttrLine
l1 l2 :: AttrLine
l2 = AttrLine
l1 AttrLine -> AttrLine -> AttrLine
forall a. [a] -> [a] -> [a]
++ [AttrCharW32
Color.spaceAttrW32] AttrLine -> AttrLine -> AttrLine
forall a. [a] -> [a] -> [a]
++ AttrLine
l2

-- * Overlay

-- | A series of screen lines that either fit the width of the screen
-- or are intended for truncation when displayed. The length of overlay
-- may exceed the length of the screen, unlike in @SingleFrame@.
-- An exception is lines generated from animation, which have to fit
-- in either dimension.
type Overlay = [AttrLine]

-- | Sparse screen overlay representation where only the indicated rows
-- are overlayed and the remaining rows are kept unchanged.
type IntOverlay = [(Int, AttrLine)]

-- | Split a string into lines. Avoids ending the line with
-- a character other than space. Space characters are removed
-- from the start, but never from the end of lines. Newlines are respected.
--
-- Note that we only split wrt @White@ space, nothing else.
splitAttrLine :: X -> AttrLine -> Overlay
splitAttrLine :: Int -> AttrLine -> Overlay
splitAttrLine w :: Int
w l :: AttrLine
l =
  (AttrLine -> Overlay) -> Overlay -> Overlay
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> AttrLine -> Overlay
splitAttrPhrase Int
w (AttrLine -> Overlay)
-> (AttrLine -> AttrLine) -> AttrLine -> Overlay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AttrCharW32 -> Bool) -> AttrLine -> AttrLine
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
== AttrCharW32
Color.spaceAttrW32))
  (Overlay -> Overlay) -> Overlay -> Overlay
forall a b. (a -> b) -> a -> b
$ AttrLine -> Overlay
linesAttr AttrLine
l

indentSplitAttrLine :: X -> AttrLine -> [AttrLine]
indentSplitAttrLine :: Int -> AttrLine -> Overlay
indentSplitAttrLine w :: Int
w l :: AttrLine
l =
  -- First line could be split at @w@, not @w - 1@, but it's good enough.
  let ts :: Overlay
ts = Int -> AttrLine -> Overlay
splitAttrLine (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) AttrLine
l
  in case Overlay
ts of
    [] -> []
    hd :: AttrLine
hd : tl :: Overlay
tl -> AttrLine
hd AttrLine -> Overlay -> Overlay
forall a. a -> [a] -> [a]
: (AttrLine -> AttrLine) -> Overlay -> Overlay
forall a b. (a -> b) -> [a] -> [b]
map ([AttrCharW32
Color.spaceAttrW32] AttrLine -> AttrLine -> AttrLine
forall a. [a] -> [a] -> [a]
++) Overlay
tl

linesAttr :: AttrLine -> Overlay
linesAttr :: AttrLine -> Overlay
linesAttr l :: AttrLine
l | AttrLine -> Bool
forall a. [a] -> Bool
null AttrLine
l = []
            | Bool
otherwise = AttrLine
h AttrLine -> Overlay -> Overlay
forall a. a -> [a] -> [a]
: if AttrLine -> Bool
forall a. [a] -> Bool
null AttrLine
t then [] else AttrLine -> Overlay
linesAttr (AttrLine -> AttrLine
forall a. [a] -> [a]
tail AttrLine
t)
 where (h :: AttrLine
h, t :: AttrLine
t) = (AttrCharW32 -> Bool) -> AttrLine -> (AttrLine, AttrLine)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
/= AttrCharW32
Color.retAttrW32) AttrLine
l

-- We consider only these, because they are short and form a closed category.
nonbreakableRev :: [AttrLine]
nonbreakableRev :: Overlay
nonbreakableRev = (String -> AttrLine) -> [String] -> Overlay
forall a b. (a -> b) -> [a] -> [b]
map String -> AttrLine
stringToAL ["eht", "a", "na", "ehT", "A", "nA"]

breakAtSpace :: AttrLine -> (AttrLine, AttrLine)
breakAtSpace :: AttrLine -> (AttrLine, AttrLine)
breakAtSpace lRev :: AttrLine
lRev =
  let (pre :: AttrLine
pre, post :: AttrLine
post) = (AttrCharW32 -> Bool) -> AttrLine -> (AttrLine, AttrLine)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
== AttrCharW32
Color.spaceAttrW32) AttrLine
lRev
  in case AttrLine
post of
    c :: AttrCharW32
c : rest :: AttrLine
rest | AttrCharW32
c AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
== AttrCharW32
Color.spaceAttrW32 ->
      if (AttrLine -> Bool) -> Overlay -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (AttrLine -> AttrLine -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` AttrLine
rest) Overlay
nonbreakableRev
      then let (pre2 :: AttrLine
pre2, post2 :: AttrLine
post2) = AttrLine -> (AttrLine, AttrLine)
breakAtSpace AttrLine
rest
           in (AttrLine
pre AttrLine -> AttrLine -> AttrLine
forall a. [a] -> [a] -> [a]
++ AttrCharW32
c AttrCharW32 -> AttrLine -> AttrLine
forall a. a -> [a] -> [a]
: AttrLine
pre2, AttrLine
post2)
      else (AttrLine
pre, AttrLine
post)
    _ -> (AttrLine
pre, AttrLine
post)  -- no space found, give up

splitAttrPhrase :: X -> AttrLine -> Overlay
splitAttrPhrase :: Int -> AttrLine -> Overlay
splitAttrPhrase w :: Int
w xs :: AttrLine
xs
  | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= AttrLine -> Int
forall a. [a] -> Int
length AttrLine
xs = [AttrLine
xs]  -- no problem, everything fits
  | Bool
otherwise =
      let (pre :: AttrLine
pre, postRaw :: AttrLine
postRaw) = Int -> AttrLine -> (AttrLine, AttrLine)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
w AttrLine
xs
          preRev :: AttrLine
preRev = AttrLine -> AttrLine
forall a. [a] -> [a]
reverse AttrLine
pre
          ((ppre :: AttrLine
ppre, ppost :: AttrLine
ppost), post :: AttrLine
post) = case AttrLine
postRaw of
            c :: AttrCharW32
c : rest :: AttrLine
rest | AttrCharW32
c AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
== AttrCharW32
Color.spaceAttrW32
                       Bool -> Bool -> Bool
&& Bool -> Bool
not ((AttrLine -> Bool) -> Overlay -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (AttrLine -> AttrLine -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` AttrLine
preRev) Overlay
nonbreakableRev) ->
              (([], AttrLine
preRev), AttrLine
rest)
            _ -> (AttrLine -> (AttrLine, AttrLine)
breakAtSpace AttrLine
preRev, AttrLine
postRaw)
          testPost :: AttrLine
testPost = (AttrCharW32 -> Bool) -> AttrLine -> AttrLine
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
== AttrCharW32
Color.spaceAttrW32) AttrLine
ppost
      in if AttrLine -> Bool
forall a. [a] -> Bool
null AttrLine
testPost
         then AttrLine
pre AttrLine -> Overlay -> Overlay
forall a. a -> [a] -> [a]
: Int -> AttrLine -> Overlay
splitAttrPhrase Int
w AttrLine
post
         else AttrLine -> AttrLine
forall a. [a] -> [a]
reverse AttrLine
ppost AttrLine -> Overlay -> Overlay
forall a. a -> [a] -> [a]
: Int -> AttrLine -> Overlay
splitAttrPhrase Int
w (AttrLine -> AttrLine
forall a. [a] -> [a]
reverse AttrLine
ppre AttrLine -> AttrLine -> AttrLine
forall a. [a] -> [a] -> [a]
++ AttrLine
post)

glueLines :: Overlay -> Overlay -> Overlay
glueLines :: Overlay -> Overlay -> Overlay
glueLines ov1 :: Overlay
ov1 ov2 :: Overlay
ov2 = Overlay -> Overlay
forall a. [a] -> [a]
reverse (Overlay -> Overlay) -> Overlay -> Overlay
forall a b. (a -> b) -> a -> b
$ Overlay -> Overlay -> Overlay
glue (Overlay -> Overlay
forall a. [a] -> [a]
reverse Overlay
ov1) Overlay
ov2
 where glue :: Overlay -> Overlay -> Overlay
glue [] l :: Overlay
l = Overlay
l
       glue m :: Overlay
m [] = Overlay
m
       glue (mh :: AttrLine
mh : mt :: Overlay
mt) (lh :: AttrLine
lh : lt :: Overlay
lt) = Overlay -> Overlay
forall a. [a] -> [a]
reverse Overlay
lt Overlay -> Overlay -> Overlay
forall a. [a] -> [a] -> [a]
++ (AttrLine
mh AttrLine -> AttrLine -> AttrLine
<+:> AttrLine
lh) AttrLine -> Overlay -> Overlay
forall a. a -> [a] -> [a]
: Overlay
mt

-- @f@ should not enlarge the line beyond screen width.
updateLines :: Int -> (AttrLine -> AttrLine) -> Overlay -> Overlay
updateLines :: Int -> (AttrLine -> AttrLine) -> Overlay -> Overlay
updateLines n :: Int
n f :: AttrLine -> AttrLine
f ov :: Overlay
ov =
  let upd :: Int -> Overlay -> Overlay
upd k :: Int
k (l :: AttrLine
l : ls :: Overlay
ls) = if Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
                       then AttrLine -> AttrLine
f AttrLine
l AttrLine -> Overlay -> Overlay
forall a. a -> [a] -> [a]
: Overlay
ls
                       else AttrLine
l AttrLine -> Overlay -> Overlay
forall a. a -> [a] -> [a]
: Int -> Overlay -> Overlay
upd (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Overlay
ls
      upd _ [] = []
  in Int -> Overlay -> Overlay
upd Int
n Overlay
ov

-- * Misc

-- | Color mode for the display.
data ColorMode =
    ColorFull  -- ^ normal, with full colours
  | ColorBW    -- ^ black and white only
  deriving ColorMode -> ColorMode -> Bool
(ColorMode -> ColorMode -> Bool)
-> (ColorMode -> ColorMode -> Bool) -> Eq ColorMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ColorMode -> ColorMode -> Bool
$c/= :: ColorMode -> ColorMode -> Bool
== :: ColorMode -> ColorMode -> Bool
$c== :: ColorMode -> ColorMode -> Bool
Eq