packages feed

HPDF 1.1 → 1.2

raw patch · 14 files changed

+1320/−709 lines, 14 filesdep ~encoding

Dependency ranges changed: encoding

Files

Graphics/PDF/Annotation.hs view
@@ -26,6 +26,8 @@ import qualified Data.Map as M import Graphics.PDF.Action import Graphics.PDF.Pages+import Control.Monad.State(gets)+--import Debug.Trace  data TextIcon = Note               | Paragraph@@ -37,11 +39,51 @@               deriving(Eq,Show)                        -data TextAnnotation = TextAnnotation PDFString [PDFFloat] TextIcon-data URLLink = URLLink PDFString [PDFFloat] String Bool-data PDFLink = PDFLink PDFString [PDFFloat] (PDFReference PDFPage) PDFFloat PDFFloat Bool+data TextAnnotation = TextAnnotation +   PDFString -- Content+   [PDFFloat] -- Rect+   TextIcon+data URLLink = URLLink +  PDFString -- Content+  [PDFFloat] -- Rect+  String -- URL+  Bool -- Border+data PDFLink = PDFLink +  PDFString -- Content+  [PDFFloat] -- Rect+  (PDFReference PDFPage) -- Page+  PDFFloat -- x+  PDFFloat -- y+  Bool -- Border --data Screen = Screen (PDFReference Rendition) PDFString [PDFFloat] (PDFReference PDFPage) (Maybe (PDFReference ControlMedia)) (Maybe (PDFReference ControlMedia))  +--det :: Matrix -> PDFFloat+--det (Matrix a b c d _ _) = a*d - b*c+--+--inverse :: Matrix -> Matrix+--inverse m@(Matrix a b c d e f) = (Matrix (d/de) (-b/de) (-c/de) (a/de) 0 0) * (Matrix 1 0 0 1 (-e) (-f))+--	where+--		de = det m+		+applyMatrixToRectangle :: Matrix -> [PDFFloat] -> [PDFFloat]+applyMatrixToRectangle m [xa,ya,xb,yb] = +    let (xa',ya') = m `applyTo` (xa,ya)+        (xa'',yb') = m `applyTo` (xa,yb)+        (xb',ya'') = m `applyTo` (xb,ya)+        (xb'',yb'') = m `applyTo` (xb,yb)+        x1 = minimum [xa',xa'',xb',xb'']+        x2 = maximum [xa',xa'',xb',xb'']+        y1 = minimum [ya',ya'',yb',yb'']+        y2 = maximum [ya',ya'',yb',yb'']+    in+    [x1,y1,x2,y2]+ where+     applyTo (Matrix a b c d e f) (x,y) = (a*x+c*y+e,b*x+d*y+f)+     +applyMatrixToRectangle _ a = a++    + -- | Get the border shqpe depending on the style getBorder :: Bool -> [PDFInteger] getBorder False = [0,0,0]@@ -82,6 +124,9 @@     annotationType _ = PDFName "Text"     annotationContent (TextAnnotation s _ _) = s     annotationRect (TextAnnotation _ r _) = r+    annotationToGlobalCoordinates (TextAnnotation a r b) = do+        gr <- transformAnnotRect r+        return $ TextAnnotation a gr b      instance PdfObject URLLink where     toPDF a@(URLLink _ _ url border) = toPDF . PDFDictionary . M.fromList $ @@ -95,7 +140,10 @@     annotationType _ = PDFName "Link"     annotationContent (URLLink s _ _ _) = s     annotationRect (URLLink _ r _ _) = r-    +    annotationToGlobalCoordinates (URLLink a r b c) = do+        gr <- transformAnnotRect r+        return $ URLLink a gr b c+         instance PdfObject PDFLink where     toPDF a@(PDFLink _ _ page x y border) = toPDF . PDFDictionary . M.fromList $                 standardAnnotationDict a ++ @@ -114,9 +162,19 @@     annotationType _ = PDFName "Link"     annotationContent (PDFLink s _ _ _ _ _) = s     annotationRect (PDFLink _ r _ _ _ _) = r+    annotationToGlobalCoordinates (PDFLink a r b c d e) = do+        gr <- transformAnnotRect r+        return $ PDFLink a gr b c d e+        +transformAnnotRect :: [PDFFloat] -> Draw [PDFFloat]+transformAnnotRect r = do+    l <- gets matrix+    let m = foldr (*) identity l+    return $ m `applyMatrixToRectangle` r      -- | Create a new annotation object newAnnotation :: (PdfObject a, AnnotationObject a) => a -> Draw () newAnnotation annot = do-    modifyStrict $ \s -> s {annots = (AnyAnnotation annot):(annots s)}+    annot' <- annotationToGlobalCoordinates annot+    modifyStrict $ \s -> s {annots = (AnyAnnotation annot'):(annots s)}     return ()
Graphics/PDF/Coordinates.hs view
@@ -33,41 +33,15 @@ data Angle = Degree PDFFloat -- ^ Angle in degrees            | Radian PDFFloat -- ^ Angle in radians --- | A transformation matrix. An affine transformation a b c d e f------ @--- a b e--- c d f--- 0 0 1--- @-       -data Matrix = Matrix !PDFFloat !PDFFloat !PDFFloat !PDFFloat !PDFFloat !PDFFloat deriving (Eq) --- | Identity matrix-identity :: Matrix-identity = Matrix 1.0 0 0 1.0 0 0 -instance Show Matrix where-  show (Matrix ma mb mc md me mf) = "Matrix " ++ (unwords [(show ma),(show mb),(show mc),(show md),(show me),(show mf)]) -instance Num Matrix where-    --  Matrix addition-    (+) (Matrix ma mb mc md me mf ) (Matrix na nb nc nd ne nf) = -         Matrix (ma+na)  (mb+nb)  (mc+nc)  (md+nd)  (me+ne)  (mf+nf)-    (*) (Matrix ma mb mc md me mf) (Matrix na nb nc nd ne nf) = -         Matrix (ma*na+mb*nc)  (ma*nb + mb*nd )  (mc*na+md*nc)  (mc*nb +md*nd)  (me*na+mf*nc+ne)  (me*nb+mf*nd+nf)-    negate (Matrix ma mb mc md me mf )  =-         Matrix (-ma)  (-mb)  (-mc)  (-md)  (-me)  (-mf)-    abs m = m-    signum _ = identity-    fromInteger i = Matrix r 0 0 r  0  0-                   where-                    r = fromInteger i   -- | Apply a transformation matrix to the current coordinate frame applyMatrix :: Matrix -> Draw ()-applyMatrix (Matrix a b c d e f)  = +applyMatrix m@(Matrix a b c d e f)  = do+    multiplyCurrentMatrixWith m     tell . mconcat $[ serialize '\n'                     , toPDF a                     , serialize ' '
Graphics/PDF/Draw.hs view
@@ -63,6 +63,10 @@  , PDFShading(..)  , getRgbColor  , emptyDrawState+ , Matrix(..)+ , identity+ , currentMatrix+ , multiplyCurrentMatrixWith  ) where   import Graphics.PDF.LowLevel.Types@@ -79,6 +83,37 @@ import Graphics.PDF.LowLevel.Serializer import Data.Monoid +-- | A transformation matrix. An affine transformation a b c d e f+--+-- @+-- a b 0+-- c d 0+-- e f 1+-- @+       +data Matrix = Matrix !PDFFloat !PDFFloat !PDFFloat !PDFFloat !PDFFloat !PDFFloat deriving (Eq)+		+-- | Identity matrix+identity :: Matrix+identity = Matrix 1.0 0 0 1.0 0 0++instance Show Matrix where+  show (Matrix ma mb mc md me mf) = "Matrix " ++ (unwords [(show ma),(show mb),(show mc),(show md),(show me),(show mf)])++instance Num Matrix where+    --  Matrix addition+    (+) (Matrix ma mb mc md me mf ) (Matrix na nb nc nd ne nf) = +         Matrix (ma+na)  (mb+nb)  (mc+nc)  (md+nd)  (me+ne)  (mf+nf)+    (*) (Matrix ma mb mc md me mf) (Matrix na nb nc nd ne nf) = +         Matrix (ma*na+mb*nc)  (ma*nb+mb*nd)  (mc*na+md*nc)  (mc*nb +md*nd)  (me*na+mf*nc+ne)  (me*nb+mf*nd+nf)+    negate (Matrix ma mb mc md me mf )  =+         Matrix (-ma)  (-mb)  (-mc)  (-md)  (-me)  (-mf)+    abs m = m+    signum _ = identity+    fromInteger i = Matrix r 0 0 r  0  0+                   where+                    r = fromInteger i+ data AnnotationStyle = AnnotationStyle !(Maybe Color)  class AnnotationObject a where@@ -86,6 +121,8 @@     annotationType :: a -> PDFName     annotationContent :: a -> PDFString     annotationRect :: a -> [PDFFloat]+    annotationToGlobalCoordinates :: a -> Draw a+    annotationToGlobalCoordinates = return      data AnyAnnotation = forall a.(PdfObject a,AnnotationObject a) => AnyAnnotation a @@ -118,6 +155,7 @@                 ,  patterns :: M.Map (PDFReference AnyPdfPattern) String                 ,  colorSpaces :: M.Map PDFColorSpace String                 ,  shadings :: M.Map PDFShading String+                ,  matrix :: [Matrix]                 } data DrawEnvironment = DrawEnvironment {                         streamId :: Int@@ -178,19 +216,36 @@ emptyDrawState :: Int -> DrawState emptyDrawState ref =      let names = (map (("O" ++ (show ref)) ++ ) $ [replicate k ['a'..'z'] | k <- [1..]] >>= sequence) in-    DrawState names emptyRsrc M.empty M.empty M.empty M.empty emptyDictionary []  M.empty M.empty M.empty+    DrawState names emptyRsrc M.empty M.empty M.empty M.empty emptyDictionary []  M.empty M.empty M.empty [identity]    -- | Execute the drawing commands to get a new state and an uncompressed PDF stream runDrawing :: Draw a -> DrawEnvironment -> DrawState -> (a,DrawState,BU.Builder) runDrawing drawing environment state = (runRWS . unDraw $ drawing) environment state       +pushMatrixStack :: Matrix -> Draw ()+pushMatrixStack m = do+    modifyStrict $ \s -> s {matrix = m : matrix s}+    +popMatrixStack :: Draw ()+popMatrixStack = do+    modifyStrict $ \s -> s {matrix = tail (matrix s)}+    ++multiplyCurrentMatrixWith :: Matrix -> Draw ()+multiplyCurrentMatrixWith m' = modifyStrict $ \s -> s {matrix = let (m:l) = matrix s in (m' * m ):l}++    +currentMatrix :: Draw Matrix+currentMatrix = gets matrix >>= return . head        -- | Draw in a new drawing context without perturbing the previous context -- that is restored after the draw        withNewContext :: Draw a -> Draw a withNewContext m = do     tell . serialize $ "\nq"+    pushMatrixStack identity     a <- m+    popMatrixStack     tell . serialize $ "\nQ"     return a
Graphics/PDF/Image.hs view
@@ -18,6 +18,7 @@    -- ** Functions    , createPDFJpeg    , readJpegFile+   , jpegBounds  ) where       import Graphics.PDF.LowLevel.Types@@ -34,6 +35,7 @@ import Control.Monad.Error   import Graphics.PDF.Coordinates import Data.Binary.Builder(Builder,fromLazyByteString)+import Control.Exception as E  m_sof0 :: Int m_sof0 = 0xc0 @@ -240,21 +242,28 @@      --test = analyzePng "Test/logo.png"     -    +withFile :: String -> (Handle -> IO c) -> IO c    +withFile name = bracket (openBinaryFile name ReadMode) hClose+ -- | Read a JPEG file and return an abstract description of its content or an error+-- The read is not lazy. The whole image will be loaded into memory readJpegFile :: FilePath              -> IO (Either String JpegFile)-readJpegFile f = do-     h <- liftIO $ openBinaryFile f ReadMode-     r <- runFA (analyzeJpeg h)-     liftIO $ hClose h+readJpegFile f = catchJust ioErrors (do+     r <- liftIO $ withFile f $ \h -> do+             runFA (analyzeJpeg h)      case r of          Right (bits_per_component,height,width,color_space) -> do-                 img <- liftIO $ B.readFile f-                 return (Right $ JpegFile bits_per_component width height color_space (fromLazyByteString img)) -         Left s -> return $ Left s +                 img <- liftIO $ withFile f $ \h' -> do+                     nb <- hFileSize h'+                     B.hGet h' (fromIntegral nb)+                 return (Right $ JpegFile bits_per_component width height color_space (fromLazyByteString img))+         Left s -> return $ Left s) (\err -> return $ Left (show err))  -  +-- | Get the JPEG bounds+jpegBounds :: JpegFile -> (PDFFloat,PDFFloat)+jpegBounds (JpegFile _ w h _ _) = (w,h)+ -- | Use an abstract description of a Jpeg to return a PDFReference that can be used to manipulate the Jpeg in the context -- of the PDF document createPDFJpeg :: JpegFile
Graphics/PDF/Shading.hs view
@@ -14,6 +14,7 @@   -- ** Type     PDFShading(..)   , paintWithShading+  , applyShading  ) where       import Graphics.PDF.Draw@@ -24,7 +25,7 @@ import Graphics.PDF.LowLevel.Serializer import Data.Monoid --- | Set alpha value for transparency+-- | Fill clipping region with a shading applyShading :: PDFShading -> Draw () applyShading shade = do     shadingMap <- gets shadings
Graphics/PDF/Typesetting.hs view
@@ -11,33 +11,56 @@ ---------------------------------------------------------  module Graphics.PDF.Typesetting(-  -- * Typesetting-  -- ** Types+  -- * Types+  -- ** Boxes     Box(..)   , DisplayableBox(..)+  , Letter(..)+  , BoxDimension+  -- ** Styles   , Style(..)   , TextStyle(..)   , StyleFunction(..)-  , AnyStyle   , ParagraphStyle(..)-  , AnyParagraphStyle   , MonadStyle(..)-  , Letter(..)-  , BoxDimension+  , ComparableStyle(..)+  -- ** Typesetting monads+  , Para+  , TM+  -- ** Containers+  , VBox+  , VerState(..)+  , Container+  , Justification(..)   -- * Functions   -- ** Text display   , displayFormattedText   -- ** Text construction operators-  , endParagraph+  , forceNewLine   , txt   , paragraph-  -- * Paragraph construction operators+  -- ** Paragraph construction operators   , kern   , addPenalty---  , nullChar   , mkLetter-  -- * Misc   , mkDrawBox+  -- ** Functions useful to change the paragraph style+  , getParaStyle+  , setParaStyle+  -- ** Container+  , mkContainer+  , fillContainer+  , defaultVerState+  , getBoxes+  , containerX+  , containerY+  , containerWidth+  , containerHeight+  , containerContentHeight+  , containerContentRightBorder+  , containerContentLeftBorder+  , containerCurrentHeight+  , containerContentRectangle   -- * Settings (similar to TeX ones)   -- ** Line breaking settings   , setFirstPassTolerance @@ -52,6 +75,7 @@   , getFitnessDemerit   , getHyphenDemerit   , getLinePenalty+  , setJustification   -- ** Vertical mode settings   , setBaseLineSkip   , setLineSkipLimit@@ -59,11 +83,7 @@   , getBaseLineSkip   , getLineSkipLimit   , getLineSkip-  -- * Styles-  -- ** Functions useful to change the paragraph style-  , getParaStyle-  , setParaStyle-  , getTextArea+  , module Graphics.PDF.Typesetting.StandardStyle   ) where    import Graphics.PDF.LowLevel.Types@@ -73,87 +93,81 @@ import Control.Monad.RWS import Graphics.PDF.Typesetting.Breaking import Graphics.PDF.Typesetting.Vertical+import Graphics.PDF.Typesetting.Layout import Graphics.PDF.Typesetting.Box+import Graphics.PDF.Typesetting.StandardStyle  -- | Display a formatted text in a given bounding rectangle with a given default paragraph style, a given default text style. No clipping -- is taking place. Drawing stop when the last line is crossing the bounding rectangle in vertical direction-displayFormattedText :: (Style s, ParagraphStyle s') => Rectangle -- ^ Text area-                     -> s' -- ^ default vertical style+displayFormattedText :: (ParagraphStyle ps s) => Rectangle -- ^ Text area+                     -> ps -- ^ default vertical style                      -> s -- ^ Default horizontal style-                     -> TM a -- ^ Typesetting monad+                     -> TM ps s a -- ^ Typesetting monad                      -> Draw a -- ^ Draw monad-displayFormattedText area@(Rectangle xa y' _ y'') defaultVStyle defaultHStyle t  = +displayFormattedText (Rectangle xa ya xb yb) defaultVStyle defaultHStyle t  =      do     --withNewContext $ do     --    addShape $ Rectangle (xa-1) y' (xb+1) y''     --    closePath     --    setAsClipPath-        let (a, s', boxes) = (runRWS . unTM $ t >>= \x' -> do {return x'} ) area (defaultTmState defaultVStyle defaultHStyle)-        strokeVBoxes (verticalPostProcess (pageSettings s') 0 area boxes) (xa,y',y'')+        let (a, s', boxes) = (runRWS . unTM $ t >>= \x' -> do {return x'} ) () (defaultTmState defaultVStyle defaultHStyle)+            c = mkContainer xa yb (xb-xa) (yb-ya)+            (d,_,_) = fillContainer (pageSettings s') c boxes+        d         return a  ---endParagraphBoxes :: [Letter]  ---endParagraphBoxes = [glueBox Nothing 0 10000.0 0,penalty (-infinity)]+-- | Return the list of Vboxes for a text+getBoxes :: (ParagraphStyle ps s) => ps -- ^ default vertical style+         -> s -- ^ Default horizontal style+         -> TM ps s a -- ^ Typesetting monad+         -> [VBox ps s] -- ^ List of boxes+getBoxes defaultVStyle defaultHStyle t  =+    let (_, _ , boxes) = (runRWS . unTM $ t >>= \x' -> do {return x'} ) () (defaultTmState defaultVStyle defaultHStyle)+    in boxes  -- | Add a penalty-addPenalty :: Int -> Para()+addPenalty :: Int -> Para s () addPenalty f = tell $ [penalty f]-  --- | End the current paragraph with or without using the same style-endParagraph :: Bool -- ^ True if we use the same style to end a paragraph. false for an invisible style-             -> Para ()-endParagraph r = do-    if r-        then-            glue 0 10000.0 0-        else-            tell $ [glueBox Nothing 0 10000.0 0]-    addPenalty (-infinity)     --- | Get the bounding rectangle containing the text-getTextArea :: TM Rectangle-getTextArea = ask--defaultTmState :: (Style s, ParagraphStyle s') => s' -> s -> TMState-defaultTmState s' s = TMState { tmStyle = AnyStyle s+defaultTmState :: (ParagraphStyle ps s) => ps -> s -> TMState ps s+defaultTmState s' s = TMState { tmStyle = s                               , paraSettings = defaultBreakingSettings                               , pageSettings = defaultVerState s'                               }     -data TMState = TMState { tmStyle :: !AnyStyle-                       , paraSettings :: !BRState-                       , pageSettings :: !VerState-                       }+data TMState ps s = TMState { tmStyle :: !s+                            , paraSettings :: !BRState+                            , pageSettings :: !(VerState ps)+                            }                        -newtype TM a = TM { unTM :: RWS Rectangle [VBox] TMState a} +newtype TM ps s a = TM { unTM :: RWS () [VBox ps s] (TMState ps s) a}  #ifndef __HADDOCK__-  deriving(Monad,MonadWriter [VBox], MonadState TMState, MonadReader Rectangle, Functor)+  deriving(Monad,MonadWriter [VBox ps s], MonadState (TMState ps s), Functor) #else instance Monad TM-instance MonadWriter [VBox] TM-instance MonadState TMState TM+instance MonadWriter [VBox ps s] TM+instance MonadState (TMState ps s) TM instance Functor TM-instance MonadReader Rectangle TM #endif -newtype Para a = Para { unPara :: RWS BRState [Letter] AnyStyle a} +newtype Para s a = Para { unPara :: RWS BRState [Letter s] s a}  #ifndef __HADDOCK__-  deriving(Monad,MonadWriter [Letter], MonadReader BRState, MonadState AnyStyle, Functor)+  deriving(Monad,MonadWriter [Letter s], MonadReader BRState, MonadState s, Functor) #else instance Monad Para-instance MonadWriter [Letter] Para-instance MonadState AnyStyle Para+instance MonadWriter [Letter s] Para+instance MonadState s Para instance Functor Para instance MonadReader BRState Para #endif  -- | A MonadStyle where some typesetting operators can be used-class Monad m => MonadStyle m where+class (Style s, Monad m) => MonadStyle s m | m -> s where     -- | Set the current text style-    setStyle :: Style a => a -> m ()+    setStyle :: s -> m ()          -- | Get the current text style-    currentStyle :: m AnyStyle+    currentStyle :: m s          -- | Add a box using the current mode (horizontal or vertical. The current style is always applied to the added box)     addBox :: (Show a, DisplayableBox a, Box a) => a @@ -175,9 +189,9 @@                  -> m ()          -instance MonadStyle TM where+instance Style s => MonadStyle s (TM ps s) where     --  Set style of text-    setStyle f = modifyStrict $ \s -> s {tmStyle = AnyStyle f}+    setStyle f = modifyStrict $ \s -> s {tmStyle = f}      --  Get current text style     currentStyle = gets tmStyle@@ -190,17 +204,15 @@     --  Add a glue     glue h y z = do         style <- getParaStyle-        Rectangle xa _ xb _ <- getTextArea-        tell $ [vglue (Just style) h y z (xb-xa) 0]+        tell $ [vglue (Just style) h y z 0 0]              --  Add a glue     unstyledGlue h y z = do-        Rectangle xa _ xb _ <- getTextArea-        tell $ [vglue Nothing h y z (xb-xa) 0]+        tell $ [vglue Nothing h y z 0 0]     -instance MonadStyle Para where+instance Style s => MonadStyle s (Para s) where     --  Set style of text-    setStyle f = put $! AnyStyle f+    setStyle f = put $! f      --  Get current text style     currentStyle = get@@ -218,37 +230,83 @@     --  Add a glue     unstyledGlue w y z = do         tell $ [glueBox Nothing w y z]+        +-- | For a newline and end the current paragraph+forceNewLine :: Style s => Para s ()+forceNewLine = do+    endPara+    startPara     +-- | End the current paragraph with or without using the same style+endFullyJustified :: Style s => Bool -- ^ True if we use the same style to end a paragraph. false for an invisible style+             -> Para s ()+endFullyJustified r = do+    if r+        then+            glue 0 10000.0 0+        else+            tell $ [glueBox Nothing 0 10000.0 0]+    addPenalty (-infinity)+     +endPara :: Style s => Para s ()+endPara = do+    style <- ask+    theStyle <- currentStyle+    let w = spaceWidth theStyle+    case centered style of+      Centered -> do+        addLetter (glueBox (Just theStyle) 0 (centeredDilatationFactor*w) 0)+        addLetter (penalty (-infinity))+      RightJustification -> addPenalty (-infinity) +      _ -> endFullyJustified False+      +startPara :: Style s => Para s ()+startPara = do+    style <- ask+    theStyle <- currentStyle+    let w = spaceWidth theStyle+    case (centered style) of+      Centered -> do+        addLetter (kernBox (theStyle) 0)+        addLetter $ penalty infinity+        addLetter (glueBox (Just theStyle) 0 (centeredDilatationFactor*w) 0)+      RightJustification -> do+        addLetter (kernBox (theStyle) 0)+        addLetter $ penalty infinity+        addLetter (glueBox (Just theStyle) 0 (rightDilatationFactor*w) 0)+      _ -> return ()+       -- | Run a paragraph. Style changes are local to the paragraph-runPara :: Para a -> TM a+runPara :: Style s => Para s a -> TM ps s a runPara m = do     TMState f settings pagesettings <- get-    let (a, s', boxes) = (runRWS . unPara $ closedPara ) settings f+    let (a, s', boxes) = (runRWS . unPara $ closedPara) settings f     put $! TMState s' settings pagesettings     style <- getParaStyle-    tell $ [Paragraph boxes (Just style) settings]+    tell $ [Paragraph 0 boxes (Just style) settings]     return a  where     closedPara = do+        startPara         x <- m-        endParagraph False+        endPara         return x      -- | Get the current paragraph style-getParaStyle :: TM AnyParagraphStyle-getParaStyle = gets pageSettings >>= TM . return . paraStyle+getParaStyle :: TM ps s ps+getParaStyle = gets pageSettings >>= TM . return . currentParagraphStyle  -- | Change the current paragraph style-setParaStyle :: ParagraphStyle s => s -> TM ()+setParaStyle :: ParagraphStyle ps s => ps -> TM ps s () setParaStyle style = do-    modifyStrict $ \s -> s {pageSettings = (pageSettings s){paraStyle = AnyParagraphStyle style}}+    modifyStrict $ \s -> s {pageSettings = (pageSettings s){currentParagraphStyle = style}}  -- | Add a letter to the paragraph-addLetter :: Letter -> Para ()+addLetter :: Letter s -> Para s () addLetter l = Para . tell $ [l]  -- | Add a new paragraph to the text-paragraph :: Para a -> TM a+paragraph :: Style s => Para s a -> TM ps s a paragraph = runPara  -- | Add a null char@@ -256,71 +314,74 @@ --nullChar = Para . tell $ [nullLetter]      -- | Add a text line-txt :: String -> Para ()+txt :: Style s => String -> Para s () txt t = do     f <- currentStyle     settings <- ask     tell $ splitText settings f (toPDFString t)  -- | add a kern (space that can be dilated or compressed and on which no line breaking can occur)-kern :: PDFFloat -> Para()+kern :: Style s => PDFFloat -> Para s () kern w  = do     f <- currentStyle     tell $ [kernBox f w] -setBaseLineSkip :: PDFFloat -> PDFFloat -> PDFFloat -> TM ()+setBaseLineSkip :: PDFFloat -> PDFFloat -> PDFFloat -> TM ps s () setBaseLineSkip w y z = modifyStrict $ \s -> s {pageSettings = (pageSettings s){baselineskip = (w,y,z)}}  -getBaseLineSkip :: TM (PDFFloat,PDFFloat,PDFFloat)+getBaseLineSkip :: TM ps s (PDFFloat,PDFFloat,PDFFloat) getBaseLineSkip = do     s <- gets pageSettings     return (baselineskip s)     -setLineSkipLimit :: PDFFloat  -> TM ()+setLineSkipLimit :: PDFFloat  -> TM ps s () setLineSkipLimit l = modifyStrict $ \s -> s {pageSettings = (pageSettings s){lineskiplimit=l}} -getLineSkipLimit :: TM PDFFloat+getLineSkipLimit :: TM ps s PDFFloat getLineSkipLimit = gets pageSettings >>= return . lineskiplimit -setLineSkip :: PDFFloat -> PDFFloat -> PDFFloat -> TM ()+setLineSkip :: PDFFloat -> PDFFloat -> PDFFloat -> TM ps s () setLineSkip w y z = modifyStrict $ \s -> s {pageSettings = (pageSettings s){lineskip = (w,y,z)}} -getLineSkip :: TM (PDFFloat,PDFFloat,PDFFloat)+getLineSkip :: TM ps s (PDFFloat,PDFFloat,PDFFloat) getLineSkip = gets pageSettings >>= return . lineskip     -setFirstPassTolerance :: PDFFloat -> TM ()+setFirstPassTolerance :: PDFFloat -> TM ps s () setFirstPassTolerance x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){firstPassTolerance = x}} -getFirstPassTolerance :: TM PDFFloat+getFirstPassTolerance :: TM ps s PDFFloat getFirstPassTolerance = gets paraSettings >>= return . firstPassTolerance -setSecondPassTolerance :: PDFFloat -> TM ()+setSecondPassTolerance :: PDFFloat -> TM ps s () setSecondPassTolerance x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){secondPassTolerance = x}} -getSecondPassTolerance :: TM PDFFloat+getSecondPassTolerance :: TM ps s PDFFloat getSecondPassTolerance = gets paraSettings >>= return . secondPassTolerance -setHyphenPenaltyValue :: Int -> TM ()+setHyphenPenaltyValue :: Int -> TM ps s () setHyphenPenaltyValue x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){hyphenPenaltyValue = x}} -getHyphenPenaltyValue :: TM Int+getHyphenPenaltyValue :: TM ps s Int getHyphenPenaltyValue = gets paraSettings >>= return . hyphenPenaltyValue -setFitnessDemerit :: PDFFloat -> TM ()+setFitnessDemerit :: PDFFloat -> TM ps s () setFitnessDemerit x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){fitness_demerit = x}} -getFitnessDemerit :: TM PDFFloat+getFitnessDemerit :: TM ps s PDFFloat getFitnessDemerit = gets paraSettings >>= return . fitness_demerit -setHyphenDemerit :: PDFFloat -> TM ()+setHyphenDemerit :: PDFFloat -> TM ps s () setHyphenDemerit x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){flagged_demerit = x}} -getHyphenDemerit :: TM PDFFloat+getHyphenDemerit :: TM ps s PDFFloat getHyphenDemerit = gets paraSettings >>= return . flagged_demerit   -setLinePenalty :: PDFFloat -> TM ()+setLinePenalty :: PDFFloat -> TM ps s () setLinePenalty x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){line_penalty = x}}                    -getLinePenalty :: TM PDFFloat+getLinePenalty :: TM ps s PDFFloat getLinePenalty = gets paraSettings >>= return . line_penalty +setJustification :: Justification -- ^ Centered, left or fully justified+                 -> TM ps s ()+setJustification j = modifyStrict $ \s -> s {paraSettings = (paraSettings s){centered = j}}
Graphics/PDF/Typesetting/Box.hs view
@@ -14,15 +14,13 @@     Box(..)   , DisplayableBox(..)   , AnyBox(..)-  , NullChar(..)-  , Overfull(..)   , Style(..)   , TextStyle(..)   , StyleFunction(..)-  , AnyStyle(..)   , BoxDimension   , DrawBox-   ,mkDrawBox+  , ComparableStyle(..)+  , mkDrawBox  ) where       import Graphics.PDF.LowLevel.Types@@ -71,10 +69,14 @@ -- when word styling is enabled               data StyleFunction = DrawWord -- ^ Must style a word                    | DrawGlue -- ^ Must style a glue-                   deriving(Eq)                          +                   deriving(Eq)  +                   +-- | Used to compare two style without taking into account the style state+class ComparableStyle a where   +    isSameStyleAs :: a -> a -> Bool                                        --- | Style of text  (sentences and words)       -class Style a where+-- | Style of text  (sentences and words). Minimum definition textStyle      +class ComparableStyle a => Style a where     -- ^ Modify the look of a sentence (sequence of words using the same style on a line)     sentenceStyle :: a -- ^ The style                   -> Maybe (Rectangle -> Draw b -> Draw ()) -- ^ Function receiving the bounding rectangle and the command for drawing the sentence@@ -84,34 +86,26 @@               -> Maybe (Rectangle -> StyleFunction -> Draw b -> Draw ()) -- ^ Word styling function     wordStyle _ = Nothing     textStyle :: a -> TextStyle-    -- | All styles used in a document must have different style codes-    styleCode :: a -> Int     -- | A style may contain data changed from word to word     updateStyle :: a -> a     updateStyle = id          -- | A style may change the height of words+    -- +    -- > Default implementation+    -- > styleHeight = getHeight . textFont . textStyle+    --      styleHeight :: a -> PDFFloat          -- | A style may change the descent of lines+    --+    -- > Default implementation+    -- > styleDescent = getDescent . textFont . textStyle+    --     styleDescent :: a -> PDFFloat     styleHeight = getHeight . textFont . textStyle      styleDescent = getDescent . textFont . textStyle -    --- | Any sentence style-data AnyStyle = forall a. (Style a) => AnyStyle a -instance Style AnyStyle where-    sentenceStyle (AnyStyle a) = sentenceStyle a-    wordStyle (AnyStyle a) = wordStyle a-    textStyle (AnyStyle a) = textStyle a-    styleCode (AnyStyle a) = styleCode a-    updateStyle (AnyStyle a) = AnyStyle $ updateStyle a-    styleHeight (AnyStyle a) = styleHeight a-    styleDescent (AnyStyle a) = styleDescent a--- -- | A box is an object with dimensions and used in the typesetting process class Box a where      -- | Box width@@ -138,26 +132,6 @@                -> PDFFloat -- ^ Horizontal position                -> PDFFloat -- ^ Vertical position (top of the box and NOT baseline)                -> Draw ()--data NullChar = NullChar deriving(Show)-data Overfull = Overfull AnyStyle--instance Box NullChar where-    boxWidth _  = 0-    boxHeight _ = 0-    boxDescent _ = 0-    -instance DisplayableBox NullChar where-    strokeBox _ _ _ = return ()-    -instance Box Overfull where-    boxWidth _  = 0-    boxHeight (Overfull s) = getHeight (textFont . textStyle $ s)-    boxDescent (Overfull s) = getDescent (textFont . textStyle $ s)-    -instance DisplayableBox Overfull where-    strokeBox a x y  = do-        stroke $ Line (x+2) (y - boxDescent a) (x+2) (y - boxDescent a + boxHeight a)      instance Box AnyBox where     boxWidth (AnyBox a)  = boxWidth a
Graphics/PDF/Typesetting/Breaking.hs view
@@ -20,14 +20,21 @@  , glueBox  , penalty  , spaceGlueBox- , nullLetter  , hyphenPenalty  , splitText  , MaybeGlue(..)  , defaultBreakingSettings  , BRState(..)- , glueWidth+ , glueSize  , mkLetter+ , spaceWidth+ , centeredDilatationFactor+ , leftDilatationFactor+ , rightDilatationFactor+ , dilatationRatio+ , badness+ , bigAdjustRatio+ , Justification(..)  ) where       import Graphics.PDF.LowLevel.Types@@ -37,52 +44,63 @@ import Graphics.PDF.Typesetting.Box import Data.Maybe(fromJust) --- | Create a null box-nullLetter :: Letter-nullLetter = mkLetter (0,0,0) Nothing NullChar+--import Debug.Trace +data Justification = FullJustification+                   | Centered+                   | LeftJustification+                   | RightJustification+                   deriving(Eq)+ -- | 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)+         -> Maybe s -- ^ Text style of the box (can use t)          -> a  -- ^ Box-         -> Letter+         -> Letter s 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+data Letter s = Letter BoxDimension !AnyBox !(Maybe s) -- ^ Any box as a letter+              | Glue !PDFFloat !PDFFloat !PDFFloat !(Maybe s) -- ^ A glue with style to know if it is part of the same sentence+              | FlaggedPenalty !PDFFloat !Int !s -- ^ Hyphen point+              | Penalty !Int -- ^ Penalty+              | AChar !s !Char !PDFFloat -- ^ A char+              | Kern !PDFFloat !(Maybe s) -- ^ A kern : non dilatable and non breakable glue               class MaybeGlue a where-    boxWidthWithRatio :: a -> PDFFloat -> PDFFloat+    glueY :: a -> PDFFloat+    glueZ :: a -> PDFFloat+    glueSizeWithRatio :: a -> PDFFloat -> PDFFloat     -instance MaybeGlue Letter where-    boxWidthWithRatio = letterWidth+instance MaybeGlue (Letter s) where+    glueSizeWithRatio = letterWidth+    glueY (Glue _ y _ _) = y+    glueY _ = 0+    glueZ (Glue _ _ z _) = z+    glueZ _ = 0+                 -- | Compute glue width with dilation-glueWidth :: PDFFloat -> PDFFloat -> PDFFloat -> PDFFloat -> PDFFloat-glueWidth w y z r =   +glueSize :: PDFFloat -> PDFFloat -> PDFFloat -> PDFFloat -> PDFFloat+glueSize w y z r =              if r >= 0                then                   r*y + w               else                   r*z + w                   -letterWidth :: Letter -- ^ letter+letterWidth :: Letter s -- ^ 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 (Glue w yi zi _) r =  glueSize w yi zi r letterWidth (FlaggedPenalty _ _ _) _ = 0 letterWidth (Penalty _) _ = 0 letterWidth (Kern w _) _ = w              -instance Show Letter where+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 ++  ")"@@ -93,18 +111,18 @@ type CB a = (PDFFloat,PDFFloat,PDFFloat,Int,a)  -class PointedBox a where+class PointedBox s a | a -> s where     isFlagged :: a -> Bool     getPenalty :: a -> Int     isPenalty :: a -> Bool-    letter :: a -> Letter+    letter :: a -> Letter s     position :: a -> Int     cumulatedW :: a -> PDFFloat     cumulatedY :: a -> PDFFloat     cumulatedZ :: a -> PDFFloat     isForcedBreak :: a -> Bool     -instance PointedBox (PDFFloat,PDFFloat,PDFFloat,Int,Letter)  where+instance PointedBox s (PDFFloat,PDFFloat,PDFFloat,Int,Letter s)  where     isFlagged (_,_,_,_,FlaggedPenalty _ _ _) = True         isFlagged _ = False     isPenalty (_,_,_,_,FlaggedPenalty _ _ _) = True    @@ -123,7 +141,7 @@     isForcedBreak _ = False          -instance PointedBox ZList where+instance PointedBox s (ZList s) where     isPenalty (ZList _ b _) = isPenalty b     isFlagged (ZList _ b _) = isFlagged b     letter (ZList _ b _) = letter b@@ -135,7 +153,7 @@     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 :: Letter s -> PDFFloat penaltyWidth (FlaggedPenalty w _ _) = w penaltyWidth _ = 0 @@ -151,8 +169,24 @@                             }                             deriving(Show)                             +                            +dilatationRatio :: PDFFloat -- ^ Maxw+                -> PDFFloat -- ^ Current w+                -> PDFFloat -- ^ y+                -> PDFFloat -- ^ z+                -> PDFFloat -- ^ Dilatation ratio+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+            -> ZList s             -> PDFFloat             -> PDFFloat adjustRatio a l maxw = @@ -160,13 +194,7 @@         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+    dilatationRatio maxw w y z  badness :: PDFFloat -> PDFFloat badness r = if r < (-1) then bigAdjustRatio else 100.0 * abs(r)**3.0@@ -193,10 +221,11 @@                        , fitness_demerit :: !PDFFloat -- ^ Default value 10000                        , flagged_demerit :: !PDFFloat -- ^ Default value 10000                        , line_penalty :: !PDFFloat -- ^ Default value 10+                       , centered :: !Justification -- ^ Default value false                        }                         defaultBreakingSettings :: BRState-defaultBreakingSettings = BRState 100 200 50 10000 10000 10+defaultBreakingSettings = BRState 100 200 50 10000 10000 10 FullJustification                     @@ -204,7 +233,7 @@                -> Bool                -> PDFFloat -- ^ adjust ratio                -> BreakNode -- ^ Flag for previous-               -> ZList -- ^ Flag for current+               -> ZList s -- ^ Flag for current                -> Maybe(PDFFloat,Int) -- ^ Demerit for the breakpoint computeDemerit settings sndPass r a z =     let b = badness r@@ -233,39 +262,52 @@                | OneCB !(CB a)                deriving(Show) -data ZList = ZList (MaybeCB Letter) (PDFFloat,PDFFloat,PDFFloat,Int,Letter) [Letter] deriving(Show)+data ZList s = ZList (MaybeCB (Letter s)) (PDFFloat,PDFFloat,PDFFloat,Int,Letter s) [Letter s] deriving(Show) +--currentLetter :: ZList s -> [Letter s]+--currentLetter (ZList (OneCB (_,_,_,_,s)) (_,_,_,_,a) _) = [s,a]+--currentLetter (ZList _ (_,_,_,_,a) _) = [a] -createZList :: [Letter] -> ZList+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 -> Bool+theEnd :: ZList s -> 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 :: 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 = createBreaknode prev (moveRight z) +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++-- | Get cumulated dimension for following box+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)+ -- | Create an hyphen penalty hyphenPenalty :: BRState-              -> AnyStyle -- ^ Style of future hyphen+              -> s -- ^ 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+              -> Letter s hyphenPenalty settings s w = FlaggedPenalty w (hyphenPenaltyValue settings) s -moveRight :: ZList -> ZList+moveRight :: ZList s -> ZList s moveRight (ZList _ c@(w,y,z,p,Glue w' y' z' _) r) =      let w'' = w + w'         y''=y+y'@@ -273,13 +315,14 @@     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+        let w' = glueSizeWithRatio 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+                     -> ZList s -- ^ Current analyzed box                      -> Bool -- ^ Result isFeasibleBreakpoint True (ZList _ (_,_,_,_,FlaggedPenalty _ p _) _) = p < infinity isFeasibleBreakpoint False (ZList _ (_,_,_,_,FlaggedPenalty _ _ _) _) = False@@ -306,7 +349,7 @@ -- we force a breakpoint updateWithNewRIfNoSolution :: Bool                            -> PDFFloat -- ^ Old r-                           -> ZList -- ^ Current+                           -> ZList s -- ^ Current                            -> (Int,Int,Int)                            -> PossibleBreak                            -> ActiveNodes-- ^ Actives@@ -325,9 +368,16 @@                     then                         f r (Map.delete key newmap)                     else-                        f r newmap                  +                        f r newmap   +                        +--debug b z = "(" +++--    show (cumulatedW z - totalWidth b + penaltyWidth (letter z)) ++ " " +++--    show (cumulatedY z - totalDilatation b) ++ " " +++--    show (cumulatedZ z - totalCompression b) ++ ")"   +--    +--breakTrace b z r' p = trace (debug b z ++ " " ++ show r' ++ " " ++ show (currentLetter z) ++ " " ++ show (position z) ++ " -> " ++ show p)           -getNewActiveBreakpoints ::  BRState -> Bool -> (Int -> PDFFloat) -> ActiveNodes -> ZList -> (PossibleBreak,ActiveNodes)+getNewActiveBreakpoints ::  BRState -> Bool -> (Int -> PDFFloat) -> ActiveNodes -> ZList s -> (PossibleBreak,ActiveNodes) getNewActiveBreakpoints settings sndPass fmaxw actives z =      if isFeasibleBreakpoint sndPass z     then@@ -362,7 +412,7 @@   -- Analyze the boxes to compute breaks-analyzeBoxes :: BRState -> Bool -> (Int -> PDFFloat) -> ActiveNodes -> ZList -> [(PDFFloat,Int,Bool)]+analyzeBoxes :: BRState -> Bool -> (Int -> PDFFloat) -> ActiveNodes -> ZList s -> [(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 @@ -414,13 +464,13 @@                      analyzeBoxes settings pass fmaxw newActives (moveRight z)  -- | Create an hyphen box-hyphenBox :: AnyStyle -> Letter+hyphenBox :: Style s => s -> Letter s 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 :: Style s => [Letter s] -> Int -> [(PDFFloat,Int,Bool)] -> [(PDFFloat,[Letter s],[Letter s])] cutList [] _ _ = []-cutList t _ [] = [(0.0,t)]+cutList t _ [] = [(0.0,[],t)] cutList t c ((ra,ba,fa):l) =     let (theLine,t') = splitAt (ba-c) t     in@@ -430,24 +480,24 @@       else           if null t'              then-                 [(ra,theLine)]+                 [(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 ++ [hyphenBox s]) : cutList t' ba l+                                                 (ra,theLine ++ [hyphenBox s],t) : 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+                                (ra,theLine,t) : 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 :: 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         theBreaks = analyzeBoxes settings False maxw active (createZList boxes)@@ -462,65 +512,104 @@ bigAdjustRatio = 10000.0  -- | Add a glue to the stream-glueBox :: Maybe AnyStyle+glueBox :: Maybe s         -> PDFFloat -- ^ Glue width         -> PDFFloat -- ^ Glue dilatation         -> PDFFloat -- ^ Glue compression-        -> Letter+        -> Letter s glueBox s w y z = Glue w y z s +-- | Return the standard space width+spaceWidth :: Style s => s -- ^ The style+           -> PDFFloat+spaceWidth  s =  +    let ws = (textWidth (textFont . textStyle $ s) (toPDFString " ") )+        h = scaleSpace . textStyle $ s+    in+      ws * h  +   +-- | How much dilatation is allowed compred to the space width   +centeredDilatationFactor :: PDFFloat+centeredDilatationFactor = 10.0       ++-- | How much dilatation is allowed compared to the space width   +leftDilatationFactor :: PDFFloat+leftDilatationFactor = 20.0++-- | How much dilatation is allowed compared to the space width   +rightDilatationFactor :: PDFFloat+rightDilatationFactor = 20.0+ -- | Add a glue to the stream-spaceGlueBox :: AnyStyle -- ^ The style-             -> Letter-spaceGlueBox s = +spaceGlueBox :: Style s => BRState -- ^ Paragraph settings+             -> s -- ^ The style+             -> 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-     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)-  +     case (centered settings) of+        FullJustification -> [Glue (ws*h) (h*sy*ws/2.0*f) (h*sz*ws/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)+                              ]                    +                           -- | Add a penalty to the stream penalty :: Int -- ^ Penalty value-        -> Letter+        -> Letter s penalty p = Penalty p  -- | Create a box containing text-createChar :: AnyStyle -- ^ Char style+createChar :: s -- ^ Char style            -> PDFFloat -- ^ Char width            -> Char -- ^ Char code-           -> Letter+           -> Letter s createChar s w t = AChar s t w   -- | Create boxes for the letters-createLetterBoxes :: BRState-                  -> AnyStyle -- ^ Letter style+createLetterBoxes :: Style s => BRState+                  -> s -- ^ Letter style                   -> [(PDFFloat,Char)] -- ^ Letter and size -                  -> [Letter] -- ^ Boxes+                  -> [Letter s] -- ^ 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 ((wa,'.'):b@(_,bc):l') | bc /= ' ' = (createChar s wa '.') : ((spaceGlueBox settings s 2.0) ++ (createLetterBoxes settings s (b:l') ))+                                                    | otherwise = (createChar s wa '.') : ((spaceGlueBox settings s 2.0) ++ (createLetterBoxes settings s l'))+createLetterBoxes settings s ((wa,','):b@(_,bc):l') | bc /= ' ' = (createChar s wa ',') : ((spaceGlueBox settings s 2.0) ++ (createLetterBoxes settings s (b:l') ))+                                                    | otherwise = (createChar s wa ',') : ((spaceGlueBox settings s 2.0) ++ (createLetterBoxes settings s l'))+createLetterBoxes settings s ((wa,';'):b@(_,bc):l') | bc /= ' ' = (createChar s wa ';') : ((spaceGlueBox settings s 2.0) ++ (createLetterBoxes settings s (b:l') ))+                                                    | otherwise = (createChar s wa ';') : ((spaceGlueBox settings s 2.0) ++ (createLetterBoxes settings s l'))+createLetterBoxes settings s ((wa,'!'):b@(_,bc):l') | bc /= ' ' = (createChar s wa '!') : ((spaceGlueBox settings s 2.0) ++ (createLetterBoxes settings s (b:l') ))+                                                    | otherwise = (createChar s wa '!') : ((spaceGlueBox settings s 2.0) ++ (createLetterBoxes settings s l'))+createLetterBoxes settings s ((wa,'?'):b@(_,bc):l') | bc /= ' ' = (createChar s wa '?') : ((spaceGlueBox settings s 2.0) ++ (createLetterBoxes settings s (b:l') ))+                                                    | otherwise = (createChar s wa '?') : ((spaceGlueBox settings s 2.0) ++ (createLetterBoxes settings s l'))+createLetterBoxes settings s ((wa,':'):b@(_,bc):l') | bc /= ' ' = (createChar s wa ':') : ((spaceGlueBox settings s 2.0) ++ (createLetterBoxes settings s (b:l') ))+                                                    | otherwise = (createChar s wa ':') : ((spaceGlueBox settings s 2.0) ++ (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 ((_,' '):l) = (spaceGlueBox settings s 1.0) ++ 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 :: Style s => BRState -> s -> PDFString -> [Letter s] splitText settings f t  = createLetterBoxes settings f . ripText (textFont . textStyle $ f) $ t -kernBox :: AnyStyle -> PDFFloat -> Letter+kernBox :: s -> PDFFloat -> Letter s kernBox s w = Kern w (Just s)
Graphics/PDF/Typesetting/Horizontal.hs view
@@ -38,10 +38,10 @@ -- WARNING -- According to splitText, PDFText to concatenate ARE letters so we can optimize the code -- Sentences are created when no word style is present, otherwise we just create words-createWords :: PDFFloat -- ^ Adjustement ratio-            -> Maybe (AnyStyle,String, PDFFloat) -- ^ Current word-            -> [Letter] -- ^ List of letters-            -> [HBox] -- ^ List of words or sentences+createWords :: ComparableStyle s => PDFFloat -- ^ Adjustement ratio+            -> Maybe (s,String, PDFFloat) -- ^ Current word+            -> [Letter s] -- ^ List of letters+            -> [HBox s] -- ^ List of words or sentences  createWords _ Nothing [] = [] -- Empty list, current word or sentence is added@@ -50,7 +50,7 @@ -- Start of a new word createWords r Nothing ((AChar s t w):l) = createWords r (Just (s,[t],w)) l -- New letter. Same style added to the word. Otherwise we start a new word-createWords r (Just (s,t,w)) ((AChar s' t' w'):l) | styleCode s == styleCode s' = createWords r (Just (s,t':t,w+w')) l+createWords r (Just (s,t,w)) ((AChar s' t' w'):l) | s `isSameStyleAs` s' = createWords r (Just (s,t':t,w+w')) l                                                   | otherwise = (createText s (saveCurrentword $ t) w):createWords r (Just (s',[t'],w')) l                                                                -- Glue close the word and start a new one because we want glues of different widths in the PDF@@ -72,37 +72,37 @@                -- Remove glues and penalties at the beginning of a line-simplify :: PDFFloat -- ^ Adjustement ratio-         -> [Letter] -- ^ List of letters-         -> [HBox] -- ^ List of words or sentence+simplify :: ComparableStyle s => PDFFloat -- ^ Adjustement ratio+         -> [Letter s] -- ^ List of letters+         -> [HBox s] -- ^ List of words or sentence simplify r ((Glue _ _ _ _):l) = simplify r l simplify r ((FlaggedPenalty _ _ _):l) = simplify r l simplify r ((Penalty _):l) = simplify r l simplify r l = createWords r Nothing l  -- | horizontalPostProcess-horizontalPostProcess :: [(PDFFloat,[Letter])] -- ^ adjust ratio, hyphen style, list of letters or boxes-                      -> [HBox] -- ^ List of lines+horizontalPostProcess :: (Style s) => [(PDFFloat,[Letter s],[Letter s])] -- ^ adjust ratio, hyphen style, list of letters or boxes+                      -> [(HBox s,[Letter s])] -- ^ List of lines horizontalPostProcess [] = []-horizontalPostProcess ((r,l'):l) = let l'' = simplify r l' in+horizontalPostProcess ((r,l',r'):l) = let l'' = simplify r l' in   if null l''       then           horizontalPostProcess l       else-          (mkHboxWithRatio r l''):horizontalPostProcess l +          ((mkHboxWithRatio r l''),r'):horizontalPostProcess l    -- | An horizontal Hbox (sentence or word) -- The width of the glue was computed with the adjustement ratio of the HLine containing the glue -- The width of the text is already taking into account the adjustement ratio of the HLine containing the Text -- Otherwise, HBox cannot dilate or compress. -data HBox  = HBox !PDFFloat !PDFFloat !PDFFloat ![HBox]-           | HGlue !PDFFloat !(Maybe (PDFFloat,PDFFloat)) !(Maybe AnyStyle)-           | Text !AnyStyle !PDFString !PDFFloat-           | SomeHBox !BoxDimension !AnyBox !(Maybe AnyStyle)+data HBox s = HBox !PDFFloat !PDFFloat !PDFFloat ![HBox s]+            | HGlue !PDFFloat !(Maybe (PDFFloat,PDFFloat)) !(Maybe s)+            | Text !s !PDFString !PDFFloat+            | SomeHBox !BoxDimension !AnyBox !(Maybe s)       -- | Change the style of the box      -withNewStyle :: AnyStyle -> HBox -> HBox+withNewStyle :: s -> HBox s -> HBox s withNewStyle _ a@(HBox _ _ _ _) = a withNewStyle s (HGlue a b _) = HGlue a b (Just s) withNewStyle s (Text _ a b) = Text s a b@@ -111,44 +111,47 @@ -- | A line of hboxes with an adjustement ratio required to display the text (generate the PDF command to increase space size)        --data HLine = HLine !PDFFloat ![HBox] deriving(Show) -mkHboxWithRatio :: PDFFloat -- ^ Adjustement ratio-                -> [HBox]-                -> HBox-mkHboxWithRatio _ [] = SomeHBox (0,0,0) (AnyBox NullChar) Nothing+mkHboxWithRatio :: Style s => PDFFloat -- ^ Adjustement ratio+                -> [HBox s]+                -> HBox s+mkHboxWithRatio _ [] = error "Cannot create an empty horizontal box" mkHboxWithRatio r l = -    let w = foldl' (\x y -> x + boxWidthWithRatio y r) 0.0 l+    let w = foldl' (\x y -> x + glueSizeWithRatio y r) 0.0 l         --h = maximum . map boxHeight $ l         ascent = maximum . map boxAscent $ l         d = maximum . map boxDescent $ l         h = ascent + d-        addBox (HGlue gw (Just(y,z)) s) (HBox w' h' d' l') = HBox w' h' d' (HGlue (glueWidth gw y z r) Nothing s:l')+        addBox (HGlue gw (Just(y,z)) s) (HBox w' h' d' l') = HBox w' h' d' (HGlue (glueSize gw y z r) Nothing s:l')         addBox a (HBox w' h' d' l') = HBox w' h' d' (a:l')         addBox _ _ = error "We can add boxes only to an horizontal list"     in     -- Add boxes and dilate glues when needing fixing their dimensions after dilatation     foldr addBox (HBox w h d []) l     -instance MaybeGlue HBox where-    boxWidthWithRatio (HGlue w (Just(y,z)) _) r = glueWidth w y z r-    boxWidthWithRatio a _ = boxWidth a-                        -  +instance Style s => MaybeGlue (HBox s) where+    glueSizeWithRatio (HGlue w (Just(y,z)) _) r = glueSize w y z r+    glueSizeWithRatio a _ = boxWidth a+    glueY (HGlue _ (Just(y,_)) _)  = y+    glueY _ = 0+    glueZ (HGlue _ (Just(_,z)) _)  = z+    glueZ _ = 0+     -- | Create an HBox           -createText :: Style s => s -- ^ Style+createText :: s -- ^ Style            -> PDFString -- ^ String            -> PDFFloat -- ^ Width-           -> HBox-createText s t w = Text (AnyStyle s) t w+           -> HBox s+createText s t w = Text s t w  -instance Show HBox where+instance Show (HBox s) where    show (HBox _ _ _ a) = "(HBox " ++ show a ++ ")"    show (HGlue a _ _) = "(HGlue " ++ show a ++ ")"    show (Text _ t _) = "(Text " ++ show t ++ ")"    show (SomeHBox _ t _) = "(SomeHBox " ++ show t ++ ")"  -- | Draw a line of words and glue using the word style-drawTextLine :: AnyStyle -> [HBox] -> PDFFloat -> PDFFloat -> Draw ()+drawTextLine :: (Style s) => s -> [HBox s] -> PDFFloat -> PDFFloat -> Draw () drawTextLine  _ [] _ _ = return () drawTextLine  style l@(a:l') x y | (isJust . wordStyle $ style) =  do     let  h = boxHeight a@@ -159,7 +162,7 @@                                  | otherwise = drawWords style l x y      -- | Draw a line of words, glue, or any box without word style-drawWords :: AnyStyle -> [HBox] -> PDFFloat -> PDFFloat -> Draw ()+drawWords :: (Style s) => s -> [HBox s] -> PDFFloat -> PDFFloat -> Draw () drawWords _ [] _ _ = return ()  drawWords s ((Text _ t w):l) x y = do@@ -185,7 +188,7 @@ drawWords _ _ _ _ = return ()  -- | Draw only words and glues using PDF text commands-drawPureWords :: AnyStyle -> [HBox] -> PDFFloat -> PDFFloat -> PDFText ([HBox],PDFFloat)  +drawPureWords :: Style s => s -> [HBox s] -> PDFFloat -> PDFFloat -> PDFText ([HBox s],PDFFloat)    drawPureWords s [] x y = do     drawTheTextBox StopText s x y Nothing@@ -206,7 +209,7 @@ drawPureWords s (_:l) x y = drawPureWords s l x y     -- When a start of line is detected by drawLineOfHBoxes, we start the drawing-startDrawingNewLineOfText :: PDFFloat -> PDFFloat -> [HBox] -> PDFFloat -> PDFFloat -> AnyStyle -> Draw ()+startDrawingNewLineOfText :: (Style s) => PDFFloat -> PDFFloat -> [HBox s] -> PDFFloat -> PDFFloat -> s -> Draw () startDrawingNewLineOfText hl dl l x y style =      do            -- Position of draw line based upon the whole line and not just this word@@ -221,9 +224,9 @@        drawLineOfHboxes hl dl l'' (x + w') y      -drawLineOfHboxes :: PDFFloat -- ^ Height of the total line first time this function is called+drawLineOfHboxes :: (Style s) => PDFFloat -- ^ Height of the total line first time this function is called                  -> PDFFloat -- ^ Descent of the total line first time this function is called-                 -> [HBox] -- ^ Remaining box to display+                 -> [HBox s] -- ^ Remaining box to display                  -> PDFFloat -- ^ x for the remaining boxes                  -> PDFFloat -- ^ y for the whole line                  -> Draw ()@@ -240,7 +243,7 @@       strokeBox a x y'       drawLineOfHboxes hl dl l (x + boxWidth a) y -instance Box HBox where+instance Style s => Box (HBox s) where      boxWidth (Text _ _ w) = w      boxWidth (HBox w _ _ _) = w      boxWidth (SomeHBox d _ _)  = boxWidth d@@ -272,6 +275,7 @@      strokeColor (textStrokeColor . textStyle $ style)      fillColor (textFillColor . textStyle $ style)      renderMode (textMode . textStyle $ style)+     setWidth (penWidth . textStyle $ style)      textStart x y      tell $ mconcat [newline,lbracket])   -- Here we need to dilate the space to take into account r and the font setting@@ -302,7 +306,7 @@                       | OneBlock -- ^ One block of text                       deriving(Eq)               -instance DisplayableBox HBox where+instance (Style s) => DisplayableBox (HBox s) where      strokeBox a@(HBox _ _ _ l) x y = do          let he = boxHeight a              de = boxDescent a@@ -336,10 +340,10 @@      strokeBox (HGlue _ _ _) _ _ = return ()        -- Test is a box has same style-isSameStyle :: Style s => s -         -> HBox+isSameStyle :: (Style s) => s +         -> HBox s          -> Bool-isSameStyle s (Text style _ _) = styleCode s == styleCode style-isSameStyle s (HGlue _ _ (Just style)) = styleCode s == styleCode style-isSameStyle s (SomeHBox _ _ (Just style)) = styleCode s == styleCode style+isSameStyle s (Text style _ _) = s `isSameStyleAs` style+isSameStyle s (HGlue _ _ (Just style)) = s `isSameStyleAs` style+isSameStyle s (SomeHBox _ _ (Just style)) = s `isSameStyleAs` style isSameStyle _ _ = False
+ Graphics/PDF/Typesetting/Layout.hs view
@@ -0,0 +1,334 @@+---------------------------------------------------------+-- |+-- Copyright   : (c) alpha 2006+-- License     : BSD-style+--+-- Maintainer  : misc@NOSPAMalpheccar.org+-- Stability   : experimental+-- Portability : portable+--+-- Box+---------------------------------------------------------+-- #hide+module Graphics.PDF.Typesetting.Layout (++   Container(..)+ , Width+ , Height+ , VBox(..)+ , ParagraphStyle(..)+ , VerState(..)+ , vglue+ , addTo+ , isOverfull+ , mkContainer+ , strokeVBoxes+ , containerX+ , containerY+ , containerWidth+ , containerHeight+ , containerContentHeight+ , containerContentRightBorder+ , containerContentLeftBorder+ , containerCurrentHeight+ , containerContentRectangle+ ) where++import Graphics.PDF.LowLevel.Types+import Graphics.PDF.Typesetting.Breaking+import Graphics.PDF.Draw+import Graphics.PDF.Shapes(Rectangle(..))+import Graphics.PDF.Typesetting.Box+import Data.List(foldl')+import Data.Maybe(isJust,fromJust)+++data VerState s = VerState { baselineskip :: !(PDFFloat,PDFFloat,PDFFloat) -- ^ Default value (12,0.17,0.0)+                           , lineskip :: !(PDFFloat,PDFFloat,PDFFloat) -- ^ Default value (3.0,0.33,0.0)+                           , lineskiplimit :: !PDFFloat -- ^ Default value 2+                           , currentParagraphStyle :: !s+                           }+                           +data VBox ps s = Paragraph Int [Letter s] !(Maybe ps) !BRState+               | VBox !PDFFloat !PDFFloat !PDFFloat ![VBox ps s] !(Maybe ps)+               | VGlue !PDFFloat !PDFFloat !PDFFloat !(Maybe (PDFFloat,PDFFloat)) !(Maybe ps)+               | SomeVBox !PDFFloat !BoxDimension !AnyBox !(Maybe ps)++notGlue :: VBox ps s -> Bool+notGlue (VGlue _ _ _ _ _) = False+notGlue (Paragraph _ _ _ _) = False+notGlue _ = True+                              +vglue :: Maybe ps+     -> PDFFloat -- ^ Glue height+     -> PDFFloat -- ^ Glue dilatation factor+     -> PDFFloat -- ^ Glue compression factor+     -> PDFFloat -- ^ Glue width+     -> PDFFloat -- ^ Glue delta+     -> VBox ps s+vglue s h y z width delta = VGlue h width delta (Just(y,z)) s++instance Show (VBox ps s) where+ show (VBox _ a _ l _) = "(VBox " ++ show a ++ " " ++ show l ++ ")"+ show (VGlue a _ _ _ _) = "(VGlue " ++ show a ++ ")"+ show (Paragraph _ _ _ _) = "(Paragraph)"+ show (SomeVBox _ d t _) = "(SomeVBox " ++ show (boxHeight d) ++ " " ++ show t ++ ")"++instance MaybeGlue (VBox ps s) where+  glueSizeWithRatio (VGlue w _ _ (Just(y,z)) _) r = glueSize w y z r+  glueSizeWithRatio a _ = boxHeight a+  +  glueY (VGlue _ _ _ (Just(y,_)) _)  = y+  glueY _ = 0+  glueZ (VGlue _ _ _ (Just(_,z)) _)  = z+  glueZ _ = 0++instance Box (VBox ps s) where+   boxWidth (Paragraph _ _ _ _) = 0+   boxWidth (VBox w _ _ _ _) = w+   boxWidth (SomeVBox _ d _ _)  = boxWidth d+   boxWidth (VGlue _ w _ _ _)  = w++   boxHeight (Paragraph _ _ _ _) = 0+   boxHeight (VBox _ h _ _ _) = h+   boxHeight (SomeVBox _ d _ _) = boxHeight d+   boxHeight (VGlue h _ _ _ _) = h++   boxDescent (Paragraph _ _ _ _) = 0+   boxDescent (VBox _ _ d _ _) = d+   boxDescent (SomeVBox _ d _ _) = boxDescent d+   boxDescent (VGlue _ _ _ _ _) = 0++instance (ParagraphStyle ps s) => DisplayableBox (VBox ps s) where+        strokeBox (Paragraph _ _ _ _) _ _ = return ()+        strokeBox b@(VBox _ _ _ l _) x y'' = strokeVBoxes l x y'+          where+              y' = y'' - boxHeight b+        strokeBox (VGlue h w delta _ (Just style)) x y = +            if (isJust . interline $ style)+                then+                    (fromJust . interline $ style) $ Rectangle (x+delta) (y-h) (x+w+delta) y+                else+                   return()+        strokeBox (VGlue _ _ _ _ _) _ _ = return ()++        strokeBox (SomeVBox delta _ a _) x y = strokeBox a (x+delta) y+                +type Width = PDFFloat+type Height = PDFFloat++-- | Container for vboxes (x,y,width,maxheight,height,currenty,current z)+data Container ps s = Container PDFFloat PDFFloat Width PDFFloat PDFFloat PDFFloat PDFFloat [VBox ps s]++-- | Create a empty container to constraint the amount of line that can be displayed+mkContainer :: PDFFloat -- ^ x+            -> PDFFloat -- ^ y+            -> PDFFloat -- ^ width+            -> PDFFloat -- ^ height+            -> Container ps s -- ^ New container+mkContainer x y width height  = Container x y width height 0 0 0 []            ++-- | Get the width of the container+containerWidth :: Container ps s -> PDFFloat+containerWidth (Container _ _ w _ _ _ _ _) = w++-- | Get the height of the container+containerHeight :: Container ps s -> PDFFloat+containerHeight (Container _ _ _ h _ _ _ _) = h++-- | Get the current height of the container without glue dilatation+containerCurrentHeight :: Container ps s -> PDFFloat+containerCurrentHeight (Container _ _ _ _ ch _ _ _) = ch++-- | Get the content height of the container with glue dilatation+containerContentHeight :: Container ps s -> PDFFloat+containerContentHeight (Container _ _ _ maxh h y z _) = let r = min (dilatationRatio maxh h y z) 2.0 in+ glueSize h y z r+ +-- | Get the minimum left border of the container content+containerContentLeftBorder :: Container ps s -> PDFFloat+containerContentLeftBorder (Container _ _ _ _ _ _ _ []) = 0.0+containerContentLeftBorder (Container _ _ _ _ _ _ _ l) = minimum . map getBoxDelta $ l+   +-- | Get the maximum right border of the container content (maybe bigger than container width due to overfull lines)+containerContentRightBorder :: Container ps s -> PDFFloat+containerContentRightBorder (Container _ _ _ _ _ _ _ []) = 0.0+containerContentRightBorder (Container _ _ _ _ _ _ _ l) = + let xmax = maximum . map rightBorder $ l+     rightBorder x = getBoxDelta x + boxWidth x+ in+  xmax++-- | Container horizontal position+containerX :: Container ps s -> PDFFloat+containerX (Container x _ _ _ _ _ _ _) = x++-- | Container vertical position+containerY :: Container ps s -> PDFFloat+containerY (Container _ y _ _ _ _ _ _) = y++-- | Return the rectangle containing the text after formatting and glue dilatation+containerContentRectangle :: Container ps s -> Rectangle+containerContentRectangle c = Rectangle (x+l) (y-th) (x+r) y + where+    x = containerX c+    y = containerY c+    th = containerContentHeight c+    l = containerContentLeftBorder c+    r = containerContentRightBorder c+++-- | Get the required style for the interline glue+getInterlineStyle :: ComparableStyle ps => VBox ps s -> VBox ps s -> Maybe ps+getInterlineStyle (VBox _ _ _ _ (Just s)) (SomeVBox _ _ _ (Just s')) | s `isSameStyleAs` s' = Just s+                                                                     | otherwise = Nothing++getInterlineStyle (VBox _ _ _ _ (Just s)) (VBox _ _ _ _ (Just s')) |  s `isSameStyleAs`  s' = Just s+                                                                   | otherwise = Nothing++getInterlineStyle (SomeVBox _ _ _ (Just s)) (SomeVBox _ _ _ (Just s')) |  s `isSameStyleAs`  s' = Just s+                                                                       | otherwise = Nothing++getInterlineStyle (SomeVBox _ _ _ (Just s)) (VBox _ _ _ _ (Just s')) |  s `isSameStyleAs`  s' = Just s+                                                                     | otherwise = Nothing++getInterlineStyle _ _ = Nothing++-- | Interline glue required+interlineGlue :: ComparableStyle ps => VerState ps -> VBox ps s -> VBox ps s -> Maybe (VBox ps s, PDFFloat, PDFFloat)+interlineGlue settings a b | notGlue a && notGlue b = +    let p = boxDescent a+        h = boxHeight b - boxDescent b+        (ba,by,bz) = baselineskip settings+        (lw,ly,lz) = lineskip settings+        li = lineskiplimit settings+        istyle = getInterlineStyle a b+        theWidth = boxWidth a+        theDelta = getBoxDelta a+    in+    if p <= -1000 +        then+            Nothing+        else+            if ba - p - h >= li+                then+                    Just $ (vglue istyle (ba-p-h) by bz theWidth theDelta,by,bz)+                else+                    Just $ (vglue istyle lw ly lz theWidth theDelta,ly,lz)+                                  | otherwise = Nothing++addTo :: ComparableStyle ps => VerState ps -> VBox ps s -> Container ps s -> Container ps s+addTo _ line (Container px py w maxh h y z []) = Container px py w maxh ((boxHeight line)+h) y z [line]+addTo settings line (Container px py w maxh h y z l@(a:_)) = +    case interlineGlue settings a line of+        Nothing ->+          let h' = boxHeight line + h +              y' = y + glueY line+              z' = z + glueZ line+          in+          Container px py w maxh h' y' z' (line:l)+        Just (v,ny,nz) ->+          let h' = boxHeight line + h + boxHeight v+              y' = y + ny + glueY line+              z' = z + nz + glueZ line+          in+          Container px py w maxh h' y' z' (line:v:l)+          +isOverfull :: Container ps s -> Bool+isOverfull (Container _ _ _ maxh h y z _) = let r = dilatationRatio maxh h y z+ in+   if r >= bigAdjustRatio then h > maxh else r <= -1++++-- | Paragraph style+class (ComparableStyle a, Style s) => ParagraphStyle a s | a -> s where+    -- | Width of the line of the paragraph+    lineWidth :: a -- ^ The style+               -> PDFFloat -- ^ Width of the text area used by the typesetting algorithm+               -> Int -- ^ Line number+               -> PDFFloat -- ^ Line width+    +    -- | Horizontal shift of the line position relatively to the left egde of the paragraph bounding box+    linePosition :: a -- ^ The style +                  -> PDFFloat -- ^ Width of the text area used by the typesetting algorithm+                  -> Int -- ^ Line number +                  -> PDFFloat -- ^ Horizontal offset from the left edge of the text area+    +    -- | How to style the interline glues added in a paragraph by the line breaking algorithm+    interline :: a -- ^ The style +              -> Maybe (Rectangle -> Draw ()) -- ^ Function used to style interline glues+    interline _ = Nothing+    lineWidth _ w _ = w+    linePosition _ _ = const 0.0+    +    -- | Change the content of a paragraph before the line breaking algorithm is run. It may also change the style+    paragraphChange :: a -- ^ The style+               -> [Letter s] -- ^ List of letters in the paragraph+               -> (a,[Letter s]) -- ^ Update style and list of letters+    paragraphChange a l = (a,l)+    +    -- | Get the paragraph bounding box and the paragraph draw command to apply additional effects+    paragraphStyle :: a -- ^ The style +                   -> Maybe (Rectangle -> Draw b -> Draw ()) -- ^ Function used to style a paragraph+    paragraphStyle _ = Nothing++-- | Get the delta used to position a box with non rectangular shapes+getBoxDelta :: VBox ps s -> PDFFloat+getBoxDelta (Paragraph _ _ _ _) = 0.0+getBoxDelta (VBox _ _ _ _ _) = 0.0+getBoxDelta (VGlue _ _ delta _ _) = delta+getBoxDelta (SomeVBox delta _ _ _) = delta+++++isSameParaStyle :: ComparableStyle ps => ps -> VBox ps s -> Bool+isSameParaStyle s (Paragraph _ _ (Just s') _) =  s `isSameStyleAs`  s'+isSameParaStyle s (VBox _ _ _ _ (Just s')) =  s `isSameStyleAs`  s'+isSameParaStyle s (VGlue _ _ _ _ (Just s')) =  s `isSameStyleAs`  s'+isSameParaStyle s (SomeVBox _ _ _ (Just s'))  =  s `isSameStyleAs`  s'     +isSameParaStyle _ _ = False++recurseStrokeVBoxes :: (ParagraphStyle ps s) => Int -> [VBox ps s] -> PDFFloat -> PDFFloat -> Draw ()+recurseStrokeVBoxes _ [] _ _  = return ()+recurseStrokeVBoxes _ (Paragraph _ _ _ _:_) _ _ = return ()+recurseStrokeVBoxes nb (a@(VGlue _ _ _ _ _):l) xa y  = do+    let h = boxHeight a+    strokeBox a xa y+    recurseStrokeVBoxes nb l xa (y-h)++recurseStrokeVBoxes nb (a:l) xa y = do+    let h = boxHeight a+    strokeBox a xa y+    recurseStrokeVBoxes (nb+1) l xa (y-h)++drawWithParaStyle :: (ParagraphStyle ps s) => ps -> [VBox ps s] -> PDFFloat -> PDFFloat -> Draw ()   +drawWithParaStyle style b xa y' = do+    let  (l',l'') = span (isSameParaStyle style) b+         h' = foldl' (\x' ny -> x' + boxHeight ny) 0.0 l'+    if (isJust . paragraphStyle $ style)+      then do+          let xleft = (minimum $ 100000:map getBoxDelta l' ) + xa+              xright = (maximum $ 0:(map (\x -> boxWidth x + getBoxDelta x) l')) + xa+          (fromJust . paragraphStyle $ style) (Rectangle xleft (y'- h') xright (y')) (recurseStrokeVBoxes 1 l' xa y')+      else+         recurseStrokeVBoxes 1 l' xa y'+    strokeVBoxes l'' xa (y' - h')++-- | Stroke the VBoxes+strokeVBoxes :: (ParagraphStyle ps s) => [VBox ps s] -- ^ List of boxes+             -> PDFFloat -- ^ X pos+             -> PDFFloat -- ^ Y pos+             -> Draw ()+strokeVBoxes [] _ _ = return ()+strokeVBoxes b@((Paragraph _ _ (Just s') _):_) xa y = drawWithParaStyle s' b xa y +strokeVBoxes b@((VBox _ _ _ _ (Just s')):_) xa y = drawWithParaStyle s' b xa y +strokeVBoxes b@((VGlue _ _ _ _ (Just s')):_) xa y = drawWithParaStyle s' b xa y+strokeVBoxes b@((SomeVBox _ _ _ (Just s')):_) xa y = drawWithParaStyle s' b xa y+strokeVBoxes (a:l) xa y = +    do+        let h = boxHeight a+        strokeBox a xa y+        strokeVBoxes l xa (y-h)+
+ Graphics/PDF/Typesetting/StandardStyle.hs view
@@ -0,0 +1,41 @@+---------------------------------------------------------+-- |+-- Copyright   : (c) alpha 2007+-- License     : BSD-style+--+-- Maintainer  : misc@NOSPAMalpheccar.org+-- Stability   : experimental+-- Portability : portable+--+-- Standard styles for typesettings+---------------------------------------------------------+-- #hide+module Graphics.PDF.Typesetting.StandardStyle(+ -- * Styles+   StandardStyle(..)+ , StandardParagraphStyle(..)+ ) where+     +import Graphics.PDF.Colors+import Graphics.PDF.Text+import Graphics.PDF.Typesetting.Vertical+import Graphics.PDF.Typesetting.Box+     +-- | Standard styles for sentences+data StandardStyle = Font PDFFont Color Color++-- | Standard styles for paragraphs+data StandardParagraphStyle = NormalParagraph+++instance ComparableStyle StandardStyle where+  isSameStyleAs (Font a sca fca) (Font b scb fcb) = a == b && sca == scb && fca == fcb+  --isSameStyleAs _ _ = False+    +instance ComparableStyle StandardParagraphStyle where+  isSameStyleAs NormalParagraph NormalParagraph = True +  +instance Style StandardStyle where+    textStyle (Font a sc fc) = TextStyle a sc fc FillText 1.0 1.0 1.0 1.0    ++instance ParagraphStyle StandardParagraphStyle StandardStyle
Graphics/PDF/Typesetting/Vertical.hs view
@@ -11,306 +11,149 @@ --------------------------------------------------------- -- #hide module Graphics.PDF.Typesetting.Vertical (-    VBox(..)-  , VerState(..)-  , verticalPostProcess-  , mkVboxWithRatio-  , strokeVBoxes+    mkVboxWithRatio   , vglue   , defaultVerState   , ParagraphStyle(..)-  , AnyParagraphStyle(..)+  , VerState(..)+  , fillContainer+  , mkContainer+  , VBox(..)  ) where   import Graphics.PDF.LowLevel.Types import Graphics.PDF.Typesetting.Breaking import Graphics.PDF.Typesetting.Horizontal(horizontalPostProcess,HBox) import Graphics.PDF.Draw-import Graphics.PDF.Shapes(Rectangle(..)) import Graphics.PDF.Typesetting.Box import Data.List(foldl')-import Data.Maybe(isJust,fromJust)--data VerState = VerState { baselineskip :: !(PDFFloat,PDFFloat,PDFFloat) -- ^ Default value (12,0.17,0.0)-                         , lineskip :: !(PDFFloat,PDFFloat,PDFFloat) -- ^ Default value (3.0,0.33,0.0)-                         , lineskiplimit :: !PDFFloat -- ^ Default value 2-                         , paraStyle :: !AnyParagraphStyle-                         }+import Graphics.PDF.Typesetting.Layout         -defaultVerState :: ParagraphStyle s => s -> VerState                 +-- | Default vertical state+--+-- > Default values+-- > baselineskip = (12,0.17,0.0)+-- > lineskip = (3.0,0.33,0.0)+-- > lineskiplimit = 2+--+defaultVerState :: s -> VerState s                 defaultVerState s = VerState { baselineskip = (12,0.17,0.0)                              , lineskip = (3.0,0.33,0.0)                              , lineskiplimit = 2-                             , paraStyle = AnyParagraphStyle s+                             , currentParagraphStyle = s                              }  -- | Pair of functions describing the shape of a text areas : horizontal position of each line, vertical top of the area, width of each line -- First line is 1 -data VBox  = Paragraph [Letter] !(Maybe AnyParagraphStyle) !BRState-           | VBox !PDFFloat !PDFFloat !PDFFloat ![VBox] !(Maybe AnyParagraphStyle)-           | VGlue !PDFFloat !PDFFloat !PDFFloat !(Maybe (PDFFloat,PDFFloat)) !(Maybe AnyParagraphStyle)-           | SomeVBox !PDFFloat !BoxDimension !AnyBox !(Maybe AnyParagraphStyle)+            -vglue :: Maybe AnyParagraphStyle-      -> PDFFloat -- ^ Glue height-      -> PDFFloat -- ^ Glue dilatation factor-      -> PDFFloat -- ^ Glue compression factor-      -> PDFFloat -- ^ Glue width-      -> PDFFloat -- ^ Glue delta-      -> VBox-vglue s h y z width delta = VGlue h width delta (Just(y,z)) s -instance Show VBox where-  show (VBox _ _ _ a _) = "(HBox " ++ show a ++ ")"-  show (VGlue a _ _ _ _) = "(HGlue " ++ show a ++ ")"-  show (Paragraph _ _ _) = "(Paragraph)"-  show (SomeVBox _ _ t _) = "(SomeHBox " ++ show t ++ ")"                           -- | A line of hboxes with an adjustement ratio required to display the text (generate the PDF command to increase space size)        --data HLine = HLine !PDFFloat ![HBox] deriving(Show)  mkVboxWithRatio :: PDFFloat -- ^ Adjustement ratio-                -> [VBox]-                -> VBox-mkVboxWithRatio _ [] = SomeVBox 0.0 (0,0,0) (AnyBox NullChar) Nothing+                -> [VBox ps s]+                -> VBox ps s+mkVboxWithRatio _ [] = error "Cannot make an empty vbox" mkVboxWithRatio r l = -   let w = foldl' (\x y -> x + boxWidthWithRatio y r) 0.0 l+   let w = foldl' (\x y -> x + glueSizeWithRatio y r) 0.0 l        h = maximum . map boxHeight $ l        d = maximum . map boxDescent $ l-       addBox (VGlue gw gh gdelta (Just(y,z)) s) (VBox w' h' d' l' s') = VBox w' h' d' (VGlue (glueWidth gw y z r) gh gdelta Nothing s:l') s'+       addBox (VGlue gw gh gdelta (Just(y,z)) s) (VBox w' h' d' l' s') = VBox w' h' d' (VGlue (glueSize gw y z r) gh gdelta Nothing s:l') s'        addBox a (VBox w' h' d' l' s') = VBox w' h' d' (a:l') s'        addBox _ _ = error "We can add boxes only to an horizontal list"    in    -- Add boxes and dilate glues when needing fixing their dimensions after dilatation    foldr addBox (VBox w h d [] Nothing) l -instance MaybeGlue VBox where-   boxWidthWithRatio (VGlue w _ _ (Just(y,z)) _) r = glueWidth w y z r-   boxWidthWithRatio a _ = boxWidth a -        --- | Convert pure lines to VBoxes-toVBoxes :: Maybe AnyParagraphStyle-         -> PDFFloat -- ^ Max width-         -> [HBox] -- ^ List of lines-         -> [VBox] -- ^ List of VBoxes-toVBoxes Nothing _ l = map createVBox l- where-    createVBox a =  SomeVBox 0.0 (boxWidth a,boxHeight a,boxDescent a) (AnyBox a) Nothing -toVBoxes s@(Just style) w l = map createVBoxAndAddKern $ zip [1..] (l )- where-      createVBoxAndAddKern (nb,a) = -          let delta = (linePosition style) w nb-          in-          SomeVBox delta (boxWidth a,boxHeight a,boxDescent a) (AnyBox a) s --- | Create VBoxes. Paragraphs are analyzed and cut into VBoxes. The pragraph style is updated and used--- to transform the list of letters-verticalPostProcess :: VerState-             -> Int -- ^ Line offset for the text area-             -> Rectangle -- ^ Text area-             -> [VBox] -- ^ List of VBox with paragraphs-             -> [VBox] -- ^ List of VBox where paragraphs have been line broken-verticalPostProcess _ _ _ [] = []-verticalPostProcess pageSettings o rect@(Rectangle xa _ xb _) ((Paragraph l style paraSettings):l') = -    let (fl,newStyle) = case style of-              Nothing -> (formatList paraSettings (const $ xb-xa) l,Nothing) -              Just aStyle -> let (style',nl) = paraChange aStyle l -               in-               (formatList paraSettings (\nb -> (lineWidth style') (xb-xa) nb ) nl,Just style')-    in-    (addInterlineGlue pageSettings . toVBoxes newStyle (xb - xa) . horizontalPostProcess $ fl) ++ verticalPostProcess pageSettings (o + length fl) rect l'-verticalPostProcess pageSettings o rect (a:l') = a:verticalPostProcess pageSettings (o+1) rect l'  -notGlue :: VBox -> Bool-notGlue (VGlue _ _ _ _ _) = False-notGlue (Paragraph _ _ _) = False-notGlue _ = True --- | Get the required style for the interline glue-getInterlineStyle :: VBox -> VBox -> Maybe AnyParagraphStyle-getInterlineStyle (VBox _ _ _ _ (Just s)) (SomeVBox _ _ _ (Just s')) | paraStyleCode s == paraStyleCode s' = Just s-                                                                     | otherwise = Nothing--getInterlineStyle (VBox _ _ _ _ (Just s)) (VBox _ _ _ _ (Just s')) | paraStyleCode s == paraStyleCode s' = Just s-                                                                   | otherwise = Nothing--getInterlineStyle (SomeVBox _ _ _ (Just s)) (SomeVBox _ _ _ (Just s')) | paraStyleCode s == paraStyleCode s' = Just s-                                                                       | otherwise = Nothing--getInterlineStyle (SomeVBox _ _ _ (Just s)) (VBox _ _ _ _ (Just s')) | paraStyleCode s == paraStyleCode s' = Just s-                                                                     | otherwise = Nothing+    +dilateVboxes :: PDFFloat -> VBox ps s -> VBox ps s+dilateVboxes r g@(VGlue _ w l (Just(_,_)) s) = +    let h' = glueSizeWithRatio g r+    in+      VGlue h' w l Nothing s+dilateVboxes _ g@(VGlue _ _ _ Nothing _) = g+dilateVboxes _ a = a               -getInterlineStyle _ _ = Nothing+drawContainer :: ParagraphStyle ps s => Container ps s -- ^ Container+              -> Draw ()+drawContainer (Container px py _ maxh h y z oldl) = +    let l' = reverse oldl+        r = min (dilatationRatio maxh h y z) 2.0+        l'' = map (dilateVboxes r) l'+    in+      strokeVBoxes l'' px py+      +-- | Create a new paragraph from the remaining letters+createPara :: Int+           -> Maybe ps+           -> BRState+           -> [Letter s] +           -> [VBox ps s]+createPara _ _ _ [] = []+createPara lineOffset style paraSettings l = [Paragraph lineOffset l style paraSettings] --- | Get the delta used to position a box with non rectangular shapes-getBoxDelta :: VBox -> PDFFloat-getBoxDelta (Paragraph _ _ _) = 0.0-getBoxDelta (VBox _ _ _ _ _) = 0.0-getBoxDelta (VGlue _ _ delta _ _) = delta-getBoxDelta (SomeVBox delta _ _ _) = delta-           -addInterlineGlue :: VerState -> [VBox] -> [VBox]-addInterlineGlue _ [] = []-addInterlineGlue _ [a] = [a]-addInterlineGlue settings (a:b:l) | notGlue a && notGlue b = -    let p = boxDescent a-        h = boxHeight b - boxDescent b-        (ba,by,bz) = baselineskip settings-        (lw,ly,lz) = lineskip settings-        li = lineskiplimit settings-        istyle = getInterlineStyle a b-        theWidth = boxWidth a-        theDelta = getBoxDelta a+-- | Add paragraph lines to a container+addParaLine :: (ParagraphStyle ps s, ComparableStyle ps) => VerState ps+            -> Maybe ps+            -> BRState +            -> Container ps s -- ^ Container+            -> [((HBox s,[Letter s]),Int)]+            -> Either (Draw (),Container ps s,[VBox ps s]) (Container ps s)+addParaLine _ _ _ c  [] = Right c+addParaLine verstate style paraSettings c (((line,remainingPar),lineNb):l) = +    let c' = addTo verstate (toVBoxes style (containerWidth c) line lineNb) c      in-    if p <= -1000 +    if isOverfull c'         then-            a:addInterlineGlue settings (b:l)+         Left (drawContainer c,c,createPara lineNb style paraSettings remainingPar)         else-            if ba - p - h >= li-                then-                    a:(vglue istyle (ba-p-h) by bz theWidth theDelta):addInterlineGlue settings (b:l)-                else-                    a:(vglue istyle lw ly lz theWidth theDelta):addInterlineGlue settings (b:l)-                                  | otherwise = a:addInterlineGlue settings (b:l)+         addParaLine verstate style paraSettings c' l -instance Box VBox where-     boxWidth (Paragraph _ _ _) = 0-     boxWidth (VBox w _ _ _ _) = w-     boxWidth (SomeVBox _ d _ _)  = boxWidth d-     boxWidth (VGlue _ w _ _ _)  = w-                  -     boxHeight (Paragraph _ _ _) = 0-     boxHeight (VBox _ h _ _ _) = h-     boxHeight (SomeVBox _ d _ _) = boxHeight d-     boxHeight (VGlue h _ _ _ _) = h+-- | Fill a container with lines+fillContainer :: (ParagraphStyle ps s, ComparableStyle ps) => VerState ps -- ^ Vertical style for interline glues+              -> Container ps s -- ^ Container+              -> [VBox ps s] -- ^ VBox to add+              -> (Draw(),Container ps s,[VBox ps s]) -- ^ Component to draw, new container and remaining VBoxes due to overfull container+fillContainer _ c [] = (drawContainer c,c,[])+fillContainer verstate c (Paragraph lineOffset l style paraSettings:l') = +    let (fl,newStyle) = case style of+                Nothing -> (formatList paraSettings (const $ containerWidth c) l,Nothing) +                Just aStyle -> let (style',nl) = paragraphChange aStyle l +                               in+                               (formatList paraSettings (\nb -> (lineWidth style') (containerWidth c) (nb+lineOffset) ) nl,Just style')+        newLines = horizontalPostProcess fl+        r = addParaLine verstate newStyle paraSettings c (zip newLines [1..])+    in+      case r of+          Left (d,c',remPara) -> (d,c',remPara ++ l')+          Right c' -> fillContainer verstate c' l'     -     boxDescent (Paragraph _ _ _) = 0-     boxDescent (VBox _ _ d _ _) = d-     boxDescent (SomeVBox _ d _ _) = boxDescent d-     boxDescent (VGlue _ _ _ _ _) = 0--instance DisplayableBox VBox where-          strokeBox (Paragraph _ _ _) _ _ = return ()-          strokeBox b@(VBox _ _ _ l _) x y'' = strokeVBoxes l (x,y',y'')-            where-                y' = y'' - boxHeight b-          strokeBox (VGlue h w delta _ (Just style)) x y = -              if (isJust . interline $ style)-                  then-                      (fromJust . interline $ style) $ Rectangle (x+delta) (y-h) (x+w+delta) y-                  else-                     return()-          strokeBox (VGlue _ _ _ _ _) _ _ = return ()-          -          strokeBox (SomeVBox delta _ a _) x y = strokeBox a (x+delta) y- -isSameParaStyle :: AnyParagraphStyle -> VBox -> Bool-isSameParaStyle s (Paragraph _ (Just s') _) = paraStyleCode s == paraStyleCode s'-isSameParaStyle s (VBox _ _ _ _ (Just s')) = paraStyleCode s == paraStyleCode s'-isSameParaStyle s (VGlue _ _ _ _ (Just s')) = paraStyleCode s == paraStyleCode s'-isSameParaStyle s (SomeVBox _ _ _ (Just s'))  = paraStyleCode s == paraStyleCode s'     -isSameParaStyle _ _ = False-     -recurseStrokeVBoxes :: Int -> [VBox] -> (PDFFloat,PDFFloat,PDFFloat) -> Draw ()-recurseStrokeVBoxes _ [] _  = return ()-recurseStrokeVBoxes _ (Paragraph _ _ _:_) _  = return ()-recurseStrokeVBoxes nb (a@(VGlue _ _ _ _ _):l) (xa,y',y)  = do-    let h = boxHeight a-    strokeBox a xa y-    if y - h >= y'+fillContainer verstate c oldl@(a:l) = +    let c' = addTo verstate a c+    in+    if isOverfull c'        then-        recurseStrokeVBoxes nb l (xa,y',(y-h))-      else-        return ()-    -recurseStrokeVBoxes nb (a:l) (xa,y',y) = do-    let h = boxHeight a-    strokeBox a xa y-    if y - h >= y'-     then-       recurseStrokeVBoxes (nb+1) l (xa,y',(y-h))-     else-       return ()           -               -drawWithParaStyle :: AnyParagraphStyle -> [VBox] -> (PDFFloat,PDFFloat,PDFFloat) -> Draw ()   -drawWithParaStyle style b (xa,y',y'') = do-    let  (l',l'') = span (isSameParaStyle style) b-         h' = foldl' (\x' ny -> x' + boxHeight ny) 0.0 l'-    if (isJust . paragraphStyle $ style)-      then do-          let xleft = (minimum $ 100000:map getBoxDelta l' ) + xa-              xright = (maximum $ 0:(map (\x -> boxWidth x + getBoxDelta x) l')) + xa-          (fromJust . paragraphStyle $ style) (Rectangle xleft (y''- h') xright (y'')) (recurseStrokeVBoxes 1 l' (xa,y',y''))+          (drawContainer c,c,oldl)       else-         recurseStrokeVBoxes 1 l' (xa,y',y'')-    strokeVBoxes l'' (xa,y',y''-h')-               --- | Stroke the VBoxes-strokeVBoxes :: [VBox] -- ^ List of boxes-             -> (PDFFloat,PDFFloat,PDFFloat)-             -> Draw ()-strokeVBoxes [] (_,_,_) = return ()-strokeVBoxes b@((Paragraph _ (Just s') _):_) (xa,y',y'') = drawWithParaStyle s' b (xa,y',y'')-strokeVBoxes b@((VBox _ _ _ _ (Just s')):_) (xa,y',y'') = drawWithParaStyle s' b (xa,y',y'')-strokeVBoxes b@((VGlue _ _ _ _ (Just s')):_) (xa,y',y'') = drawWithParaStyle s' b (xa,y',y'')-strokeVBoxes b@((SomeVBox _ _ _ (Just s')):_) (xa,y',y'') = drawWithParaStyle s' b (xa,y',y'')-strokeVBoxes (a:l) (xa,y',y'') = -    do-        let h = boxHeight a-        strokeBox a xa y''-        if y'' - h >= y'-          then-             strokeVBoxes l (xa,y',(y''-h))-          else-             return ()---- | Paragraph style-class ParagraphStyle a where-    -- | Width of the line of the paragraph-    lineWidth :: a -- ^ The style-               -> PDFFloat -- ^ Width of the text area used by the typesetting algorithm-               -> Int -- ^ Line number-               -> PDFFloat -- ^ Line width-    -    -- | Horizontal shift of the line position relatively to the left egde of the paragraph bounding box-    linePosition :: a -- ^ The style -                  -> PDFFloat -- ^ Width of the text area used by the typesetting algorithm-                  -> Int -- ^ Line number -                  -> PDFFloat -- ^ Horizontal offset from the left edge of the text area-    -    -- | All paragraph styles used in a document must have different codes-    paraStyleCode :: a -- ^ The style -                  -> Int -- ^ Code identifying the style-    -    -- | How to style the interline glues added in a paragraph by the line breaking algorithm-    interline :: a -- ^ The style -              -> Maybe (Rectangle -> Draw ()) -- ^ Function used to style interline glues-    interline _ = Nothing-    lineWidth _ w _ = w-    linePosition _ _ = const 0.0-    -    -- | Change the content of a paragraph before the line breaking algorithm is run. It may also change the style-    paraChange :: a -- ^ The style-               -> [Letter] -- ^ List of letters in the paragraph-               -> (a,[Letter]) -- ^ Update style and list of letters-    paraChange a l = (a,l)-    -    -- | Get the paragraph bounding box and the paragraph draw command to apply additional effects-    paragraphStyle :: a -- ^ The style -                   -> Maybe (Rectangle -> Draw b -> Draw ()) -- ^ Function used to style a paragraph-    paragraphStyle _ = Nothing-    --- | Any paragraph style-data AnyParagraphStyle = forall a . ParagraphStyle a => AnyParagraphStyle a+          fillContainer verstate c' l+          +-- | Convert pure lines to VBoxes+toVBoxes :: (ParagraphStyle ps s) => Maybe ps+       -> PDFFloat -- ^ Max width+       -> HBox s -- ^ List of lines+       -> Int -- ^ Line number+       -> VBox ps s -- ^ List of VBoxes+toVBoxes Nothing _ a _ = SomeVBox 0.0 (boxWidth a,boxHeight a,boxDescent a) (AnyBox a) Nothing+toVBoxes s@(Just style) w a nb = +        let delta = (linePosition style) w nb in+        SomeVBox delta (boxWidth a,boxHeight a,boxDescent a) (AnyBox a) s -instance ParagraphStyle AnyParagraphStyle where-    lineWidth (AnyParagraphStyle a) = lineWidth a-    linePosition (AnyParagraphStyle a) = linePosition a-    paraStyleCode (AnyParagraphStyle a) = paraStyleCode a-    interline (AnyParagraphStyle a) = interline a-    paraChange (AnyParagraphStyle a) l = let (a',l') = paraChange a l in (AnyParagraphStyle a',l')-    paragraphStyle (AnyParagraphStyle a) = paragraphStyle a
HPDF.cabal view
@@ -1,5 +1,5 @@ Name: HPDF-Version: 1.1+Version: 1.2 License: LGPL License-file:LICENSE Copyright: Copyright (c) 2007, alpheccar@@ -7,8 +7,8 @@ synopsis: Generation of PDF documents maintainer: misc@NOSPAMalpheccar.org tested-with: GHC==6.6-homepage: http://www.alpheccar.org/en/posts/show/82-build-depends: base, haskell98,mtl,encoding >= 0.1 ,zlib >= 0.3, binary >= 0.3+homepage: http://www.alpheccar.org/en/posts/show/84+build-depends: base, haskell98,mtl,encoding >= 0.2 ,zlib >= 0.3, binary >= 0.3 ghc-options: -Wall -funbox-strict-fields  -fglasgow-exts  -O2 extensions: ForeignFunctionInterface, CPP description: A PDF library with support for several pages, page transitions, outlines, annotations, compression, colors, shapes, patterns, jpegs, fonts, typesetting ...@@ -54,4 +54,6 @@    Graphics.PDF.Typesetting.Horizontal    Graphics.PDF.Typesetting.Vertical    Graphics.PDF.Typesetting.Box+   Graphics.PDF.Typesetting.Layout    Graphics.PDF.LowLevel.Serializer+   Graphics.PDF.Typesetting.StandardStyle
Test/test.hs view
@@ -75,13 +75,46 @@            strokeColor (Rgb 0 0 1)            stroke (Ellipse 0 0 100 50)             -testAnnotation :: Draw ()-testAnnotation = do-    strokeColor red-    newAnnotation (URLLink (toPDFString "Go to my blog") [0,0,100,100] "http://www.alpheccar.org" True)-    drawText $ text (PDFFont Times_Roman 12) 10 30 (toPDFString "Go to my blog")-    stroke $ Rectangle 0 0 100 100-    newAnnotation (TextAnnotation (toPDFString "Key annotation") [100,100,130,130] Key)+testAnnotation ::PDFReference PDFPage -> PDF ()+testAnnotation p = do+    drawWithPage p $ do+      r+   +    p1 <- addPage Nothing+    drawWithPage p1 $ do+      withNewContext $ do+        applyMatrix $ translate 50 0+        r+    p2 <- addPage Nothing+    drawWithPage p2 $ do+      strokeColor red+      stroke $ Line 0 0 100 0+      applyMatrix $ translate 100 0+      strokeColor green+      stroke $ Line 0 0 100 0+      withNewContext $ do+          applyMatrix $ rotate (Degree (-20))+          strokeColor $ Rgb 1 1 0+          stroke $ Line 0 0 100 0+          applyMatrix $ translate 50 50+          strokeColor blue+          stroke $ Line 0 0 100 0+          withNewContext $ do+            applyMatrix $ rotate (Degree 45)+            r+            strokeColor black+            stroke $ Line 0 0 100 0+    p3 <- addPage Nothing+    drawWithPage p3 $ do+     withNewContext $ do+        applyMatrix $ scale 3 1+        r+ where r = do+        strokeColor red+        newAnnotation (URLLink (toPDFString "Go to my blog") [0,0,200,100] "http://www.alpheccar.org" True)+        drawText $ text (PDFFont Times_Roman 12) 10 30 (toPDFString "Go to my blog")+        stroke $ Rectangle 0 0 200 100+        newAnnotation (TextAnnotation (toPDFString "Key annotation") [100,100,130,130] Key)   textTest :: Draw () textTest = do@@ -103,72 +136,59 @@            applyMatrix $ scale 2 2            drawXObject jpg            -data Normal = Normal deriving(Eq)-data Bold = Bold deriving(Eq)-data Crazy = Crazy deriving(Eq)-data SuperCrazy = SuperCrazy !([Int],[PDFFloat]) deriving(Eq)-data DebugStyle = DebugStyle deriving(Eq)-data RedRectStyle = RedRectStyle deriving(Eq)-data BlueStyle = BlueStyle deriving(Eq) -instance Style Normal where-    textStyle _ = TextStyle (PDFFont Times_Roman 10) black black FillText 1.0 1.0 1.0 1.0-    styleCode _ = 1+data MyParaStyles = Normal+                  | Bold+                  | Crazy+                  | SuperCrazy [Int] [PDFFloat]+                  | DebugStyle+                  | RedRectStyle+                  | BlueStyle+                  +instance ComparableStyle MyParaStyles where+  isSameStyleAs Normal Normal = True+  isSameStyleAs Bold Bold = True+  isSameStyleAs Crazy Crazy = True+  isSameStyleAs (SuperCrazy _ _) (SuperCrazy _ _) = True+  isSameStyleAs DebugStyle DebugStyle = True+  isSameStyleAs RedRectStyle RedRectStyle = True+  isSameStyleAs BlueStyle BlueStyle = True+  isSameStyleAs _ _ = False+  +                  +instance Style MyParaStyles where+    textStyle Normal = TextStyle (PDFFont Times_Roman 10) black black FillText 1.0 1.0 1.0 1.0+    textStyle Bold = TextStyle (PDFFont Times_Bold 12) black black FillText 1.0 1.0 1.0 1.0+    textStyle RedRectStyle = TextStyle (PDFFont Times_Roman 10) black black FillText 1.0 1.0 1.0 1.0+    textStyle DebugStyle = TextStyle (PDFFont Times_Roman 10) black black FillText 1.0 1.0 1.0 1.0+    textStyle Crazy = TextStyle (PDFFont Times_Roman 10) red red FillText 1.0 1.0 1.0 1.0+    textStyle (SuperCrazy _ _) = TextStyle (PDFFont Times_Roman 12) black black FillText 1.0 2.0 0.5 0.5+    textStyle BlueStyle = TextStyle (PDFFont Times_Roman 10) black black FillText 1.0 1.0 1.0 1.0     -instance Style Bold where-    textStyle _ = TextStyle (PDFFont Times_Bold 12) black black FillText 1.0 1.0 1.0 1.0-    styleCode _ = 2 +    sentenceStyle BlueStyle = Just $ \r d -> do+        fillColor $ Rgb 0.6 0.6 1+        strokeColor $ Rgb 0.6 0.6 1+        fillAndStroke r+        d+        return()     -instance Style RedRectStyle where-    sentenceStyle _ = Just $ \r d -> do+    sentenceStyle RedRectStyle = Just $ \r d -> do         strokeColor red         stroke r         d         return()-    textStyle _ = TextStyle (PDFFont Times_Roman 10) black black FillText 1.0 1.0 1.0 1.0-    styleCode _ = 5-        -instance Style DebugStyle where-    wordStyle _ = Just $ \r m d ->+    sentenceStyle Crazy = Just $ \r d -> do+       d+       strokeColor blue+       stroke r+    sentenceStyle _ = Nothing+           +    wordStyle DebugStyle = Just $ \r m d ->       case m of           DrawWord -> d >> return ()           DrawGlue -> d >> stroke r-    textStyle _ = TextStyle (PDFFont Times_Roman 10) black black FillText 1.0 1.0 1.0 1.0-    styleCode _ = 5 -            -crazyWord :: Rectangle -> StyleFunction -> Draw a -> Draw ()-crazyWord r@(Rectangle xa ya xb yb) DrawWord d = do-    fillColor $ Rgb 0.6 1 0.6 -    fill r-    d-    strokeColor $ Rgb 0 0 1-    let m = (ya+yb)/2.0-    stroke $ Line xa m xb m -crazyWord (Rectangle xa ya xb yb) DrawGlue _ = do-    fillColor $ Rgb 0 0 1-    fill (Circle ((xa+xb)/2.0) ((ya+yb)/2.0) ((xb-xa)/2.0))-    -instance Style Crazy where-    sentenceStyle _ = Just $ \r d -> do-        d-        strokeColor blue-        stroke r-    wordStyle _ = Just crazyWord-    textStyle _ = TextStyle (PDFFont Times_Roman 10) red red FillText 1.0 1.0 1.0 1.0-    styleCode _ = 3   -    -    -superCrazy :: SuperCrazy-superCrazy = SuperCrazy (randomRs (0,32) (mkStdGen 0),randomRs (-10.0,10.0) (mkStdGen 10000))--instance Style SuperCrazy where-    styleCode _ = 4-    updateStyle (SuperCrazy (a,b)) = SuperCrazy $ (drop 8 a,tail b)-    textStyle _ = TextStyle (PDFFont Times_Roman 12) black black FillText 1.0 2.0 0.5 0.5-    styleHeight r = (getHeight . textFont . textStyle $ r) + 4.0-    styleDescent r = (getDescent . textFont . textStyle $ r) + 2-    -    wordStyle (SuperCrazy (l,_)) = Just ws +    wordStyle Crazy = Just crazyWord+    wordStyle (SuperCrazy l _) = Just ws       where         ws _ DrawGlue _ = return ()         ws (Rectangle xa ya xb yb) DrawWord drawWord = do@@ -189,22 +209,69 @@               drawWord             return () -instance ParagraphStyle Normal where-    paraStyleCode _ = 1+    wordStyle _ = Nothing     -data CirclePara = CirclePara deriving(Eq)-data BluePara = BluePara PDFFloat deriving(Eq)+    updateStyle (SuperCrazy a b) = SuperCrazy (drop 8 a) (tail b)+    updateStyle a = a+    +    styleHeight r@(SuperCrazy _ _) = (getHeight . textFont . textStyle $ r) + 4.0+    styleHeight r = getHeight . textFont . textStyle $ r+    +    styleDescent r@(SuperCrazy _ _) = (getDescent . textFont . textStyle $ r) + 2+    styleDescent r = getDescent . textFont . textStyle $ r+     -instance ParagraphStyle BluePara where-    paraStyleCode _ = 3+             +crazyWord :: Rectangle -> StyleFunction -> Draw a -> Draw ()+crazyWord r@(Rectangle xa ya xb yb) DrawWord d = do+    fillColor $ Rgb 0.6 1 0.6 +    fill r+    d+    strokeColor $ Rgb 0 0 1+    let m = (ya+yb)/2.0+    stroke $ Line xa m xb m +crazyWord (Rectangle xa ya xb yb) DrawGlue _ = do+    fillColor $ Rgb 0 0 1+    fill (Circle ((xa+xb)/2.0) ((ya+yb)/2.0) ((xb-xa)/2.0))+    +   +    +superCrazy :: MyParaStyles+superCrazy = SuperCrazy (randomRs (0,32) (mkStdGen 0)) (randomRs (-10.0,10.0) (mkStdGen 10000))+    +data MyVertStyles = NormalPara+                  | CirclePara+                  | BluePara !PDFFloat++instance ComparableStyle MyVertStyles where+    isSameStyleAs NormalPara NormalPara = True+    isSameStyleAs CirclePara CirclePara = True+    isSameStyleAs (BluePara _) (BluePara _) = True+    isSameStyleAs _ _ = False+    +    +instance ParagraphStyle MyVertStyles MyParaStyles  where     lineWidth (BluePara a) w nb = (if nb > 3 then w else w-a) - 20.0+    lineWidth CirclePara _ nb = +           let nbLines = 15.0+               r = nbLines * (getHeight . textFont . textStyle $ Normal)+               pasin x' = if x' >= 1.0 then pi/2 else if x' <= -1.0 then (-pi/2) else asin x'+               angle l = pasin $ (nbLines - (fromIntegral l)  ) / nbLines+           in+           abs(2*r*cos (angle nb))+    lineWidth _ w _ = w+                linePosition (BluePara a) _ nb = (if nb > 3 then 0.0 else a) + 10.0-    interline _ = Just $ \r -> do+    linePosition a@(CirclePara) w nb = max 0 ((w - lineWidth a w nb) / 2.0)+    linePosition _ _ _ = 0.0+    +    interline (BluePara _) = Just $ \r -> do         fillColor $ Rgb 0.6 0.6 1         strokeColor $ Rgb 0.6 0.6 1         fillAndStroke r-    paraChange s [] = (s,[])-    paraChange _ (AChar st c _:l) = +    interline _ = Nothing+        +    paragraphChange (BluePara _) (AChar st c _:l) =          let f = PDFFont Helvetica_Bold 45             w' = charWidth f c              charRect = Rectangle 0 (- getDescent f) w' (getHeight f - getDescent f)@@ -223,8 +290,10 @@                     paintWithShading (AxialShading 0 (- getDescent f) w' (getHeight f - getDescent f) (Rgb 1 0 0) (Rgb 0 0 1)) (addShape charRect)         in         (BluePara w', c':l)-    paraChange s l = (s,l)-    paragraphStyle _ = Just $ \(Rectangle xa ya xb yb) b -> do+    +    paragraphChange s l = (s,l)+    +    paragraphStyle (BluePara _) = Just $ \(Rectangle xa ya xb yb) b -> do         let f = Rectangle (xa-3) (ya-3) (xb+3) (yb+3)         fillColor $ Rgb 0.6 0.6 1         fill f@@ -232,46 +301,70 @@         strokeColor red         stroke f         return ()-        -instance ParagraphStyle CirclePara where-    lineWidth _ _ nb = -        let nbLines = 15.0-            r = nbLines * (getHeight . textFont . textStyle $ Normal)-            pasin x' = if x' >= 1.0 then pi/2 else if x' <= -1.0 then (-pi/2) else asin x'-            angle l = pasin $ (nbLines - (fromIntegral l)  ) / nbLines-        in-        abs(2*r*cos (angle nb))-    linePosition a w nb = max 0 ((w - lineWidth a w nb) / 2.0)-    paraStyleCode _ = 2--instance Style BlueStyle where-    sentenceStyle _ = Just $ \r d -> do-        fillColor $ Rgb 0.6 0.6 1-        strokeColor $ Rgb 0.6 0.6 1-        fillAndStroke r-        d-        return()-    textStyle _ = TextStyle (PDFFont Times_Roman 10) black black FillText 1.0 1.0 1.0 1.0-    styleCode _ = 7+    paragraphStyle _ = Nothing     +containerTest :: PDFReference PDFPage -> PDF ()+containerTest p = +    let c = mkContainer 10 300 200 90+        (d,c',r) = fillContainer (defaultVerState NormalParagraph) c . getBoxes NormalParagraph (Font (PDFFont Times_Roman 10) black black) $ testText+        cb = mkContainer 10 210 200 210+        (d',c'',_) = fillContainer (defaultVerState NormalParagraph) cb r+    in drawWithPage p $ do+      d+      d'+      let x = containerX c'+          y = containerY c'+          w = containerWidth c'+          h = containerHeight c'+      strokeColor red+      stroke $ Rectangle x y (x+w) (y-h)+      strokeColor blue+      stroke $ containerContentRectangle c'+      stroke $ containerContentRectangle c''+      +    +standardStyleTest :: TM StandardParagraphStyle StandardStyle ()+standardStyleTest = do+    paragraph $ do+        txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut "+        txt $ "labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris "+        setStyle $ Font (PDFFont Times_Bold 10) black black+        txt $ "nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate "+        txt $ "velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non "+        txt $ "proident, sunt in culpa qui officia deserunt mollit anim id est laborum."+ +testText :: TM StandardParagraphStyle StandardStyle ()      +testText = do+        paragraph $ do+            txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor "+            txt $ "incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud "+            txt $ "exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute "+            txt $ "irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla "+            txt $ "pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia "+            txt $ "deserunt mollit anim id est laborum."+            +testBreakText :: TM StandardParagraphStyle StandardStyle ()      +testBreakText = do+        paragraph $ do+            txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor "+            txt $ "incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud "+            txt $ "exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute "+            txt $ "irure dolor"+            forceNewLine+            txt $ " in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla "+            txt $ "pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia "+            txt $ "deserunt mollit anim id est laborum."+                     typesetTest :: Int -> PDFReference PDFPage -> PDF () typesetTest test page = do-    let --symbol = mkDrawBox $ do-        --  applyMatrix $ translate 0 (-4)-        --  strokeColor red-        --  fillColor red-        --  fillAndStroke $ Polygon [ (0,0)-        --                          , (5,5)-        --                          , (10,0)-        --                          , (0,0)-        --                          ]-        --  strokeColor blue-        --  fillColor blue-        --  fillAndStroke $ Polygon [ (0,0)-        --                          , (5,-5)-        --                          , (10,0)-        --                          , (0,0)-        --                          ]+    let simpleText = do+            paragraph $ do+                txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor "+                txt $ "incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud "+                txt $ "exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute "+                txt $ "irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla "+                txt $ "pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia "+                txt $ "deserunt mollit anim id est laborum."         debugText = do             paragraph $ do                 txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor "@@ -296,11 +389,13 @@                 setStyle Crazy                 par                 setStyle Normal+        par :: Para MyParaStyles ()         par = do               txt $ "Lor/-em ip/-sum do/-lor sit am/-et, con/-se/-cte/-tur adi/-pi/-si/-cing el/-it, sed do eius/-mod tem/-por inci/-di/-dunt ut lab/-ore et do/-lo/-re ma/-gna ali/-qua. "               txt $ "Ut en/-im ad mi/-nim ven/-iam, quis no/-strud ex/-er/-ci/-ta/-tion ul/-lam/-co labo/-ris ni/-si ut ali/-quip ex ea com/-mo/-do con/-se/-quat. Duis au/-te ir/-ure "               txt $ "do/-lor in re/-pre/-hen/-der/-it in vo/-lup/-ta/-te ve/-lit es/-se cil/-lum do/-lo/-re eu fu/-giat nul/-la pa/-ria/-tur. Ex/-cep/-teur sint oc/-cae/-cat cu/-pi/-da/-tat non "               txt $ "pro/-id/-ent, sunt in cul/-pa qui of/-fi/-cia de/-se/-runt mol/-lit anim id est la/-bo/-rum."+        normalPar :: Para MyParaStyles ()         normalPar = do               txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. "               txt $ "Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor "@@ -309,27 +404,27 @@         myText = do               -- Duplicate paragraph several times               paragraph normalPar-              glue 3 0 0+              glue 6 0.33 0               setStyle BlueStyle               setParaStyle (BluePara 0)-              setFirstPassTolerance 5000-              setSecondPassTolerance 10000-              unstyledGlue 3 0 0+              setFirstPassTolerance 500+              --setSecondPassTolerance 10000+              unstyledGlue 6 0.33 0               paragraph $ do                     txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. "-                    txt $ "Ut enim ad minim veniam, quis nostrud exercitation ullamco "+                    txt $ "Ut enim ad minim veniam, quis nostrud exercitation ullamco"                     --addBox symbol 10 10 5                     txt $ " laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor "                     txt $ "in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, "                     txt $ "sunt in culpa qui officia deserunt mollit anim id est laborum."-              unstyledGlue 3 0 0+              unstyledGlue 6 0.33 0               setFirstPassTolerance 100               setSecondPassTolerance 200               setStyle Normal-              setParaStyle Normal-              glue 3 0 0+              setParaStyle NormalPara+              glue 6 0.33 0               paragraph normalPar-              glue 3 0 0+              glue 6 0.33 0               paragraph normalPar         --textStart = 300 - getHeight f + getDescent f         maxw = 400@@ -340,30 +435,86 @@       --stroke $ Line 10 textStart (10+maxw) textStart       strokeColor black       case test of+          0 -> do+                strokeColor red+                stroke $ Line 10 300 (10+maxw) 300+                displayFormattedText (Rectangle 10 0 (10+maxw) 300) NormalPara Normal simpleText           1 -> do               strokeColor red-              stroke $ Line 10 300 (10+maxw) 300-              displayFormattedText (Rectangle 10 0 (10+maxw) 300) Normal Normal myText+              stroke $ Line 10 400 (10+maxw) 400+              displayFormattedText (Rectangle 10 0 (10+maxw) 400) NormalPara Normal myText           2 -> do               strokeColor red               stroke $ Line 10 300 (10+maxw) 300-              displayFormattedText (Rectangle 10 0 (10+maxw) 300) Normal Normal debugText+              displayFormattedText (Rectangle 10 0 (10+maxw) 300) NormalPara Normal debugText           3 -> do               let r = (Rectangle 10 200 (10+maxw) 300)               displayFormattedText r CirclePara Normal $ do                    setStyle Normal                    setFirstPassTolerance 5000                    setSecondPassTolerance 5000-                   setLineSkip 0 0 0-                   setBaseLineSkip 0 0 0-                   setLineSkipLimit 0+                   --setLineSkip 0 0 0+                   --setBaseLineSkip 0 0 0+                   --setLineSkipLimit 0                    paragraph $ do                        mapM_ (const normalPar) ([1..3]::[Int])                        txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. "                        txt $ "Ut enim ad minim"               strokeColor red               stroke r-          _ -> displayFormattedText ((Rectangle 0 300 (10+maxw) 300)) Normal Normal myText+          4 -> displayFormattedText ((Rectangle 10 0 (10+maxw) 300)) NormalParagraph (Font (PDFFont Times_Roman 10) black black) standardStyleTest+          5 -> do+              strokeColor red+              stroke $ Rectangle 10 300 (10+maxw) 400+              displayFormattedText ((Rectangle 10 300 (10+maxw) 400)) NormalParagraph (Font (PDFFont Times_Roman 10) black black) $ do+                  setJustification Centered+                  testText+                  +              strokeColor red+              stroke $ Rectangle 10 200 (10+maxw) 300+              displayFormattedText ((Rectangle 10 200 (10+maxw) 300)) NormalParagraph (Font (PDFFont Times_Roman 10) black black) $ do+                  setJustification LeftJustification+                  testText+              +              strokeColor red+              stroke $ Rectangle 10 100 (10+maxw) 200+              displayFormattedText ((Rectangle 10 100 (10+maxw) 200)) NormalParagraph (Font (PDFFont Times_Roman 10) black black) $ do+                  setJustification RightJustification+                  testText+              strokeColor red+              stroke $ Rectangle 10 0 (10+maxw) 100+              drawText $ text (PDFFont Helvetica_Bold 24) 10 100 (toPDFString "Lorem ipsum")+              stroke $ Line 10 120 (10 + textWidth (PDFFont Helvetica_Bold 24) (toPDFString "Lorem ipsum") ) 120 +              displayFormattedText ((Rectangle 10 0 (10+maxw) 100)) NormalParagraph (Font (PDFFont Times_Roman 10) black black) $ do+                  setJustification LeftJustification+                  paragraph $ do+                      setStyle (Font (PDFFont Helvetica_Bold 24) black black)+                      txt $ "Lorem ipsum"+          6 -> do+                strokeColor red+                stroke $ Rectangle 10 300 (10+maxw) 400+                displayFormattedText ((Rectangle 10 300 (10+maxw) 400)) NormalParagraph (Font (PDFFont Times_Roman 10) black black) $ do+                    setJustification Centered+                    testBreakText++                strokeColor red+                stroke $ Rectangle 10 200 (10+maxw) 300+                displayFormattedText ((Rectangle 10 200 (10+maxw) 300)) NormalParagraph (Font (PDFFont Times_Roman 10) black black) $ do+                    setJustification LeftJustification+                    testBreakText++                strokeColor red+                stroke $ Rectangle 10 100 (10+maxw) 200+                displayFormattedText ((Rectangle 10 100 (10+maxw) 200)) NormalParagraph (Font (PDFFont Times_Roman 10) black black) $ do+                    setJustification RightJustification+                    testBreakText+                    +                strokeColor red+                stroke $ Rectangle 10 0 (10+maxw) 100+                displayFormattedText ((Rectangle 10 0 (10+maxw) 100)) NormalParagraph (Font (PDFFont Times_Roman 10) black black) $ do+                    setJustification FullJustification+                    testBreakText+          _ -> displayFormattedText ((Rectangle 0 300 (10+maxw) 300)) NormalPara Normal myText                                                testAll :: JpegFile -> PDF ()@@ -376,10 +527,26 @@      page2 <- addPage Nothing      newSection (toPDFString "Debug text") Nothing Nothing $ do             typesetTest 2 page2-            +                page3 <- addPage Nothing      newSection (toPDFString "Circle text") Nothing Nothing $ do             typesetTest 3 page3+          +     page3a <- addPage Nothing+     newSection (toPDFString "Standard styles") Nothing Nothing $ do+            typesetTest 4 page3a+            +     page3b <- addPage Nothing+     newSection (toPDFString "Justifications") Nothing Nothing $ do+            typesetTest 5 page3b+            +     page3d <- addPage Nothing+     newSection (toPDFString "New lines") Nothing Nothing $ do+            typesetTest 6 page3d+            +     page3c <- addPage Nothing+     newSection (toPDFString "Container") Nothing Nothing $ do+            containerTest page3c              page4 <- addPage Nothing     newSection (toPDFString "Shapes") Nothing Nothing $ do@@ -416,8 +583,7 @@                 page10 <- addPage Nothing     newSection (toPDFString "Annotations") Nothing Nothing $ do-        drawWithPage page10 $ do-          testAnnotation +          testAnnotation page10                page11 <- addPage Nothing     newSection (toPDFString "Text encoding") Nothing Nothing $ do@@ -432,6 +598,6 @@ main = do     let rect = PDFRect 0 0 600 400     Right jpg <- readJpegFile "logo.jpg"  -    runPdf "demo.pdf" (standardDocInfo { author=toPDFString "alpheccar", compressed = True}) rect $ do+    runPdf "demo.pdf" (standardDocInfo { author=toPDFString "alpheccar", compressed = False}) rect $ do         testAll jpg