diff --git a/Graphics/PDF/Annotation.hs b/Graphics/PDF/Annotation.hs --- a/Graphics/PDF/Annotation.hs +++ b/Graphics/PDF/Annotation.hs @@ -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 () diff --git a/Graphics/PDF/Coordinates.hs b/Graphics/PDF/Coordinates.hs --- a/Graphics/PDF/Coordinates.hs +++ b/Graphics/PDF/Coordinates.hs @@ -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 ' ' diff --git a/Graphics/PDF/Draw.hs b/Graphics/PDF/Draw.hs --- a/Graphics/PDF/Draw.hs +++ b/Graphics/PDF/Draw.hs @@ -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 diff --git a/Graphics/PDF/Image.hs b/Graphics/PDF/Image.hs --- a/Graphics/PDF/Image.hs +++ b/Graphics/PDF/Image.hs @@ -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 diff --git a/Graphics/PDF/Shading.hs b/Graphics/PDF/Shading.hs --- a/Graphics/PDF/Shading.hs +++ b/Graphics/PDF/Shading.hs @@ -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 diff --git a/Graphics/PDF/Typesetting.hs b/Graphics/PDF/Typesetting.hs --- a/Graphics/PDF/Typesetting.hs +++ b/Graphics/PDF/Typesetting.hs @@ -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}} diff --git a/Graphics/PDF/Typesetting/Box.hs b/Graphics/PDF/Typesetting/Box.hs --- a/Graphics/PDF/Typesetting/Box.hs +++ b/Graphics/PDF/Typesetting/Box.hs @@ -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 diff --git a/Graphics/PDF/Typesetting/Breaking.hs b/Graphics/PDF/Typesetting/Breaking.hs --- a/Graphics/PDF/Typesetting/Breaking.hs +++ b/Graphics/PDF/Typesetting/Breaking.hs @@ -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) diff --git a/Graphics/PDF/Typesetting/Horizontal.hs b/Graphics/PDF/Typesetting/Horizontal.hs --- a/Graphics/PDF/Typesetting/Horizontal.hs +++ b/Graphics/PDF/Typesetting/Horizontal.hs @@ -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 diff --git a/Graphics/PDF/Typesetting/Layout.hs b/Graphics/PDF/Typesetting/Layout.hs new file mode 100644 --- /dev/null +++ b/Graphics/PDF/Typesetting/Layout.hs @@ -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) + diff --git a/Graphics/PDF/Typesetting/StandardStyle.hs b/Graphics/PDF/Typesetting/StandardStyle.hs new file mode 100644 --- /dev/null +++ b/Graphics/PDF/Typesetting/StandardStyle.hs @@ -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 diff --git a/Graphics/PDF/Typesetting/Vertical.hs b/Graphics/PDF/Typesetting/Vertical.hs --- a/Graphics/PDF/Typesetting/Vertical.hs +++ b/Graphics/PDF/Typesetting/Vertical.hs @@ -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 diff --git a/HPDF.cabal b/HPDF.cabal --- a/HPDF.cabal +++ b/HPDF.cabal @@ -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 diff --git a/Test/test.hs b/Test/test.hs --- a/Test/test.hs +++ b/Test/test.hs @@ -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