module Graphics.PDF.Typesetting.Breaking (
Letter(..)
, formatList
, infinity
, createChar
, kernBox
, glueBox
, penalty
, spaceGlueBox
, hyphenPenalty
, splitText
, MaybeGlue(..)
, defaultBreakingSettings
, BRState(..)
, glueSize
, mkLetter
, spaceWidth
, centeredDilatationFactor
, leftDilatationFactor
, rightDilatationFactor
, dilatationRatio
, badness
, bigAdjustRatio
, Justification(..)
, simplify
) where
import Graphics.PDF.LowLevel.Types
import Data.List(minimumBy)
import qualified Data.Map as Map
import Graphics.PDF.Text
import Graphics.PDF.Typesetting.Box
import Data.Maybe(fromJust)
import Graphics.PDF.Hyphenate
data Justification = FullJustification
| Centered
| LeftJustification
| RightJustification
deriving(Eq)
mkLetter :: (Show a, Box a, DisplayableBox a) => BoxDimension
-> Maybe s
-> a
-> Letter s
mkLetter d s a = Letter d (AnyBox a) s
data Letter s = Letter BoxDimension !AnyBox !(Maybe s)
| Glue !PDFFloat !PDFFloat !PDFFloat !(Maybe s)
| FlaggedPenalty !PDFFloat !Int !s
| Penalty !Int
| AChar !s !Char !PDFFloat
| Kern !PDFFloat !(Maybe s)
class MaybeGlue a where
glueY :: a -> PDFFloat
glueZ :: a -> PDFFloat
glueSizeWithRatio :: a -> PDFFloat -> PDFFloat
instance MaybeGlue (Letter s) where
glueSizeWithRatio = letterWidth
glueY (Glue _ y _ _) = y
glueY _ = 0
glueZ (Glue _ _ z _) = z
glueZ _ = 0
glueSize :: PDFFloat -> PDFFloat -> PDFFloat -> PDFFloat -> PDFFloat
glueSize w y z r =
if r >= 0
then
r*y + w
else
r*z + w
letterWidth :: Letter s
-> PDFFloat
-> PDFFloat
letterWidth (AChar _ _ w) _ = w
letterWidth (Letter dim _ _) _ = boxWidth dim
letterWidth (Glue w yi zi _) r = glueSize w yi zi r
letterWidth (FlaggedPenalty _ _ _) _ = 0
letterWidth (Penalty _) _ = 0
letterWidth (Kern w _) _ = w
instance Show (Letter s) where
show (Letter _ a _) = "(Letter " ++ show a ++ ")"
show (Glue a b c _) = "(Glue " ++ show a ++ " " ++ show b ++ " " ++ show c ++ ")"
show (FlaggedPenalty a b _) = "(FlaggedPenalty " ++ show a ++ " " ++ show b ++ ")"
show (Penalty a) = "(Penalty " ++ show a ++ ")"
show (AChar _ t _) = "(Text " ++ show t ++ ")"
show (Kern _ _) = "(Kern)"
type CB a = (PDFFloat,PDFFloat,PDFFloat,Int,a)
class PointedBox s a | a -> s where
isFlagged :: a -> Bool
getPenalty :: a -> Int
isPenalty :: a -> Bool
letter :: a -> Letter s
position :: a -> Int
cumulatedW :: a -> PDFFloat
cumulatedY :: a -> PDFFloat
cumulatedZ :: a -> PDFFloat
isForcedBreak :: a -> Bool
instance PointedBox s (PDFFloat,PDFFloat,PDFFloat,Int,Letter s) where
isFlagged (_,_,_,_,FlaggedPenalty _ _ _) = True
isFlagged _ = False
isPenalty (_,_,_,_,FlaggedPenalty _ _ _) = True
isPenalty (_,_,_,_,Penalty _) = True
isPenalty _ = False
getPenalty (_,_,_,_,FlaggedPenalty _ p _) = p
getPenalty (_,_,_,_,Penalty p) = p
getPenalty _ = 0
letter (_,_,_,_,a) = a
position (_,_,_,p,_) = p
cumulatedW (w,_,_,_,_) = w
cumulatedY (_,y,_,_,_) = y
cumulatedZ (_,_,z,_,_) = z
isForcedBreak (_,_,_,_,FlaggedPenalty _ p _) = p <= (infinity)
isForcedBreak (_,_,_,_,Penalty p) = p <= (infinity)
isForcedBreak _ = False
instance PointedBox s (ZList s) where
isPenalty (ZList _ b _) = isPenalty b
isFlagged (ZList _ b _) = isFlagged b
letter (ZList _ b _) = letter b
position (ZList _ b _) = position b
cumulatedW (ZList _ b _) = cumulatedW b
cumulatedY (ZList _ b _) = cumulatedY b
cumulatedZ (ZList _ b _) = cumulatedZ b
getPenalty (ZList _ b _) = getPenalty b
isForcedBreak (ZList _ b _) = isForcedBreak b
penaltyWidth :: Letter s -> PDFFloat
penaltyWidth (FlaggedPenalty w _ _) = w
penaltyWidth _ = 0
data BreakNode =
BreakNode { totalWidth :: !PDFFloat
, totalDilatation :: !PDFFloat
, totalCompression :: !PDFFloat
, demerit :: !PDFFloat
, flagged :: !Bool
, fitnessValue :: !Int
, ratio :: !PDFFloat
, previous :: Maybe (Int,Int,Int,BreakNode)
}
deriving(Show)
dilatationRatio :: PDFFloat
-> PDFFloat
-> PDFFloat
-> PDFFloat
-> PDFFloat
dilatationRatio maxw w y z =
if w == maxw
then 0.0
else if w < maxw
then
if y > 0.0 then ((maxw w) / y) else bigAdjustRatio
else
if z > 0.0 then ((maxw w) / z) else bigAdjustRatio
adjustRatio :: BreakNode
-> ZList s
-> PDFFloat
-> PDFFloat
adjustRatio a l maxw =
let w = cumulatedW l totalWidth a + penaltyWidth (letter l)
y = cumulatedY l totalDilatation a
z = cumulatedZ l totalCompression a
in
dilatationRatio maxw w y z
badness :: PDFFloat -> PDFFloat
badness r = if r < (1) then bigAdjustRatio else 100.0 * abs(r)**3.0
fitness :: PDFFloat -> Int
fitness r =
if r < (0.5)
then
0
else if r <= (0.5)
then
1
else
if r <= 1
then
2
else
3
data BRState = BRState { firstPassTolerance :: !PDFFloat
, secondPassTolerance :: !PDFFloat
, hyphenPenaltyValue :: !Int
, fitness_demerit :: !PDFFloat
, flagged_demerit :: !PDFFloat
, line_penalty :: !PDFFloat
, centered :: !Justification
, hyphenation :: !HyphenationDatabase
}
defaultBreakingSettings :: BRState
defaultBreakingSettings = BRState 100 100 50 1000 1000 10 FullJustification (English Nothing)
computeDemerit :: Bool
-> BRState
-> Bool
-> PDFFloat
-> BreakNode
-> ZList s
-> Maybe(PDFFloat,Int)
computeDemerit force settings sndPass r a z =
let b = badness r
p = getPenalty z
fitness' = fitness r
tolerance = if sndPass then (secondPassTolerance settings) else (firstPassTolerance settings)
in
if (b <= tolerance) || force
then
let fld = if isFlagged z && (flagged a) then (flagged_demerit settings) else 0.0
fid = if fitness' /= (fitnessValue a) then (fitness_demerit settings) else 0.0
dem = max 1000.0 $ if p >= 0
then
fid + fld + ((line_penalty settings) + b) ** 2.0 + (fromIntegral p) ** 2.0
else if p < 0 && p > (infinity)
then
fid + fld + ((line_penalty settings) + b) ** 2.0 (fromIntegral p)**2.0
else
fid + fld + ((line_penalty settings) + b) ** 2.0
in
Just (dem,fitness')
else
Nothing
data MaybeCB a = NoCB
| OneCB !(CB a)
deriving(Show)
data ZList s = ZList (MaybeCB (Letter s)) (PDFFloat,PDFFloat,PDFFloat,Int,Letter s) [Letter s] deriving(Show)
createZList :: [Letter s] -> ZList s
createZList [] = error "List cannot be empty to create a zipper"
createZList l = ZList NoCB (0,0,0,1,head l) (tail l)
theEnd :: ZList s -> Bool
theEnd (ZList _ _ []) = True
theEnd _ = False
createBreaknode :: Maybe (Int,Int,Int,BreakNode) -> ZList s -> BreakNode
createBreaknode prev a@(ZList _ (_,_,_,_,FlaggedPenalty _ _ _) []) = breakN prev True a
createBreaknode prev a@(ZList _ (_,_,_,_,Penalty _) []) = breakN prev False a
createBreaknode prev a@(ZList _ (_,_,_,_,Glue _ _ _ _) []) = breakN prev False a
createBreaknode prev a@(ZList _ (_,_,_,_,_) []) = breakN prev False a
createBreaknode prev a@(ZList _ (_,_,_,_,FlaggedPenalty _ p _) _) | p <= infinity = breakN prev True a
createBreaknode prev a@(ZList _ (_,_,_,_,Letter _ _ _) _) = breakN prev False a
createBreaknode prev a@(ZList _ (_,_,_,_,AChar _ _ _) _) = breakN prev False a
createBreaknode prev a@(ZList _ (_,_,_,_,Kern _ _) _) = breakN prev False a
createBreaknode prev z =
let BreakNode a b c d _ e f g = createBreaknode prev (moveRight z) in
BreakNode a b c d False e f g
breakN :: Maybe (Int,Int,Int,BreakNode) -> Bool -> ZList s -> BreakNode
breakN prev t a = let (w,y,z) = getDim a in BreakNode w y z 0.0 t 0 0.0 prev
getDim :: ZList s -> (PDFFloat,PDFFloat,PDFFloat)
getDim (ZList _ (w,y,z,_,Letter _ _ _) _) = (w,y,z)
getDim (ZList _ (w,y,z,_,AChar _ _ _) _) = (w,y,z)
getDim (ZList _ (w,y,z,_,Kern _ _) _) = (w,y,z)
getDim (ZList _ (w,y,z,_,_) []) = (w,y,z)
getDim a = if theEnd a then error "Can't find end of paragraph" else getDim (moveRight a)
moveRight :: ZList s -> ZList s
moveRight (ZList _ c@(w,y,z,p,Glue w' y' z' _) r) =
let w'' = w + w'
y''=y+y'
z''=z+z'
in
ZList (OneCB c) (w'',y'',z'',p+1,head r) (tail r)
moveRight (ZList _ c@(w,y,z,p,a) r) =
let w' = glueSizeWithRatio a 0.0
w'' = w + w'
in
ZList (OneCB c) (w'',y,z,p+1,head r) (tail r)
isFeasibleBreakpoint :: Bool
-> ZList s
-> Bool
isFeasibleBreakpoint True (ZList _ (_,_,_,_,FlaggedPenalty _ p _) _) = p < infinity
isFeasibleBreakpoint False (ZList _ (_,_,_,_,FlaggedPenalty _ _ _) _) = False
isFeasibleBreakpoint _ (ZList _ (_,_,_,_,Penalty p) _) = p < infinity
isFeasibleBreakpoint _ (ZList NoCB _ _) = False
isFeasibleBreakpoint _ (ZList (OneCB (_,_,_,_,Letter _ _ _)) (_,_,_,_,Glue _ _ _ _) _) = True
isFeasibleBreakpoint _ (ZList (OneCB (_,_,_,_,AChar _ _ _)) (_,_,_,_,Glue _ _ _ _) _) = True
isFeasibleBreakpoint _ _ = False
type PossibleBreak = ActiveNodes
type ActiveNodes = Map.Map (Int,Int,Int) BreakNode
updateBreak :: BreakNode
-> BreakNode
-> BreakNode
updateBreak a b = if demerit a < demerit b then a else b
updateWithNewRIfNoSolution :: Bool
-> PDFFloat
-> ZList s
-> (Int,Int,Int)
-> PossibleBreak
-> ActiveNodes
-> (Bool -> PDFFloat -> ActiveNodes -> (PossibleBreak,ActiveNodes))
-> (PossibleBreak,ActiveNodes)
updateWithNewRIfNoSolution sndPass r z key newbreak newmap f =
if isForcedBreak z
then
f True r (Map.delete key newmap)
else
if r < 1
then let m' = Map.delete key newmap
in
if Map.null m' && sndPass then f True (0.99) m' else (newbreak,m')
else
f False r newmap
getNewActiveBreakpoints :: BRState -> Bool -> (Int -> PDFFloat) -> ActiveNodes -> ZList s -> (PossibleBreak,ActiveNodes)
getNewActiveBreakpoints settings sndPass fmaxw actives z =
if isFeasibleBreakpoint sndPass z
then
let analyzeActive key@(p,line,f) b (newbreak,newmap') =
let r' = adjustRatio b z (fmaxw (line+1))
in
updateWithNewRIfNoSolution sndPass r' z key newbreak newmap' $
\force r newmap -> let dem' = computeDemerit force settings sndPass r b z in
case dem' of
Nothing -> (newbreak,newmap)
Just (d',f') ->
let b' = createBreaknode (Just (p,line,f,b)) z in
(Map.insertWith updateBreak (position z,line+1,f') (b' {demerit = d',fitnessValue = f', ratio = r}) newbreak ,newmap)
in
let (breaks',actives') = Map.foldWithKey analyzeActive (Map.empty,actives) actives
dmin = minimum . map demerit . Map.elems $ breaks'
nbreaks = Map.filter (\x -> demerit x < dmin + (fitness_demerit settings)) breaks'
in
if Map.null nbreaks
then
(breaks' , actives')
else
(nbreaks , actives')
else
(Map.empty,actives )
genNodeList :: (Int,Int,Int,BreakNode) -> [(PDFFloat,Int,Bool)]
genNodeList (p,_,_,b@(BreakNode _ _ _ _ f _ _ Nothing)) = [(ratio b,p,f)]
genNodeList (p,_,_,b@(BreakNode _ _ _ _ f _ _ (Just _))) = (ratio b,p,f):genNodeList (fromJust . previous $ b)
analyzeBoxes :: BRState -> Bool -> (Int -> PDFFloat) -> ActiveNodes -> ZList s -> ZList s -> [(PDFFloat,Int,Bool)]
analyzeBoxes settings pass fmaxw actives lastz z =
let getMinBreak b' = (\((xc,yc,zc),w) -> (xc,yc,zc,w)) . minimumBy (\(_,a) (_,b) -> compare (demerit a) (demerit b)) . Map.toList $ b'
(breaks',actives') = getNewActiveBreakpoints settings pass fmaxw actives z
newActives = Map.union (breaks') (actives')
getRightOrderNodeList = tail . reverse . genNodeList
getKey (a,b,c,_) = (a,b,c)
getNode (_,_,_,BreakNode a b c d e f r _) = BreakNode a b c d e f r Nothing
in
if Map.null actives'
then
if Map.null breaks'
then
if not pass
then
analyzeBoxes settings True fmaxw actives lastz lastz
else
error "Second pass analysis failed ! Generally due to wrong width in the text area or an end of text before end of paragraph detected"
else
let minBreak = getMinBreak breaks'
someNewBreaks = getRightOrderNodeList minBreak
in
if theEnd z
then
someNewBreaks
else
let z' = moveRight z in
someNewBreaks ++ analyzeBoxes settings pass fmaxw (Map.insert (getKey minBreak) (getNode minBreak) Map.empty) z' z'
else
if Map.null breaks'
then
if theEnd z
then
error "End of text found but no paragraph end detected"
else
analyzeBoxes settings pass fmaxw actives' lastz (moveRight z)
else
if theEnd z
then
let minBreak = getMinBreak breaks' in
getRightOrderNodeList minBreak
else
analyzeBoxes settings pass fmaxw newActives lastz (moveRight z)
hyphenBox :: Style s => s -> Letter s
hyphenBox s = AChar s '-' (charWidth (textFont . textStyle $ s) '-')
cutList :: Style s => Justification -> [Letter s] -> Int -> [(PDFFloat,Int,Bool)] -> [(PDFFloat,[Letter s],[Letter s])]
cutList _ [] _ _ = []
cutList _ t _ [] = [(0.0,[],t)]
cutList j t c ((ra,ba,fa):l) =
let (theLine,t') = splitAt (bac) t
in
if null theLine
then
[]
else
if null t'
then
[(ra,theLine,t)]
else
case head t' of
FlaggedPenalty _ _ s -> if not fa
then
error $ "Breakpoint marked as not flagged but detected as flagged ! Send a bug report ! " ++ show (ra,ba,fa)
else
(ra,theLine ++ hyphenForJustification j s,t) : cutList j t' ba l
_ -> if fa
then
error $ "Breakpoint marked as flagged but detected as not flagged ! Send a bug report ! " ++ show (ra,ba,fa) ++ " " ++ show theLine ++ " " ++ show t'
else
(ra,theLine,t) : cutList j t' ba l
formatList :: Style s => BRState -> (Int -> PDFFloat) -> [Letter s] -> [(PDFFloat,[Letter s],[Letter s])]
formatList settings maxw boxes =
let active = Map.insert (0,0,1) (BreakNode 0 0 0 0 False 0 0.0 Nothing) Map.empty
z = createZList boxes
theBreaks = analyzeBoxes settings False maxw active z z
in
cutList (centered settings) boxes 1 theBreaks
infinity :: Int
infinity = 10000
bigAdjustRatio :: PDFFloat
bigAdjustRatio = 10000.0
glueBox :: Maybe s
-> PDFFloat
-> PDFFloat
-> PDFFloat
-> Letter s
glueBox s w y z = Glue w y z s
spaceWidth :: Style s => s
-> PDFFloat
spaceWidth s =
let ws = (textWidth (textFont . textStyle $ s) (toPDFString " ") )
h = scaleSpace . textStyle $ s
in
ws * h
centeredDilatationFactor :: PDFFloat
centeredDilatationFactor = 10.0
leftDilatationFactor :: PDFFloat
leftDilatationFactor = 20.0
rightDilatationFactor :: PDFFloat
rightDilatationFactor = 20.0
spaceGlueBox :: Style s => BRState
-> s
-> PDFFloat
-> [Letter s]
spaceGlueBox settings s f =
let ws = (textWidth (textFont . textStyle $ s) (toPDFString " ") )
h = scaleSpace . textStyle $ s
sy = scaleDilatation . textStyle $ s
sz = scaleCompression . textStyle $ s
normalW = ws * h
in
case (centered settings) of
FullJustification -> [Glue (normalW) (normalW*sy/2.0*f) (normalW*sz/3.0) (Just s)]
Centered -> [ Glue 0 (centeredDilatationFactor*normalW) 0 (Just s)
, Penalty 0
, Glue (normalW) (2*centeredDilatationFactor*normalW) 0 (Just s)
, Kern 0 (Just s)
, Penalty infinity
, Glue 0 (centeredDilatationFactor*normalW) 0 (Just s)
]
LeftJustification -> [ Glue 0 (leftDilatationFactor*normalW) 0 (Just s)
, Penalty 0
, Glue normalW (leftDilatationFactor*normalW) 0 (Just s)
]
RightJustification -> [ Glue normalW (rightDilatationFactor*normalW) 0 (Just s)
, Kern 0 (Just s)
, Penalty infinity
, Glue 0 (rightDilatationFactor*normalW) 0 (Just s)
]
spaceSize :: Style s => s
-> PDFFloat
spaceSize s =
let ws = (textWidth (textFont . textStyle $ s) (toPDFString " ") )
h = scaleSpace . textStyle $ s
in ws * h
simplify :: [Letter s]
-> [Letter s]
simplify [] = []
simplify ((Glue _ _ _ _):l) = simplify l
simplify ((FlaggedPenalty _ _ _):l) = simplify l
simplify ((Penalty _):l) = simplify l
simplify l = l
hyphenForJustification :: Style s => Justification -> s -> [Letter s]
hyphenForJustification Centered s = [hyphenBox s,Glue 0 (centeredDilatationFactor*spaceSize s) 0 (Just s)]
hyphenForJustification LeftJustification s = [hyphenBox s,Glue 0 (leftDilatationFactor*spaceSize s) 0 (Just s)]
hyphenForJustification _ s = [hyphenBox s]
penalty :: Int
-> Letter s
penalty p = Penalty p
createChar :: s
-> PDFFloat
-> Char
-> Letter s
createChar s w t = AChar s t w
createLetterBoxes :: Style s => BRState
-> s
-> [(PDFFloat,Char)]
-> [Letter s]
createLetterBoxes _ _ [] = []
createLetterBoxes settings s ((_,'/'):(w,'-'):l) = hyphenPenalty settings s w : createLetterBoxes settings s l
createLetterBoxes settings s ((w',','):(_,' '):l) = (createChar s w' ',') : ((spaceGlueBox settings s 2.0) ++ createLetterBoxes settings s l)
createLetterBoxes settings s ((w',';'):(_,' '):l) = (createChar s w' ';') : ((spaceGlueBox settings s 2.0) ++ createLetterBoxes settings s l)
createLetterBoxes settings s ((w','.'):(_,' '):l) = (createChar s w' '.') : ((spaceGlueBox settings s 2.0) ++ createLetterBoxes settings s l)
createLetterBoxes settings s ((w',':'):(_,' '):l) = (createChar s w' ':') : ((spaceGlueBox settings s 2.0) ++ createLetterBoxes settings s l)
createLetterBoxes settings s ((w','!'):(_,' '):l) = (createChar s w' '!') : ((spaceGlueBox settings s 2.0) ++ createLetterBoxes settings s l)
createLetterBoxes settings s ((w','?'):(_,' '):l) = (createChar s w' '?') : ((spaceGlueBox settings s 2.0) ++ createLetterBoxes settings s l)
createLetterBoxes settings s ((_,' '):l) = (spaceGlueBox settings s 1.0) ++ createLetterBoxes settings s l
createLetterBoxes settings s ((w,t):l) = (createChar s w t) : createLetterBoxes settings s l
splitText :: Style s => BRState -> s -> PDFString -> [Letter s]
splitText settings f t = wordToLetters t
where
wordToLetters = createLetterBoxes settings f . ripText (textFont . textStyle $ f)
hyphenPenalty :: BRState
-> s
-> PDFFloat
-> Letter s
hyphenPenalty settings s w = FlaggedPenalty w (hyphenPenaltyValue settings) s
kernBox :: s -> PDFFloat -> Letter s
kernBox s w = Kern w (Just s)