{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-}
module Monomer.Graphics.Text (
calcTextSize,
calcTextSize_,
fitTextToSize,
fitTextToWidth,
alignTextLines,
moveTextLines,
getTextLinesSize,
getGlyphsMin,
getGlyphsMax
) where
import Control.Lens ((&), (^.), (^?), (+~), ix, non)
import Data.Default
import Data.List (foldl')
import Data.Maybe
import Data.Sequence (Seq(..), (<|), (|>))
import Data.Text (Text)
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import Monomer.Common
import Monomer.Core.StyleTypes
import Monomer.Core.StyleUtil
import Monomer.Graphics.Types
import Monomer.Helper
import qualified Monomer.Common.Lens as L
import qualified Monomer.Graphics.Lens as L
type GlyphGroup = Seq GlyphPos
calcTextSize
:: FontManager
-> StyleState
-> Text
-> Size
calcTextSize :: FontManager -> StyleState -> Text -> Size
calcTextSize FontManager
fontMgr StyleState
style !Text
text = Size
size where
size :: Size
size = FontManager
-> StyleState
-> TextMode
-> TextTrim
-> Maybe Double
-> Maybe Int
-> Text
-> Size
calcTextSize_ FontManager
fontMgr StyleState
style TextMode
SingleLine TextTrim
KeepSpaces forall a. Maybe a
Nothing forall a. Maybe a
Nothing Text
text
calcTextSize_
:: FontManager
-> StyleState
-> TextMode
-> TextTrim
-> Maybe Double
-> Maybe Int
-> Text
-> Size
calcTextSize_ :: FontManager
-> StyleState
-> TextMode
-> TextTrim
-> Maybe Double
-> Maybe Int
-> Text
-> Size
calcTextSize_ FontManager
fontMgr StyleState
style TextMode
mode TextTrim
trim Maybe Double
mwidth Maybe Int
mlines Text
text = Size
newSize where
font :: Font
font = StyleState -> Font
styleFont StyleState
style
fontSize :: FontSize
fontSize = StyleState -> FontSize
styleFontSize StyleState
style
!metrics :: TextMetrics
metrics = FontManager -> Font -> FontSize -> TextMetrics
computeTextMetrics FontManager
fontMgr Font
font FontSize
fontSize
width :: Double
width = forall a. a -> Maybe a -> a
fromMaybe forall a. RealFloat a => a
maxNumericValue Maybe Double
mwidth
textLinesW :: Seq TextLine
textLinesW = FontManager
-> StyleState -> Double -> TextTrim -> Text -> Seq TextLine
fitTextToWidth FontManager
fontMgr StyleState
style Double
width TextTrim
trim Text
text
textLines :: Seq TextLine
textLines
| TextMode
mode forall a. Eq a => a -> a -> Bool
== TextMode
SingleLine = forall a. Int -> Seq a -> Seq a
Seq.take Int
1 Seq TextLine
textLinesW
| forall a. Maybe a -> Bool
isJust Maybe Int
mlines = forall a. Int -> Seq a -> Seq a
Seq.take (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Int
mlines) Seq TextLine
textLinesW
| Bool
otherwise = Seq TextLine
textLinesW
newSize :: Size
newSize
| Bool -> Bool
not (forall a. Seq a -> Bool
Seq.null Seq TextLine
textLines) = Seq TextLine -> Size
getTextLinesSize Seq TextLine
textLines
| Bool
otherwise = Double -> Double -> Size
Size Double
0 (TextMetrics -> Double
_txmLineH TextMetrics
metrics)
fitTextToSize
:: FontManager
-> StyleState
-> TextOverflow
-> TextMode
-> TextTrim
-> Maybe Int
-> Size
-> Text
-> Seq TextLine
fitTextToSize :: FontManager
-> StyleState
-> TextOverflow
-> TextMode
-> TextTrim
-> Maybe Int
-> Size
-> Text
-> Seq TextLine
fitTextToSize FontManager
fontMgr StyleState
style TextOverflow
ovf TextMode
mode TextTrim
trim Maybe Int
mlines !Size
size !Text
text = Seq TextLine
newLines where
Size Double
cw Double
ch = Size
size
font :: Font
font = StyleState -> Font
styleFont StyleState
style
fontSize :: FontSize
fontSize = StyleState -> FontSize
styleFontSize StyleState
style
textMetrics :: TextMetrics
textMetrics = FontManager -> Font -> FontSize -> TextMetrics
computeTextMetrics FontManager
fontMgr Font
font FontSize
fontSize
fitW :: Double
fitW
| TextMode
mode forall a. Eq a => a -> a -> Bool
== TextMode
MultiLine = Double
cw
| Bool
otherwise = forall a. RealFloat a => a
maxNumericValue
maxH :: Double
maxH = case Maybe Int
mlines of
Just Int
maxLines -> forall a. Ord a => a -> a -> a
min Double
ch (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxLines forall a. Num a => a -> a -> a
* TextMetrics
textMetrics forall s a. s -> Getting a s a -> a
^. forall s a. HasLineH s a => Lens' s a
L.lineH)
Maybe Int
_ -> Double
ch
textLinesW :: Seq TextLine
textLinesW = FontManager
-> StyleState -> Double -> TextTrim -> Text -> Seq TextLine
fitTextToWidth FontManager
fontMgr StyleState
style Double
fitW TextTrim
trim Text
text
firstLine :: Seq TextLine
firstLine = forall a. Int -> Seq a -> Seq a
Seq.take Int
1 Seq TextLine
textLinesW
isMultiline :: Bool
isMultiline = TextMode
mode forall a. Eq a => a -> a -> Bool
== TextMode
MultiLine
ellipsisReq :: Bool
ellipsisReq = TextOverflow
ovf forall a. Eq a => a -> a -> Bool
== TextOverflow
Ellipsis Bool -> Bool -> Bool
&& Seq TextLine -> Size
getTextLinesSize Seq TextLine
firstLine forall s a. s -> Getting a s a -> a
^. forall s a. HasW s a => Lens' s a
L.w forall a. Ord a => a -> a -> Bool
> Double
cw
newLines :: Seq TextLine
newLines
| Bool
isMultiline = FontManager
-> StyleState
-> TextOverflow
-> Double
-> Double
-> Seq TextLine
-> Seq TextLine
fitLinesToH FontManager
fontMgr StyleState
style TextOverflow
ovf Double
cw Double
maxH Seq TextLine
textLinesW
| Bool
ellipsisReq = FontManager -> StyleState -> Double -> TextLine -> TextLine
addEllipsisToTextLine FontManager
fontMgr StyleState
style Double
cw forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq TextLine
firstLine
| Bool
otherwise = FontManager
-> StyleState -> TextTrim -> Double -> TextLine -> TextLine
clipTextLine FontManager
fontMgr StyleState
style TextTrim
trim Double
cw forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq TextLine
firstLine
fitTextToWidth
:: FontManager
-> StyleState
-> Double
-> TextTrim
-> Text
-> Seq TextLine
fitTextToWidth :: FontManager
-> StyleState -> Double -> TextTrim -> Text -> Seq TextLine
fitTextToWidth FontManager
fontMgr StyleState
style Double
width TextTrim
trim Text
text = Seq TextLine
resultLines where
font :: Font
font = StyleState -> Font
styleFont StyleState
style
fSize :: FontSize
fSize = StyleState -> FontSize
styleFontSize StyleState
style
fSpcH :: FontSpace
fSpcH = StyleState -> FontSpace
styleFontSpaceH StyleState
style
fSpcV :: FontSpace
fSpcV = StyleState -> FontSpace
styleFontSpaceV StyleState
style
break :: LineBreak
break = StyleState -> LineBreak
styleTextLineBreak StyleState
style
lineH :: Double
lineH = TextMetrics -> Double
_txmLineH TextMetrics
metrics
!metrics :: TextMetrics
metrics = FontManager -> Font -> FontSize -> TextMetrics
computeTextMetrics FontManager
fontMgr Font
font FontSize
fSize
fitToWidth :: Double -> Double -> TextTrim -> Text -> Seq TextLine
fitToWidth = FontManager
-> Font
-> FontSize
-> FontSpace
-> FontSpace
-> TextMetrics
-> LineBreak
-> Double
-> Double
-> TextTrim
-> Text
-> Seq TextLine
fitLineToW FontManager
fontMgr Font
font FontSize
fSize FontSpace
fSpcH FontSpace
fSpcV TextMetrics
metrics LineBreak
break
helper :: (Seq TextLine, Double) -> Text -> (Seq TextLine, Double)
helper (Seq TextLine, Double)
acc Text
line = (Seq TextLine
cLines forall a. Semigroup a => a -> a -> a
<> Seq TextLine
newLines, Double
newTop) where
(Seq TextLine
cLines, Double
cTop) = (Seq TextLine, Double)
acc
newLines :: Seq TextLine
newLines = Double -> Double -> TextTrim -> Text -> Seq TextLine
fitToWidth Double
cTop Double
width TextTrim
trim Text
line
vspc :: Double
vspc = FontSpace -> Double
unFontSpace FontSpace
fSpcV
newTop :: Double
newTop = Double
cTop forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Seq a -> Int
Seq.length Seq TextLine
newLines) forall a. Num a => a -> a -> a
* (Double
lineH forall a. Num a => a -> a -> a
+ Double
vspc)
(Seq TextLine
resultLines, Double
_) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Seq TextLine, Double) -> Text -> (Seq TextLine, Double)
helper (forall a. Seq a
Empty, Double
0) (Text -> [Text]
T.lines Text
text)
alignTextLines
:: StyleState
-> Rect
-> Seq TextLine
-> Seq TextLine
alignTextLines :: StyleState -> Rect -> Seq TextLine -> Seq TextLine
alignTextLines StyleState
style Rect
parentRect Seq TextLine
textLines = Seq TextLine
newTextLines where
Rect Double
_ Double
py Double
_ Double
ph = Rect
parentRect
Size Double
_ Double
th = Seq TextLine -> Size
getTextLinesSize Seq TextLine
textLines
TextMetrics Double
asc Double
_ Double
lineH Double
lowerX = (Seq TextLine
textLines forall s a. s -> Getting (First a) s a -> Maybe a
^? forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
0) forall s a. s -> Getting a s a -> a
^. forall a. Eq a => a -> Iso' (Maybe a) a
non forall a. Default a => a
def forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasMetrics s a => Lens' s a
L.metrics
isSingle :: Bool
isSingle = forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq TextLine
textLines forall a. Eq a => a -> a -> Bool
== Int
1
alignH :: AlignTH
alignH = StyleState -> AlignTH
styleTextAlignH StyleState
style
alignV :: AlignTV
alignV = StyleState -> AlignTV
styleTextAlignV StyleState
style
alignOffsetY :: Double
alignOffsetY = case AlignTV
alignV of
AlignTV
ATTop -> Double
0
AlignTV
ATAscender
| Bool
isSingle -> (Double
ph forall a. Num a => a -> a -> a
- Double
asc) forall a. Fractional a => a -> a -> a
/ Double
2
AlignTV
ATLowerX
| Bool
isSingle -> (Double
ph forall a. Num a => a -> a -> a
- Double
lowerX) forall a. Fractional a => a -> a -> a
/ Double
2 forall a. Num a => a -> a -> a
- (Double
asc forall a. Num a => a -> a -> a
- Double
lowerX)
AlignTV
ATBottom -> Double
ph forall a. Num a => a -> a -> a
- Double
th
AlignTV
ATBaseline -> Double
ph forall a. Num a => a -> a -> a
- Double
th
AlignTV
_ -> (Double
ph forall a. Num a => a -> a -> a
- Double
th) forall a. Fractional a => a -> a -> a
/ Double
2
offsetY :: Double
offsetY = Double
py forall a. Num a => a -> a -> a
+ Double
alignOffsetY
newTextLines :: Seq TextLine
newTextLines = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Rect -> Double -> AlignTH -> TextLine -> TextLine
alignTextLine Rect
parentRect Double
offsetY AlignTH
alignH) Seq TextLine
textLines
moveTextLines
:: Point
-> Seq TextLine
-> Seq TextLine
moveTextLines :: Point -> Seq TextLine -> Seq TextLine
moveTextLines (Point Double
offsetX Double
offsetY) Seq TextLine
textLines = Seq TextLine
newTextLines where
moveTextLine :: b -> b
moveTextLine b
tl = b
tl
forall a b. a -> (a -> b) -> b
& forall s a. HasRect s a => Lens' s a
L.rect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasX s a => Lens' s a
L.x forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Double
offsetX
forall a b. a -> (a -> b) -> b
& forall s a. HasRect s a => Lens' s a
L.rect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasY s a => Lens' s a
L.y forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Double
offsetY
newTextLines :: Seq TextLine
newTextLines = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {b} {a}.
(HasRect b a, HasX a Double, HasY a Double) =>
b -> b
moveTextLine Seq TextLine
textLines
getTextLinesSize :: Seq TextLine -> Size
getTextLinesSize :: Seq TextLine -> Size
getTextLinesSize Seq TextLine
textLines = Size
size where
spaceV :: Double
spaceV = FontSpace -> Double
unFontSpace forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Default a => a
def TextLine -> FontSpace
_tlFontSpaceV (Seq TextLine
textLines forall s a. s -> Getting (First a) s a -> Maybe a
^? forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
0)
lineW :: s -> a
lineW s
line = s
line forall s a. s -> Getting a s a -> a
^. forall s a. HasSize s a => Lens' s a
L.size forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasW s a => Lens' s a
L.w
lineH :: TextLine -> Double
lineH TextLine
line = TextLine
line forall s a. s -> Getting a s a -> a
^. forall s a. HasSize s a => Lens' s a
L.size forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasH s a => Lens' s a
L.h forall a. Num a => a -> a -> a
+ FontSpace -> Double
unFontSpace (TextLine -> FontSpace
_tlFontSpaceV TextLine
line)
~Double
width = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {s} {a} {a}. (HasSize s a, HasW a a) => s -> a
lineW Seq TextLine
textLines)
height :: Double
height = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TextLine -> Double
lineH Seq TextLine
textLines) forall a. Num a => a -> a -> a
- Double
spaceV
size :: Size
size
| forall a. Seq a -> Bool
Seq.null Seq TextLine
textLines = forall a. Default a => a
def
| Bool
otherwise = Double -> Double -> Size
Size Double
width Double
height
getGlyphsMin :: Seq GlyphPos -> Double
getGlyphsMin :: Seq GlyphPos -> Double
getGlyphsMin Seq GlyphPos
Empty = Double
0
getGlyphsMin (GlyphPos
g :<| Seq GlyphPos
gs) = GlyphPos -> Double
_glpXMin GlyphPos
g
getGlyphsMax :: Seq GlyphPos -> Double
getGlyphsMax :: Seq GlyphPos -> Double
getGlyphsMax Seq GlyphPos
Empty = Double
0
getGlyphsMax (Seq GlyphPos
gs :|> GlyphPos
g) = GlyphPos -> Double
_glpXMax GlyphPos
g
alignTextLine :: Rect -> Double -> AlignTH -> TextLine -> TextLine
alignTextLine :: Rect -> Double -> AlignTH -> TextLine -> TextLine
alignTextLine Rect
parentRect Double
offsetY AlignTH
alignH TextLine
textLine = TextLine
newTextLine where
Rect Double
px Double
_ Double
pw Double
_ = Rect
parentRect
Rect Double
tx Double
ty Double
tw Double
th = TextLine -> Rect
_tlRect TextLine
textLine
alignOffsetX :: Double
alignOffsetX = case AlignTH
alignH of
AlignTH
ATLeft -> Double
0
AlignTH
ATCenter -> (Double
pw forall a. Num a => a -> a -> a
- Double
tw) forall a. Fractional a => a -> a -> a
/ Double
2
AlignTH
ATRight -> Double
pw forall a. Num a => a -> a -> a
- Double
tw
offsetX :: Double
offsetX = Double
px forall a. Num a => a -> a -> a
+ Double
alignOffsetX
newTextLine :: TextLine
newTextLine = TextLine
textLine {
_tlRect :: Rect
_tlRect = Double -> Double -> Double -> Double -> Rect
Rect (Double
tx forall a. Num a => a -> a -> a
+ Double
offsetX) (Double
ty forall a. Num a => a -> a -> a
+ Double
offsetY) Double
tw Double
th
}
fitLinesToH
:: FontManager
-> StyleState
-> TextOverflow
-> Double
-> Double
-> Seq TextLine
-> Seq TextLine
fitLinesToH :: FontManager
-> StyleState
-> TextOverflow
-> Double
-> Double
-> Seq TextLine
-> Seq TextLine
fitLinesToH FontManager
fontMgr StyleState
style TextOverflow
overflow Double
w Double
h Seq TextLine
Empty = forall a. Seq a
Empty
fitLinesToH FontManager
fontMgr StyleState
style TextOverflow
overflow Double
w Double
h (TextLine
g1 :<| TextLine
g2 :<| Seq TextLine
gs)
| TextOverflow
overflow forall a. Eq a => a -> a -> Bool
== TextOverflow
Ellipsis Bool -> Bool -> Bool
&& Double
h forall a. Ord a => a -> a -> Bool
>= Double
g1H forall a. Num a => a -> a -> a
+ Double
g2H = TextLine
g1 forall a. a -> Seq a -> Seq a
:<| Seq TextLine
rest
| TextOverflow
overflow forall a. Eq a => a -> a -> Bool
== TextOverflow
Ellipsis Bool -> Bool -> Bool
&& Double
h forall a. Ord a => a -> a -> Bool
>= Double
g1H = forall a. a -> Seq a
Seq.singleton TextLine
ellipsisG1
| TextOverflow
overflow forall a. Eq a => a -> a -> Bool
== TextOverflow
ClipText Bool -> Bool -> Bool
&& Double
h forall a. Ord a => a -> a -> Bool
>= Double
g1H = TextLine
g1 forall a. a -> Seq a -> Seq a
:<| Seq TextLine
rest
where
g1H :: Double
g1H = Size -> Double
_sH (TextLine -> Size
_tlSize TextLine
g1)
g2H :: Double
g2H = Size -> Double
_sH (TextLine -> Size
_tlSize TextLine
g2)
newH :: Double
newH = Double
h forall a. Num a => a -> a -> a
- Double
g1H
rest :: Seq TextLine
rest = FontManager
-> StyleState
-> TextOverflow
-> Double
-> Double
-> Seq TextLine
-> Seq TextLine
fitLinesToH FontManager
fontMgr StyleState
style TextOverflow
overflow Double
w Double
newH (TextLine
g2 forall a. a -> Seq a -> Seq a
:<| Seq TextLine
gs)
ellipsisG1 :: TextLine
ellipsisG1 = FontManager -> StyleState -> Double -> TextLine -> TextLine
addEllipsisToTextLine FontManager
fontMgr StyleState
style Double
w TextLine
g1
fitLinesToH FontManager
fontMgr StyleState
style TextOverflow
overflow Double
w Double
h (TextLine
g :<| Seq TextLine
gs)
| Double
h forall a. Ord a => a -> a -> Bool
> Double
0 = forall a. a -> Seq a
Seq.singleton TextLine
newG
| Bool
otherwise = forall a. Seq a
Empty
where
gW :: Double
gW = Size -> Double
_sW (TextLine -> Size
_tlSize TextLine
g)
newG :: TextLine
newG
| TextOverflow
overflow forall a. Eq a => a -> a -> Bool
== TextOverflow
Ellipsis Bool -> Bool -> Bool
&& Double
w forall a. Ord a => a -> a -> Bool
< Double
gW = FontManager -> StyleState -> Double -> TextLine -> TextLine
addEllipsisToTextLine FontManager
fontMgr StyleState
style Double
w TextLine
g
| Bool
otherwise = TextLine
g
fitLineToW
:: FontManager
-> Font
-> FontSize
-> FontSpace
-> FontSpace
-> TextMetrics
-> LineBreak
-> Double
-> Double
-> TextTrim
-> Text
-> Seq TextLine
fitLineToW :: FontManager
-> Font
-> FontSize
-> FontSpace
-> FontSpace
-> TextMetrics
-> LineBreak
-> Double
-> Double
-> TextTrim
-> Text
-> Seq TextLine
fitLineToW FontManager
fontMgr Font
font FontSize
fSize FontSpace
fSpcH FontSpace
fSpcV TextMetrics
metrics LineBreak
break Double
top Double
width TextTrim
trim Text
text = Seq TextLine
res where
spaces :: Text
spaces = Int -> Text -> Text
T.replicate Int
4 Text
" "
newText :: Text
newText = Text -> Text -> Text -> Text
T.replace Text
"\t" Text
spaces Text
text
!glyphs :: Seq GlyphPos
glyphs = FontManager
-> Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeGlyphsPos FontManager
fontMgr Font
font FontSize
fSize FontSpace
fSpcH Text
newText
keepTailSpaces :: Bool
keepTailSpaces = TextTrim
trim forall a. Eq a => a -> a -> Bool
== TextTrim
TrimSpaces
groups :: Seq (Seq GlyphPos)
groups
| LineBreak
break forall a. Eq a => a -> a -> Bool
== LineBreak
OnCharacters = LineBreak -> Double -> Seq GlyphPos -> Seq (Seq GlyphPos)
splitGroups LineBreak
break Double
width Seq GlyphPos
glyphs
| Bool
otherwise = Seq (Seq GlyphPos) -> Double -> Bool -> Seq (Seq GlyphPos)
fitGroups (LineBreak -> Double -> Seq GlyphPos -> Seq (Seq GlyphPos)
splitGroups LineBreak
break Double
width Seq GlyphPos
glyphs) Double
width Bool
keepTailSpaces
resetGroups :: Seq (Seq GlyphPos)
resetGroups
| TextTrim
trim forall a. Eq a => a -> a -> Bool
== TextTrim
TrimSpaces = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Seq GlyphPos -> Seq GlyphPos
trimGlyphs Seq (Seq GlyphPos)
groups
| Bool
otherwise = Seq (Seq GlyphPos)
groups
buildLine :: Int -> Seq GlyphPos -> TextLine
buildLine = Font
-> FontSize
-> FontSpace
-> FontSpace
-> TextMetrics
-> Double
-> Int
-> Seq GlyphPos
-> TextLine
buildTextLine Font
font FontSize
fSize FontSpace
fSpcH FontSpace
fSpcV TextMetrics
metrics Double
top
res :: Seq TextLine
res
| Text
text forall a. Eq a => a -> a -> Bool
/= Text
"" = forall a b. (Int -> a -> b) -> Seq a -> Seq b
Seq.mapWithIndex Int -> Seq GlyphPos -> TextLine
buildLine Seq (Seq GlyphPos)
resetGroups
| Bool
otherwise = forall a. a -> Seq a
Seq.singleton (Int -> Seq GlyphPos -> TextLine
buildLine Int
0 forall a. Seq a
Empty)
buildTextLine
:: Font
-> FontSize
-> FontSpace
-> FontSpace
-> TextMetrics
-> Double
-> Int
-> Seq GlyphPos
-> TextLine
buildTextLine :: Font
-> FontSize
-> FontSpace
-> FontSpace
-> TextMetrics
-> Double
-> Int
-> Seq GlyphPos
-> TextLine
buildTextLine Font
font FontSize
fSize FontSpace
fSpcH FontSpace
fSpcV TextMetrics
metrics Double
top Int
idx Seq GlyphPos
glyphs = TextLine
textLine where
lineH :: Double
lineH = TextMetrics -> Double
_txmLineH TextMetrics
metrics
x :: Double
x = Double
0
y :: Double
y = Double
top forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
idx forall a. Num a => a -> a -> a
* (Double
lineH forall a. Num a => a -> a -> a
+ FontSpace -> Double
unFontSpace FontSpace
fSpcV)
width :: Double
width = Seq GlyphPos -> Double
getGlyphsWidth Seq GlyphPos
glyphs
height :: Double
height = Double
lineH
text :: Text
text = [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\[Char]
ac GlyphPos
g -> GlyphPos -> Char
_glpGlyph GlyphPos
g forall a. a -> [a] -> [a]
: [Char]
ac) [] Seq GlyphPos
glyphs
textLine :: TextLine
textLine = TextLine {
_tlFont :: Font
_tlFont = Font
font,
_tlFontSize :: FontSize
_tlFontSize = FontSize
fSize,
_tlFontSpaceH :: FontSpace
_tlFontSpaceH = FontSpace
fSpcH,
_tlFontSpaceV :: FontSpace
_tlFontSpaceV = FontSpace
fSpcV,
_tlMetrics :: TextMetrics
_tlMetrics = TextMetrics
metrics,
_tlText :: Text
_tlText = Text
text,
_tlSize :: Size
_tlSize = Double -> Double -> Size
Size Double
width Double
height,
_tlRect :: Rect
_tlRect = Double -> Double -> Double -> Double -> Rect
Rect Double
x Double
y Double
width Double
height,
_tlGlyphs :: Seq GlyphPos
_tlGlyphs = Seq GlyphPos
glyphs
}
addEllipsisToTextLine
:: FontManager
-> StyleState
-> Double
-> TextLine
-> TextLine
addEllipsisToTextLine :: FontManager -> StyleState -> Double -> TextLine -> TextLine
addEllipsisToTextLine FontManager
fontMgr StyleState
style Double
width TextLine
textLine = TextLine
newTextLine where
TextLine{Text
Seq GlyphPos
Rect
Size
TextMetrics
FontSpace
FontSize
Font
_tlGlyphs :: Seq GlyphPos
_tlRect :: Rect
_tlSize :: Size
_tlText :: Text
_tlMetrics :: TextMetrics
_tlFontSpaceV :: FontSpace
_tlFontSpaceH :: FontSpace
_tlFontSize :: FontSize
_tlFont :: Font
_tlGlyphs :: TextLine -> Seq GlyphPos
_tlText :: TextLine -> Text
_tlMetrics :: TextLine -> TextMetrics
_tlFontSpaceH :: TextLine -> FontSpace
_tlFontSize :: TextLine -> FontSize
_tlFont :: TextLine -> Font
_tlSize :: TextLine -> Size
_tlRect :: TextLine -> Rect
_tlFontSpaceV :: TextLine -> FontSpace
..} = TextLine
textLine
Size Double
tw Double
th = Size
_tlSize
Size Double
dw Double
dh = FontManager -> StyleState -> Text -> Size
calcTextSize FontManager
fontMgr StyleState
style Text
"..."
font :: Font
font = StyleState -> Font
styleFont StyleState
style
fontSize :: FontSize
fontSize = StyleState -> FontSize
styleFontSize StyleState
style
fontSpcH :: FontSpace
fontSpcH = StyleState -> FontSpace
styleFontSpaceH StyleState
style
targetW :: Double
targetW = Double
width forall a. Num a => a -> a -> a
- Double
tw
dropHelper :: (a, Double) -> GlyphPos -> (a, Double)
dropHelper (a
idx, Double
w) GlyphPos
g
| Double -> Double -> Bool
isSafeLE (GlyphPos -> Double
_glpW GlyphPos
g forall a. Num a => a -> a -> a
+ Double
w) Double
dw = (a
idx forall a. Num a => a -> a -> a
+ a
1, GlyphPos -> Double
_glpW GlyphPos
g forall a. Num a => a -> a -> a
+ Double
w)
| Bool
otherwise = (a
idx, Double
w)
(Int
dropChars, Double
_) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. Num a => (a, Double) -> GlyphPos -> (a, Double)
dropHelper (Int
0, Double
targetW) (forall a. Seq a -> Seq a
Seq.reverse Seq GlyphPos
_tlGlyphs)
newText :: Text
newText = Int -> Text -> Text
T.dropEnd Int
dropChars Text
_tlText forall a. Semigroup a => a -> a -> a
<> Text
"..."
!newGlyphs :: Seq GlyphPos
newGlyphs = FontManager
-> Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeGlyphsPos FontManager
fontMgr Font
font FontSize
fontSize FontSpace
fontSpcH Text
newText
newW :: Double
newW = Seq GlyphPos -> Double
getGlyphsWidth Seq GlyphPos
newGlyphs
newTextLine :: TextLine
newTextLine = TextLine
textLine {
_tlText :: Text
_tlText = Text
newText,
_tlSize :: Size
_tlSize = Size
_tlSize { _sW :: Double
_sW = Double
newW },
_tlRect :: Rect
_tlRect = Rect
_tlRect { _rW :: Double
_rW = Double
newW },
_tlGlyphs :: Seq GlyphPos
_tlGlyphs = Seq GlyphPos
newGlyphs
}
clipTextLine
:: FontManager
-> StyleState
-> TextTrim
-> Double
-> TextLine
-> TextLine
clipTextLine :: FontManager
-> StyleState -> TextTrim -> Double -> TextLine -> TextLine
clipTextLine FontManager
fontMgr StyleState
style TextTrim
trim Double
width TextLine
textLine = TextLine
newTextLine where
TextLine{Text
Seq GlyphPos
Rect
Size
TextMetrics
FontSpace
FontSize
Font
_tlGlyphs :: Seq GlyphPos
_tlRect :: Rect
_tlSize :: Size
_tlText :: Text
_tlMetrics :: TextMetrics
_tlFontSpaceV :: FontSpace
_tlFontSpaceH :: FontSpace
_tlFontSize :: FontSize
_tlFont :: Font
_tlGlyphs :: TextLine -> Seq GlyphPos
_tlText :: TextLine -> Text
_tlMetrics :: TextLine -> TextMetrics
_tlFontSpaceH :: TextLine -> FontSpace
_tlFontSize :: TextLine -> FontSize
_tlFont :: TextLine -> Font
_tlSize :: TextLine -> Size
_tlRect :: TextLine -> Rect
_tlFontSpaceV :: TextLine -> FontSpace
..} = TextLine
textLine
Size Double
tw Double
th = Size
_tlSize
font :: Font
font = StyleState -> Font
styleFont StyleState
style
fontSize :: FontSize
fontSize = StyleState -> FontSize
styleFontSize StyleState
style
fontSpcH :: FontSpace
fontSpcH = StyleState -> FontSpace
styleFontSpaceH StyleState
style
takeHelper :: (a, Double) -> GlyphPos -> (a, Double)
takeHelper (a
idx, Double
w) GlyphPos
g
| Double -> Double -> Bool
isSafeLE (GlyphPos -> Double
_glpW GlyphPos
g forall a. Num a => a -> a -> a
+ Double
w) Double
width = (a
idx forall a. Num a => a -> a -> a
+ a
1, GlyphPos -> Double
_glpW GlyphPos
g forall a. Num a => a -> a -> a
+ Double
w)
| Bool
otherwise = (a
idx, Double
w)
(Integer
takeChars, Double
_) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. Num a => (a, Double) -> GlyphPos -> (a, Double)
takeHelper (Integer
0, Double
0) Seq GlyphPos
_tlGlyphs
validGlyphs :: Seq GlyphPos
validGlyphs = forall a. (a -> Bool) -> Seq a -> Seq a
Seq.takeWhileL (\GlyphPos
g -> Double -> Double -> Bool
isSafeLE (GlyphPos -> Double
_glpXMax GlyphPos
g) Double
width) Seq GlyphPos
_tlGlyphs
newText :: Text
newText
| TextTrim
trim forall a. Eq a => a -> a -> Bool
== TextTrim
KeepSpaces = Int -> Text -> Text
T.take (forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq GlyphPos
validGlyphs) Text
_tlText
| Bool
otherwise = (Char -> Bool) -> Text -> Text
T.dropWhileEnd (forall a. Eq a => a -> a -> Bool
== Char
' ') forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.take (forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq GlyphPos
validGlyphs) Text
_tlText
!newGlyphs :: Seq GlyphPos
newGlyphs = FontManager
-> Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeGlyphsPos FontManager
fontMgr Font
font FontSize
fontSize FontSpace
fontSpcH Text
newText
newW :: Double
newW = Seq GlyphPos -> Double
getGlyphsWidth Seq GlyphPos
newGlyphs
newTextLine :: TextLine
newTextLine = TextLine
textLine {
_tlText :: Text
_tlText = Text
newText,
_tlSize :: Size
_tlSize = Size
_tlSize { _sW :: Double
_sW = Double
newW },
_tlRect :: Rect
_tlRect = Rect
_tlRect { _rW :: Double
_rW = Double
newW },
_tlGlyphs :: Seq GlyphPos
_tlGlyphs = Seq GlyphPos
newGlyphs
}
fitGroups :: Seq GlyphGroup -> Double -> Bool -> Seq GlyphGroup
fitGroups :: Seq (Seq GlyphPos) -> Double -> Bool -> Seq (Seq GlyphPos)
fitGroups Seq (Seq GlyphPos)
Empty Double
_ Bool
_ = forall a. Seq a
Empty
fitGroups (Seq GlyphPos
g :<| Seq (Seq GlyphPos)
gs) !Double
width !Bool
keepTailSpaces = Seq GlyphPos
currentLine forall a. a -> Seq a -> Seq a
<| Seq (Seq GlyphPos)
extraLines where
gW :: Double
gW = Seq GlyphPos -> Double
getGlyphsWidth Seq GlyphPos
g
gMax :: Double
gMax = Seq GlyphPos -> Double
getGlyphsMax Seq GlyphPos
g
extraGroups :: (Seq GlyphPos, Seq (Seq GlyphPos))
extraGroups = Seq (Seq GlyphPos)
-> Double -> Double -> Bool -> (Seq GlyphPos, Seq (Seq GlyphPos))
fitExtraGroups Seq (Seq GlyphPos)
gs (Double
width forall a. Num a => a -> a -> a
- Double
gW) Double
gMax Bool
keepTailSpaces
(Seq GlyphPos
lineGroups, Seq (Seq GlyphPos)
remainingGroups) = (Seq GlyphPos, Seq (Seq GlyphPos))
extraGroups
currentLine :: Seq GlyphPos
currentLine = Seq GlyphPos
g forall a. Semigroup a => a -> a -> a
<> Seq GlyphPos
lineGroups
extraLines :: Seq (Seq GlyphPos)
extraLines = Seq (Seq GlyphPos) -> Double -> Bool -> Seq (Seq GlyphPos)
fitGroups Seq (Seq GlyphPos)
remainingGroups Double
width Bool
keepTailSpaces
fitExtraGroups
:: Seq GlyphGroup
-> Double
-> Double
-> Bool
-> (Seq GlyphPos, Seq GlyphGroup)
Seq (Seq GlyphPos)
Empty Double
_ Double
_ Bool
_ = (forall a. Seq a
Empty, forall a. Seq a
Empty)
fitExtraGroups (Seq GlyphPos
g :<| Seq (Seq GlyphPos)
gs) !Double
width !Double
prevGMax !Bool
keepTailSpaces
| Double -> Double -> Bool
isSafeLE (Double
gW forall a. Num a => a -> a -> a
+ Double
wDiff) Double
width Bool -> Bool -> Bool
|| Bool
keepSpace = (Seq GlyphPos
g forall a. Semigroup a => a -> a -> a
<> Seq GlyphPos
newFit, Seq (Seq GlyphPos)
newRest)
| Bool
otherwise = (forall a. Seq a
Empty, Seq GlyphPos
g forall a. a -> Seq a -> Seq a
:<| Seq (Seq GlyphPos)
gs)
where
gW :: Double
gW = Seq GlyphPos -> Double
getGlyphsWidth Seq GlyphPos
g
gMin :: Double
gMin = Seq GlyphPos -> Double
getGlyphsMin Seq GlyphPos
g
gMax :: Double
gMax = Seq GlyphPos -> Double
getGlyphsMax Seq GlyphPos
g
wDiff :: Double
wDiff = Double
gMin forall a. Num a => a -> a -> a
- Double
prevGMax
remWidth :: Double
remWidth = Double
width forall a. Num a => a -> a -> a
- (Double
gW forall a. Num a => a -> a -> a
+ Double
wDiff)
keepSpace :: Bool
keepSpace = Bool
keepTailSpaces Bool -> Bool -> Bool
&& Seq GlyphPos -> Bool
isSpaceGroup Seq GlyphPos
g
(Seq GlyphPos
newFit, Seq (Seq GlyphPos)
newRest) = Seq (Seq GlyphPos)
-> Double -> Double -> Bool -> (Seq GlyphPos, Seq (Seq GlyphPos))
fitExtraGroups Seq (Seq GlyphPos)
gs Double
remWidth Double
gMax Bool
keepTailSpaces
getGlyphsWidth :: Seq GlyphPos -> Double
getGlyphsWidth :: Seq GlyphPos -> Double
getGlyphsWidth Seq GlyphPos
glyphs = Seq GlyphPos -> Double
getGlyphsMax Seq GlyphPos
glyphs forall a. Num a => a -> a -> a
- Seq GlyphPos -> Double
getGlyphsMin Seq GlyphPos
glyphs
isSpaceGroup :: Seq GlyphPos -> Bool
isSpaceGroup :: Seq GlyphPos -> Bool
isSpaceGroup Seq GlyphPos
Empty = Bool
False
isSpaceGroup (GlyphPos
g :<| Seq GlyphPos
gs) = Char -> Bool
isSpace (GlyphPos -> Char
_glpGlyph GlyphPos
g)
splitGroups :: LineBreak -> Double -> Seq GlyphPos -> Seq GlyphGroup
splitGroups :: LineBreak -> Double -> Seq GlyphPos -> Seq (Seq GlyphPos)
splitGroups LineBreak
_ Double
_ Seq GlyphPos
Empty = forall a. Seq a
Empty
splitGroups LineBreak
break Double
width Seq GlyphPos
glyphs = Seq GlyphPos
group forall a. a -> Seq a -> Seq a
<| LineBreak -> Double -> Seq GlyphPos -> Seq (Seq GlyphPos)
splitGroups LineBreak
break Double
width Seq GlyphPos
rest where
GlyphPos
g :<| Seq GlyphPos
gs = Seq GlyphPos
glyphs
groupWordFn :: GlyphPos -> Bool
groupWordFn = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isWordDelimiter forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlyphPos -> Char
_glpGlyph
groupWidthFn :: GlyphPos -> Bool
groupWidthFn GlyphPos
g2 = GlyphPos -> Double
_glpXMax GlyphPos
g2 forall a. Num a => a -> a -> a
- GlyphPos -> Double
_glpXMin GlyphPos
g forall a. Ord a => a -> a -> Bool
<= Double
width
atWord :: Bool
atWord = LineBreak
break forall a. Eq a => a -> a -> Bool
== LineBreak
OnSpaces
(Seq GlyphPos
group, Seq GlyphPos
rest)
| Bool
atWord Bool -> Bool -> Bool
&& Char -> Bool
isWordDelimiter (GlyphPos -> Char
_glpGlyph GlyphPos
g) = (forall a. a -> Seq a
Seq.singleton GlyphPos
g, Seq GlyphPos
gs)
| Bool
atWord = forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
Seq.spanl GlyphPos -> Bool
groupWordFn Seq GlyphPos
glyphs
| Bool
otherwise = forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
Seq.spanl GlyphPos -> Bool
groupWidthFn Seq GlyphPos
glyphs
trimGlyphs :: Seq GlyphPos -> Seq GlyphPos
trimGlyphs :: Seq GlyphPos -> Seq GlyphPos
trimGlyphs Seq GlyphPos
glyphs = Seq GlyphPos
newGlyphs where
isSpaceGlyph :: GlyphPos -> Bool
isSpaceGlyph GlyphPos
g = GlyphPos -> Char
_glpGlyph GlyphPos
g forall a. Eq a => a -> a -> Bool
== Char
' '
newGlyphs :: Seq GlyphPos
newGlyphs = forall a. (a -> Bool) -> Seq a -> Seq a
Seq.dropWhileL GlyphPos -> Bool
isSpaceGlyph forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> Seq a -> Seq a
Seq.dropWhileR GlyphPos -> Bool
isSpaceGlyph Seq GlyphPos
glyphs
isWordDelimiter :: Char -> Bool
isWordDelimiter :: Char -> Bool
isWordDelimiter = (forall a. Eq a => a -> a -> Bool
== Char
' ')
isSpace :: Char -> Bool
isSpace :: Char -> Bool
isSpace = (forall a. Eq a => a -> a -> Bool
== Char
' ')
isSafeLE :: Double -> Double -> Bool
isSafeLE :: Double -> Double -> Bool
isSafeLE Double
width Double
target = Double
width forall a. Ord a => a -> a -> Bool
<= Double
target Bool -> Bool -> Bool
|| forall a. Num a => a -> a
abs (Double
target forall a. Num a => a -> a -> a
- Double
width) forall a. Ord a => a -> a -> Bool
< Double
0.001