{-# 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 :: 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
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 <+:>
(<+:>) :: 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
type Overlay = [AttrLine]
type IntOverlay = [(Int, AttrLine)]
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 =
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
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)
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]
| 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
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
data ColorMode =
ColorFull
| ColorBW
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