{-# LANGUAGE RankNTypes #-}
module Game.LambdaHack.Client.UI.Overlay
(
AttrLine, emptyAttrLine, textToAL, textFgToAL, stringToAL, (<+:>)
, Overlay, IntOverlay
, splitAttrLine, indentSplitAttrLine, glueLines, updateLines
, ColorMode(..)
#ifdef EXPOSE_INTERNAL
, 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
type AttrLine = [Color.AttrCharW32]
emptyAttrLine :: Int -> AttrLine
emptyAttrLine w = replicate w Color.spaceAttrW32
textToAL :: Text -> AttrLine
textToAL !t =
let f c l = let !ac = Color.attrChar1ToW32 c
in ac : l
in T.foldr f [] t
textFgToAL :: Color.Color -> Text -> AttrLine
textFgToAL !fg !t =
let f ' ' l = Color.spaceAttrW32 : l
f c l = let !ac = Color.attrChar2ToW32 fg c
in ac : l
in T.foldr f [] t
stringToAL :: String -> AttrLine
stringToAL = map Color.attrChar1ToW32
infixr 6 <+:>
(<+:>) :: AttrLine -> AttrLine -> AttrLine
(<+:>) [] l2 = l2
(<+:>) l1 [] = l1
(<+:>) l1 l2 = l1 ++ [Color.spaceAttrW32] ++ l2
type Overlay = [AttrLine]
type IntOverlay = [(Int, AttrLine)]
splitAttrLine :: X -> AttrLine -> Overlay
splitAttrLine w l =
concatMap (splitAttrPhrase w . dropWhile (== Color.spaceAttrW32))
$ linesAttr l
indentSplitAttrLine :: X -> AttrLine -> [AttrLine]
indentSplitAttrLine w l =
let ts = splitAttrLine (w - 1) l
in case ts of
[] -> []
hd : tl -> hd : map ([Color.spaceAttrW32] ++) tl
linesAttr :: AttrLine -> Overlay
linesAttr l | null l = []
| otherwise = h : if null t then [] else linesAttr (tail t)
where (h, t) = span (/= Color.retAttrW32) l
nonbreakableRev :: [AttrLine]
nonbreakableRev = map stringToAL ["eht", "a", "na", "ehT", "A", "nA"]
breakAtSpace :: AttrLine -> (AttrLine, AttrLine)
breakAtSpace lRev =
let (pre, post) = break (== Color.spaceAttrW32) lRev
in case post of
c : rest | c == Color.spaceAttrW32 ->
if any (`isPrefixOf` rest) nonbreakableRev
then let (pre2, post2) = breakAtSpace rest
in (pre ++ c : pre2, post2)
else (pre, post)
_ -> (pre, post)
splitAttrPhrase :: X -> AttrLine -> Overlay
splitAttrPhrase w xs
| w >= length xs = [xs]
| otherwise =
let (pre, postRaw) = splitAt w xs
preRev = reverse pre
((ppre, ppost), post) = case postRaw of
c : rest | c == Color.spaceAttrW32
&& not (any (`isPrefixOf` preRev) nonbreakableRev) ->
(([], preRev), rest)
_ -> (breakAtSpace preRev, postRaw)
testPost = dropWhileEnd (== Color.spaceAttrW32) ppost
in if null testPost
then pre : splitAttrPhrase w post
else reverse ppost : splitAttrPhrase w (reverse ppre ++ post)
glueLines :: Overlay -> Overlay -> Overlay
glueLines ov1 ov2 = reverse $ glue (reverse ov1) ov2
where glue [] l = l
glue m [] = m
glue (mh : mt) (lh : lt) = reverse lt ++ (mh <+:> lh) : mt
updateLines :: Int -> (AttrLine -> AttrLine) -> Overlay -> Overlay
updateLines n f ov =
let upd k (l : ls) = if k == 0
then f l : ls
else l : upd (k - 1) ls
upd _ [] = []
in upd n ov
data ColorMode =
ColorFull
| ColorBW
deriving Eq