HPDF-1.1: Graphics/PDF/Typesetting/Breaking.hs
---------------------------------------------------------
-- |
-- Copyright : (c) alpha 2006
-- License : BSD-style
--
-- Maintainer : misc@NOSPAMalpheccar.org
-- Stability : experimental
-- Portability : portable
--
-- Breaking algorithm used to split a paragraph into lines
-- or a text into pages
---------------------------------------------------------
-- #hide
module Graphics.PDF.Typesetting.Breaking (
Letter(..)
, formatList
, infinity
, createChar
, kernBox
, glueBox
, penalty
, spaceGlueBox
, nullLetter
, hyphenPenalty
, splitText
, MaybeGlue(..)
, defaultBreakingSettings
, BRState(..)
, glueWidth
, mkLetter
) 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)
-- | Create a null box
nullLetter :: Letter
nullLetter = mkLetter (0,0,0) Nothing NullChar
-- | Make a letter from any box
mkLetter :: (Show a, Box a, DisplayableBox a) => BoxDimension -- ^ Dimension of the box
-> Maybe AnyStyle -- ^ Text style of the box (can use t)
-> a -- ^ Box
-> Letter
mkLetter d s a = Letter d (AnyBox a) s
-- | A letter which can be anything. Sizes are widths and for glue the dilation and compression factors
-- For the generic letter, height and descent are also provided
data Letter = Letter BoxDimension !AnyBox !(Maybe AnyStyle) -- ^ Any box as a letter
| Glue !PDFFloat !PDFFloat !PDFFloat !(Maybe AnyStyle) -- ^ A glue with style to know if it is part of the same sentence
| FlaggedPenalty !PDFFloat !Int !AnyStyle -- ^ Hyphen point
| Penalty !Int -- ^ Penalty
| AChar !AnyStyle !Char !PDFFloat -- ^ A char
| Kern !PDFFloat !(Maybe AnyStyle) -- ^ A kern : non dilatable and non breakable glue
class MaybeGlue a where
boxWidthWithRatio :: a -> PDFFloat -> PDFFloat
instance MaybeGlue Letter where
boxWidthWithRatio = letterWidth
-- | Compute glue width with dilation
glueWidth :: PDFFloat -> PDFFloat -> PDFFloat -> PDFFloat -> PDFFloat
glueWidth w y z r =
if r >= 0
then
r*y + w
else
r*z + w
letterWidth :: Letter -- ^ letter
-> PDFFloat -- ^ Adjustement ratio
-> PDFFloat -- ^ Width
letterWidth (AChar _ _ w) _ = w
letterWidth (Letter dim _ _) _ = boxWidth dim
letterWidth (Glue w yi zi _) r = glueWidth w yi zi r
letterWidth (FlaggedPenalty _ _ _) _ = 0
letterWidth (Penalty _) _ = 0
letterWidth (Kern w _) _ = w
instance Show Letter 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 a where
isFlagged :: a -> Bool
getPenalty :: a -> Int
isPenalty :: a -> Bool
letter :: a -> Letter
position :: a -> Int
cumulatedW :: a -> PDFFloat
cumulatedY :: a -> PDFFloat
cumulatedZ :: a -> PDFFloat
isForcedBreak :: a -> Bool
instance PointedBox (PDFFloat,PDFFloat,PDFFloat,Int,Letter) 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 ZList 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
-- A penalty has no width unless you break on it so it needs a special processing
penaltyWidth :: Letter -> 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)
adjustRatio :: BreakNode
-> ZList
-> 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
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
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
-- | Breaking algorithm settings
data BRState = BRState { firstPassTolerance :: !PDFFloat -- ^ Default value 100
, secondPassTolerance :: !PDFFloat -- ^ Default value 200
, hyphenPenaltyValue :: !Int -- ^ Default value 50
, fitness_demerit :: !PDFFloat -- ^ Default value 10000
, flagged_demerit :: !PDFFloat -- ^ Default value 10000
, line_penalty :: !PDFFloat -- ^ Default value 10
}
defaultBreakingSettings :: BRState
defaultBreakingSettings = BRState 100 200 50 10000 10000 10
computeDemerit :: BRState
-> Bool
-> PDFFloat -- ^ adjust ratio
-> BreakNode -- ^ Flag for previous
-> ZList -- ^ Flag for current
-> Maybe(PDFFloat,Int) -- ^ Demerit for the breakpoint
computeDemerit 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) || sndPass
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 = ZList (MaybeCB Letter) (PDFFloat,PDFFloat,PDFFloat,Int,Letter) [Letter] deriving(Show)
createZList :: [Letter] -> ZList
createZList [] = error "List cannot be empty to create a zipper"
createZList l = ZList NoCB (0,0,0,1,head l) (tail l)
theEnd :: ZList -> Bool
theEnd (ZList _ _ []) = True
theEnd _ = False
-- | We create a new breakpoint but we get the cumulated dimensions only at the next box following the break
-- since glues and penalties are removed at the beginning of a line
createBreaknode :: Maybe (Int,Int,Int,BreakNode) -> ZList -> BreakNode
createBreaknode prev (ZList _ (w,y,z,_,FlaggedPenalty _ _ _) []) = BreakNode (w) (y) (z) 0.0 True 0 0.0 prev
createBreaknode prev (ZList _ (w,y,z,_,Penalty _) []) = BreakNode w (y) (z) 0.0 False 0 0.0 prev
createBreaknode prev (ZList _ (w,y,z,_,Glue w' y' z' _) []) = BreakNode (w + w') (y+y') (z+z') 0.0 False 0 0.0 prev
createBreaknode prev (ZList _ (w,y,z,_,a) []) = BreakNode (w + boxWidthWithRatio a 0.0) (y) (z) 0.0 False 0 0.0 prev
createBreaknode prev (ZList _ (w,y,z,_,FlaggedPenalty _ p _) _) | p <= infinity = BreakNode w y z 0.0 True 0 0.0 prev
createBreaknode prev (ZList _ (w,y,z,_,Penalty p) _) | p <= infinity = BreakNode w y z 0.0 False 0 0.0 prev
createBreaknode prev (ZList _ (w,y,z,_,Letter _ _ _) _) = BreakNode w y z 0.0 False 0 0.0 prev
createBreaknode prev (ZList _ (w,y,z,_,AChar _ _ _) _) = BreakNode w y z 0.0 False 0 0.0 prev
createBreaknode prev (ZList _ (w,y,z,_,Kern _ _) _) = BreakNode w y z 0.0 False 0 0.0 prev
createBreaknode prev z = createBreaknode prev (moveRight z)
-- | Create an hyphen penalty
hyphenPenalty :: BRState
-> AnyStyle -- ^ Style of future hyphen
-> PDFFloat -- ^ Size of hyphen taking into account the kerning that was perturbed by the hyphen introduction. The char before the hyphen is now bigger
-> Letter
hyphenPenalty settings s w = FlaggedPenalty w (hyphenPenaltyValue settings) s
moveRight :: ZList -> ZList
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' = boxWidthWithRatio a 0.0
w'' = w + w'
in
ZList (OneCB c) (w'',y,z,p+1,head r) (tail r)
isFeasibleBreakpoint :: Bool -- ^ Second pass
-> ZList -- ^ Current analyzed box
-> Bool -- ^ Result
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
-- Update a feasible breakpoint remembering only the best one
type PossibleBreak = ActiveNodes -- Line, demerit and break node
type ActiveNodes = Map.Map (Int,Int,Int) BreakNode
updateBreak :: BreakNode
-> BreakNode
-> BreakNode
updateBreak a b = if demerit a < demerit b then a else b
-- | Check is a break point is possible
-- otherwise, if none is possible and there is only one remaining active point,
-- we force a breakpoint
updateWithNewRIfNoSolution :: Bool
-> PDFFloat -- ^ Old r
-> ZList -- ^ Current
-> (Int,Int,Int)
-> PossibleBreak
-> ActiveNodes-- ^ Actives
-> (PDFFloat -> ActiveNodes -> (PossibleBreak,ActiveNodes))
-> (PossibleBreak,ActiveNodes)
updateWithNewRIfNoSolution sndPass r z key newbreak newmap f =
if r < -1
then
--if Map.size newmap > 1 then (newbreak,Map.delete key newmap) else f (-0.99) (Map.delete key newmap)
if sndPass
then
f (-0.99) (Map.delete key newmap)
else
(newbreak,Map.delete key newmap)
else if isForcedBreak z
then
f r (Map.delete key newmap)
else
f r newmap
getNewActiveBreakpoints :: BRState -> Bool -> (Int -> PDFFloat) -> ActiveNodes -> ZList -> (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' $
\r newmap -> let dem' = computeDemerit 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
-- We keep only the best new break
(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 )
-- (position, line, fitness) -> (adjust ratio, break position)
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)
-- Analyze the boxes to compute breaks
analyzeBoxes :: BRState -> Bool -> (Int -> PDFFloat) -> ActiveNodes -> ZList -> [(PDFFloat,Int,Bool)]
analyzeBoxes settings pass fmaxw actives 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 forced breakpoint or no breakpoint found
if Map.null actives'
then
-- If no breakpoint found
if Map.null breaks'
then
-- Second pass analysis
if not pass
then
analyzeBoxes settings True fmaxw actives z
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
-- Forced breakpoint then we gen a list from it and continue the analysis
let minBreak = getMinBreak breaks'
someNewBreaks = getRightOrderNodeList minBreak
in
if theEnd z
then
someNewBreaks
else
someNewBreaks ++ analyzeBoxes settings pass fmaxw (Map.insert (getKey minBreak) (getNode minBreak) Map.empty) (moveRight z)
-- Normal feasible breakpoint
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' (moveRight z)
else
-- If the end it must be a possible breakpoint
-- We should NEVER reach this part. The end should always be a forced breakpoint
if theEnd z
then
let minBreak = getMinBreak breaks' in
getRightOrderNodeList minBreak
else
-- We continue the analysis
analyzeBoxes settings pass fmaxw newActives (moveRight z)
-- | Create an hyphen box
hyphenBox :: AnyStyle -> Letter
hyphenBox s = AChar s '-' (charWidth (textFont . textStyle $ s) '-')
-- Use a list of breakpoint and adjustement ratios to generate a list of lines. Bool means if the break was done on a flagged penalty (hyphen)
cutList :: [Letter] -> Int -> [(PDFFloat,Int,Bool)] -> [(PDFFloat,[Letter])]
cutList [] _ _ = []
cutList t _ [] = [(0.0,t)]
cutList t c ((ra,ba,fa):l) =
let (theLine,t') = splitAt (ba-c) t
in
if null theLine
then
[]
else
if null t'
then
[(ra,theLine)]
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 ++ [hyphenBox s]) : cutList t' ba l
_ -> if fa
then
error "Breakpoint marked as flagged but detected as not flagged ! Send a bug report !"
else
(ra,theLine) : cutList t' ba l
-- Compute the breakpoints and generate a list of lines with the adjustement ratios
-- The line are not interpreted. Some additional postprocessing is required
-- for horizontal lines of vertical boxes
formatList :: BRState -> (Int -> PDFFloat) -> [Letter] -> [(PDFFloat,[Letter])]
formatList settings maxw boxes =
let active = Map.insert (0,0,1) (BreakNode 0 0 0 0 False 0 0.0 Nothing) Map.empty
theBreaks = analyzeBoxes settings False maxw active (createZList boxes)
in
cutList boxes 1 theBreaks
-- | Value modeling infinity
infinity :: Int
infinity = 10000
bigAdjustRatio :: PDFFloat
bigAdjustRatio = 10000.0
-- | Add a glue to the stream
glueBox :: Maybe AnyStyle
-> PDFFloat -- ^ Glue width
-> PDFFloat -- ^ Glue dilatation
-> PDFFloat -- ^ Glue compression
-> Letter
glueBox s w y z = Glue w y z s
-- | Add a glue to the stream
spaceGlueBox :: AnyStyle -- ^ The style
-> Letter
spaceGlueBox s =
let ws = (textWidth (textFont . textStyle $ s) (toPDFString " ") )
h = scaleSpace . textStyle $ s
sy = scaleDilatation . textStyle $ s
sz = scaleCompression . textStyle $ s
in
Glue (ws*h) (h*sy*ws/2.0) (h*sz*ws/3.0) (Just s)
-- | Add a glue to the stream
punctuationGlue :: AnyStyle -- ^ The style
-> Letter
punctuationGlue s =
let ws = (textWidth (textFont . textStyle $ s) (toPDFString " ") )
h = scaleSpace . textStyle $ s
sy = scaleDilatation . textStyle $ s
sz = scaleCompression . textStyle $ s
in
Glue (ws*h) (h*sy*ws) (h*sz*ws/3.0) (Just s)
-- | Add a penalty to the stream
penalty :: Int -- ^ Penalty value
-> Letter
penalty p = Penalty p
-- | Create a box containing text
createChar :: AnyStyle -- ^ Char style
-> PDFFloat -- ^ Char width
-> Char -- ^ Char code
-> Letter
createChar s w t = AChar s t w
-- | Create boxes for the letters
createLetterBoxes :: BRState
-> AnyStyle -- ^ Letter style
-> [(PDFFloat,Char)] -- ^ Letter and size
-> [Letter] -- ^ Boxes
createLetterBoxes _ _ [] = []
createLetterBoxes settings s ((wa,'.'):b@(_,bc):l') | bc /= ' ' = (createChar s wa '.'): punctuationGlue s : createLetterBoxes settings s (b:l')
| otherwise = (createChar s wa '.') : punctuationGlue s : createLetterBoxes settings s l'
createLetterBoxes settings s ((_,'/'):(w,'-'):l) = hyphenPenalty settings s w : createLetterBoxes settings s l
createLetterBoxes settings s ((_,' '):l) = (spaceGlueBox s) : createLetterBoxes settings s l
createLetterBoxes settings s ((w,t):l) = (createChar s w t) : createLetterBoxes settings s l
-- WARNING : must generate a list of LETTERS
-- word are created with the analysis of style just above
-- | split a line into boxes
splitText :: BRState -> AnyStyle -> PDFString -> [Letter]
splitText settings f t = createLetterBoxes settings f . ripText (textFont . textStyle $ f) $ t
kernBox :: AnyStyle -> PDFFloat -> Letter
kernBox s w = Kern w (Just s)