--------------------------------------------------------- -- | -- 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)