HPDF 1.0 → 1.1
raw patch · 27 files changed
+2652/−479 lines, 27 filesdep +binary
Dependencies added: binary
Files
- Graphics/PDF.hs +81/−59
- Graphics/PDF/Colors.hs +45/−8
- Graphics/PDF/Coordinates.hs +19/−2
- Graphics/PDF/Demo.hs +0/−151
- Graphics/PDF/Document.hs +9/−7
- Graphics/PDF/Draw.hs +36/−39
- Graphics/PDF/Image.hs +45/−31
- Graphics/PDF/LowLevel/Serializer.hs +76/−0
- Graphics/PDF/LowLevel/Types.hs +70/−58
- Graphics/PDF/Pages.hs +4/−2
- Graphics/PDF/Pattern.hs +43/−8
- Graphics/PDF/Resources.hs +1/−1
- Graphics/PDF/Shading.hs +7/−1
- Graphics/PDF/Shapes.hs +74/−21
- Graphics/PDF/Text.hs +99/−52
- Graphics/PDF/Typesetting.hs +326/−0
- Graphics/PDF/Typesetting/Box.hs +173/−0
- Graphics/PDF/Typesetting/Breaking.hs +526/−0
- Graphics/PDF/Typesetting/Horizontal.hs +345/−0
- Graphics/PDF/Typesetting/Vertical.hs +316/−0
- HPDF.cabal +14/−5
- Test/Makefile +8/−2
- Test/test.hs +309/−30
- c/conversion.c +17/−0
- c/conversion.h +5/−0
- c/ctext.h +1/−1
- c/metrics.c +3/−1
Graphics/PDF.hs view
@@ -44,8 +44,11 @@ , module Graphics.PDF.Pattern -- ** Shading , module Graphics.PDF.Shading+ -- ** Typesetting+ , module Graphics.PDF.Typesetting ) where +import Graphics.PDF.Typesetting import Graphics.PDF.Shading import Graphics.PDF.Pattern import Graphics.PDF.Navigation@@ -55,7 +58,6 @@ import qualified Data.ByteString.Lazy as B import Data.Int import System.IO-import Control.Exception(bracket) import Text.Printf(printf) import Control.Monad.State import Graphics.PDF.Annotation@@ -70,6 +72,9 @@ import Graphics.PDF.Action import Graphics.PDF.Image import Graphics.PDF.Resources(emptyResource)+import Data.Binary.Builder(Builder,fromLazyByteString, toLazyByteString)+import Graphics.PDF.LowLevel.Serializer+import Data.Monoid -- | Create a new PDF document and return a first page -- The page is using the document size by default@@ -82,17 +87,20 @@ return () -- Create the PDF stream objects from the draw monads-createStreams :: [(Int, (Maybe (PDFReference PDFPage),Draw ()))] -> PDF ()-createStreams l = mapM_ addStream l+createStreams :: PDF ()+createStreams = do+ ls <- gets streams >>= return . IM.toList+ modifyStrict $ \s -> s {streams = IM.empty}+ mapM_ addStream ls where- addStream (k,(p,d)) = do+ addStream (k,(p,(state',w'))) = do -- New reference for the stream r <- supply -- Run the drawing and get the new state (resource, annotation)- myBounds <- gets xobjectBound- cp <- gets currentPage- let (_,state',w') = runDrawing d (emptyEnvironment {streamId = r, xobjectb = myBounds, currentp = maybe Nothing (\(PDFReference x) -> Just x) cp })- ref = PDFReference r :: PDFReference PDFLength+ --myBounds <- gets xobjectBound+ --cp <- gets currentPage+ --let (_,state',w') = runDrawing d (emptyEnvironment {streamId = r, xobjectb = myBounds, currentp = maybe Nothing (\(PDFReference x) -> Just x) cp })+ let ref = PDFReference r :: PDFReference PDFLength -- Pattern NEEDS a resource entry even if empty otherwise don't work with acrobat reader -- Image DON'T want a resource entry if empty otherwise don't work with apple reader@@ -124,43 +132,30 @@ -- We compress only if the stream is not using its own filter if (compressed infos) && (not (pdfDictMember (PDFName "Filter") resources)) then do- let w'' = compress w'+ let w''' = compress . toLazyByteString $ w'+ w'' = fromLazyByteString w''' updateObject (PDFReference k :: PDFReference PDFStream) (PDFStream w'' True ref resources)- updateObject ref (PDFLength (B.length w''))+ updateObject ref (PDFLength (B.length w''')) else do updateObject (PDFReference k :: PDFReference PDFStream) (PDFStream w' False ref resources)- updateObject ref (PDFLength (B.length w'))+ updateObject ref (PDFLength (B.length . toLazyByteString $ w')) -- | Save all the pages and streams in the main object dictionary saveObjects :: PDF (PDFReference PDFCatalog) saveObjects = do- ls <- gets streams- createStreams . IM.toList $ ls+ -- Save streams to the object dictionary so that they are saved in the PDF document+ createStreams infos <- gets docInfo- -- Save pages and streams to the object dictionary so that they are saved in the PDF document+ -- Save pages to the object dictionary so that they are saved in the PDF document pRef <- addPages -- Create outlines object o <- gets outline oref <- addOutlines o -- Create the catalog cat <- addObject $ PDFCatalog oref pRef (pageMode infos) (pageLayout infos) (viewerPreferences infos)- modify $ \s -> s {catalog = cat}+ modifyStrict $ \s -> s {catalog = cat} gets catalog- --- | Write PDF objects in the TOC-writeObjectsAndCreateToc :: Handle -- ^ File handle- -> [B.ByteString] -- ^ List of objects each object being already converted to a bytestring- -> IO (Int,Int64,[B.ByteString])-writeObjectsAndCreateToc h l = foldM writeObject (0,0::Int64,[]) l where- writeObject (nb,len,toc) obj = do- -- Write the object to the file- B.hPut h obj- -- Remember the position- return (nb+1,len + B.length obj,(toByteString (printf "%010d 00000 n \n" ((fromIntegral len)::Integer))) : toc) -withFile :: FilePath -> (Handle -> IO c) -> IO c-withFile name = bracket (openBinaryFile name WriteMode) hClose- -- | The PDFTrailer #ifndef __HADDOCK__ data PDFTrailer = PDFTrailer @@ -180,8 +175,61 @@ where allInfos = [ (PDFName "Author",AnyPdfObject . author $ infos) , (PDFName "Subject",AnyPdfObject . subject $ infos)+ , (PDFName "Producer",AnyPdfObject $ toPDFString "HPDF - The Haskell PDF Library" ) ]- ++-- | Write PDF objects in the TOC+writeObjectsAndCreateToc :: [Builder] -- ^ List of objects each object being already converted to a bytestring+ -> (Int,Int64,[Builder])+writeObjectsAndCreateToc l = + let lengths = tail . scanl (\len obj -> len + (B.length . toLazyByteString $ obj)) 0 $ l+ createEntry x = serialize $ (printf "%010d 00000 n \n" ((fromIntegral x)::Integer) :: String)+ entries = map createEntry (init lengths) + in+ (length l,last lengths,entries)+-- foldr writeObject (0,0::Int64,[]) l where+-- writeObject obj (nb,len,toc) = (nb+1,len + (B.length . toLazyByteString $ obj),(serialize $ (printf "%010d 00000 n \n" ((fromIntegral len)::Integer))) : toc)+ +defaultPdfSettings :: PdfState+defaultPdfSettings = + PdfState {+ supplySrc = 1+ , objects = IM.empty+ , pages = noPages+ , streams = IM.empty+ , catalog = PDFReference 0+ , defaultRect = PDFRect 0 0 600 400 + , docInfo = standardDocInfo { author=toPDFString "Unknown", compressed = True}+ , outline = Nothing+ , currentPage = Nothing+ , xobjectBound = IM.empty+ , firstOutline = [True]+ }++createObjectByteStrings :: PdfState -> PDF a -> Builder +createObjectByteStrings pdfState m =+ let header = serialize "%PDF-1.5\n"+ objectEncoding (x,a) = toPDF . PDFReferencedObject (fromIntegral x) $ a+ (root,s) = flip runState pdfState . unPDF $ createPDF >> m >> saveObjects+ objs = objects s+ objectContents = header : (map objectEncoding . IM.toAscList $ objs)+ (nb,len,toc) = writeObjectsAndCreateToc objectContents+ in+ mconcat$ objectContents +++ [ serialize "xref\n"+ , serialize $ "0 " ++ show nb ++ "\n"+ , serialize "0000000000 65535 f \n"+ ]+ +++ toc+ +++ [ serialize "\ntrailer\n"+ , toPDF $ PDFTrailer nb root (docInfo pdfState)+ , serialize "\nstartxref\n"+ , serialize (show len)+ , serialize "\n%%EOF"+ ]+ -- | Generates a PDF document runPdf :: String -- ^ Name of the PDF document -> PDFDocumentInfo@@ -189,33 +237,7 @@ -> PDF a -- ^ PDF action -> IO () runPdf filename infos rect m = do- (root,s) <- flip runStateT vars . unPDF $ createPDF >> m >> saveObjects- let header = toByteString "%PDF-1.5\n"- objs = objects s- withFile filename $ \h -> do- (nb,len,toc) <- writeObjectsAndCreateToc h $ header : (map (toPDF . pointer) . IM.toAscList $ objs)- B.hPut h . toByteString $ "xref\n"- B.hPut h . toByteString $ "0 " ++ show nb ++ "\n"- B.hPut h . toByteString $ "0000000000 65535 f \n"- B.hPut h . B.concat . tail . reverse $ toc- B.hPut h . toByteString $ "\ntrailer\n"- B.hPut h . toPDF $ PDFTrailer nb root infos- B.hPut h . toByteString $ "\nstartxref\n"- B.hPut h . toByteString $ (show len)- B.hPut h . toByteString $ "\n%%EOF"- where- pointer (x,a) = PDFReferencedObject (fromIntegral x) a- vars = PdfState {- supplySrc = 1- , objects = IM.empty- , pages = noPages- , streams = IM.empty- , catalog = PDFReference 0- , defaultRect = rect- , docInfo = infos- , outline = Nothing- , currentPage = Nothing- , xobjectBound = IM.empty- , firstOutline = [True]- }+ let content = createObjectByteStrings (defaultPdfSettings {defaultRect = rect, docInfo = infos} ) m+ B.writeFile filename (toLazyByteString content)+
Graphics/PDF/Colors.hs view
@@ -32,7 +32,9 @@ import Graphics.PDF.LowLevel.Types import Control.Monad.State(gets) import Graphics.PDF.Resources-+import Control.Monad.Writer+import Graphics.PDF.LowLevel.Serializer+import Data.Monoid black :: Color black = Rgb 0 0 0 @@ -57,7 +59,10 @@ alphaMap <- gets strokeAlphas (newName,newMap) <- setResource "ExtGState" (StrokeAlpha alpha) alphaMap modifyStrict $ \s -> s { strokeAlphas = newMap }- writeCmd ("\n/" ++ newName ++ " gs")+ tell . mconcat $[ serialize "\n/" + , serialize newName+ , serialize " gs"+ ] -- | Set alpha value for transparency setFillAlpha :: Double -> Draw ()@@ -65,11 +70,14 @@ alphaMap <- gets fillAlphas (newName,newMap) <- setResource "ExtGState" (FillAlpha alpha) alphaMap modifyStrict $ \s -> s { fillAlphas = newMap }- writeCmd ("\n/" ++ newName ++ " gs")+ tell . mconcat $[ serialize "\n/" + , serialize newName+ , serialize " gs"+ ] -- | Init the PDF color space to RGB. setRGBColorSpace :: Draw ()-setRGBColorSpace = writeCmd "\n/DeviceRGB CS\n/DeviceRGB cs\n"+setRGBColorSpace = tell . serialize $ "\n/DeviceRGB CS\n/DeviceRGB cs\n" @@ -77,17 +85,46 @@ fillColor :: MonadPath m => Color -- ^ Filling color -> m () fillColor (Rgb r g b) = do- writeCmd $ "\n" ++ (show r) ++ " " ++ (show g) ++ " " ++ (show b) ++ " rg" + tell . mconcat $[ serialize "\n"+ , toPDF r+ , serialize ' '+ , toPDF g+ , serialize ' '+ , toPDF b+ , serialize " rg" + ]+ fillColor (Hsv h s v) = do let (r,g,b) = hsvToRgb (h,s,v)- writeCmd $ "\n" ++ (show r) ++ " " ++ (show g) ++ " " ++ (show b) ++ " rg"+ tell . mconcat $[ serialize "\n"+ , toPDF r+ , serialize ' '+ , toPDF g+ , serialize ' '+ , toPDF b+ , serialize " rg" + ] -- | Select the drawing color strokeColor :: MonadPath m => Color -- ^ Drawing color -> m () strokeColor (Rgb r g b) = do- writeCmd $ "\n" ++ (show r) ++ " " ++ (show g) ++ " " ++ (show b) ++ " RG" + tell . mconcat $[ serialize "\n"+ , toPDF r+ , serialize ' '+ , toPDF g+ , serialize ' '+ , toPDF b+ , serialize " RG" + ] strokeColor (Hsv h s v) = do let (r,g,b) = hsvToRgb (h,s,v)- writeCmd $ "\n" ++ (show r) ++ " " ++ (show g) ++ " " ++ (show b) ++ " RG" + tell . mconcat $[ serialize "\n"+ , toPDF r+ , serialize ' '+ , toPDF g+ , serialize ' '+ , toPDF b+ , serialize " RG" + ]
Graphics/PDF/Coordinates.hs view
@@ -24,7 +24,11 @@ import Graphics.PDF.LowLevel.Types import Graphics.PDF.Draw+import Control.Monad.Writer +import Graphics.PDF.LowLevel.Serializer+import Data.Monoid+ -- | Angle data Angle = Degree PDFFloat -- ^ Angle in degrees | Radian PDFFloat -- ^ Angle in radians@@ -64,8 +68,21 @@ -- | Apply a transformation matrix to the current coordinate frame applyMatrix :: Matrix -> Draw () applyMatrix (Matrix a b c d e f) = - writeCmd $ "\n" ++ show (a) ++ " " ++ show (b) ++ " " ++ show (c) ++ " " ++ show (d) ++ " " ++ show (e) ++ " " ++ show (f) ++ " cm"-+ tell . mconcat $[ serialize '\n'+ , toPDF a+ , serialize ' '+ , toPDF b+ , serialize ' '+ , toPDF c+ , serialize ' '+ , toPDF d+ , serialize ' '+ , toPDF e+ , serialize ' '+ , toPDF f+ , serialize " cm"+ ]+ -- | Rotation matrix rotate :: Angle -- ^ Rotation angle -> Matrix
− Graphics/PDF/Demo.hs
@@ -1,151 +0,0 @@------------------------------------------------------------- |--- Copyright : (c) alpha 2007--- License : BSD-style------ Maintainer : misc@NOSPAMalpheccar.org--- Stability : experimental--- Portability : portable------ PDF demo. Generate a file demo.pdf-----------------------------------------------------------module Graphics.PDF.Demo(demo) where--import Graphics.PDF- -fontDebug :: PDFFont -> PDFString -> Draw ()-fontDebug f t = do- drawText $ do- setFont f- textStart 10 200.0- leading $ getHeight f- renderMode FillText- displayText t- startNewLine- displayText $ toPDFString "Another little test"- strokeColor $ Rgb 1 0 0- stroke $ Line 10 200 612 200- fill $ Circle 10 200 10- stroke $ Rectangle 10 (200.0 - (getDescent f)) (10.0 + textWidth f t) (200.0 - getDescent f + getHeight f) -- -geometryTest :: Draw ()-geometryTest = do- strokeColor red- stroke $ Rectangle 0 0 200 100- fillColor blue- fill $ Ellipse 100 100 300 200- fillAndStroke $ RoundRectangle 32 32 200 200 600 400--lineStyle ::Draw ()-lineStyle = do- withNewContext $ do- setWidth 2- setDash $ DashPattern [3] 0- geometryTest- - -shadingTest :: Draw ()-shadingTest = do- paintWithShading (RadialShading 0 0 50 0 0 600 (Rgb 1 0 0) (Rgb 0 0 1)) (addShape $ Rectangle 0 0 300 300)- paintWithShading (AxialShading 300 300 600 400 (Rgb 1 0 0) (Rgb 0 0 1)) (addShape $ Ellipse 300 300 600 400)- - -patternTest :: PDFReference PDFPage -> PDF ()-patternTest page = do- p <- createUncoloredTiling 0 0 100 50 100 50 ConstantSpacing pattern- cp <- createColoredTiling 0 0 100 50 100 50 ConstantSpacing cpattern- drawWithPage page $ do- strokeColor green- setUncoloredFillPattern p (Rgb 1 0 0)- fillAndStroke $ Ellipse 0 0 300 300- setColoredFillPattern cp- fillAndStroke $ Ellipse 300 300 600 400- - where - myDrawing = do- stroke (Line 0 0 100 100)- fill (Rectangle 100 100 200 200)- pattern = do- stroke (Ellipse 0 0 100 50)- cpattern = do- 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)- -textTest :: Draw ()-textTest = do- strokeColor red- fillColor blue- fontDebug (PDFFont Times_Roman 48) (toPDFString "This is a test !")-- ---testImage :: FilePath -> PDFReference PDFPage -> PDF ()---testImage logo page = do--- Right jpg <- createPDFJpeg logo--- drawWithPage page $ do--- withNewContext $ do--- setFillAlpha 0.4--- drawXObject jpg--- withNewContext $ do--- applyMatrix $ rotate (Degree 20)--- applyMatrix $ translate 200 200--- applyMatrix $ scale 2 2--- drawXObject jpg- -testAll :: FilePath -> PDF ()-testAll logo = do- page <- addPage Nothing- newSection (toPDFString "Shapes") Nothing Nothing $ do- - newSection (toPDFString "Geometry") Nothing Nothing $ do- drawWithPage page $ do- geometryTest - - page <- addPage Nothing- newSection (toPDFString "Line style") Nothing Nothing $ do- drawWithPage page $ do- lineStyle- page <- addPage Nothing- newSection (toPDFString "Object reuse") Nothing Nothing $ do- r <- createPDFXForm 0 0 200 200 lineStyle- drawWithPage page $ do- drawXObject r- - page <- addPage Nothing- newSectionWithPage (toPDFString "Painting") Nothing Nothing page $ do- newSection (toPDFString "Patterns") Nothing Nothing $ do- patternTest page- page <- addPage Nothing- newSection (toPDFString "Shading") Nothing Nothing $ do- drawWithPage page $ do- shadingTest- page <- addPage Nothing- --newSection (toPDFString "Media") Nothing Nothing $ do- -- newSection (toPDFString "image") Nothing Nothing $ do - -- testImage logo page - - page <- addPage Nothing- newSection (toPDFString "Annotations") Nothing Nothing $ do- drawWithPage page $ do- testAnnotation - page <- addPage Nothing- newSection (toPDFString "Text") Nothing Nothing $ do- drawWithPage page $ do- textTest- - --- | Run the demo and create a demo.pdf file -demo :: IO()-demo = do- let rect = PDFRect 0 0 600 400- runPdf "demo.pdf" (standardDocInfo { author=toPDFString $ "alpheccar"}) rect $ do- testAll ""-
Graphics/PDF/Document.hs view
@@ -47,8 +47,7 @@ import Control.Monad.State import qualified Data.IntMap as IM import qualified Data.Map as M--+import Data.Monoid -- | No information for the document standardDocInfo :: PDFDocumentInfo @@ -113,7 +112,7 @@ -- | Draw on a given page drawWithPage :: PDFReference PDFPage -- ^ Page -> Draw a -- ^ Drawing commands- -> PDF ()+ -> PDF a drawWithPage page draw = do -- Get the page dictionary lPages <- gets pages@@ -122,13 +121,16 @@ -- Look for the page let thePage = findPage page lPages case thePage of- Nothing -> return ()+ Nothing -> error "Can't find the page to draw on it" -- If the page is found, get its stream reference and look for the stream Just(PDFPage _ _ (PDFReference streamRef) _ _ _ _) -> do let theContent = IM.lookup streamRef lStreams case theContent of- Nothing -> return()+ Nothing -> error "Can't find a content for the page to draw on it" -- If the stream is found- Just (_,c) -> do+ Just (_,(oldState,oldW)) -> do -- Create a new cntent and update the stream- modifyStrict $ \s -> s {streams = IM.insert streamRef (Just page,c >> draw >> return ()) lStreams}+ myBounds <- gets xobjectBound+ let (a,state',w') = runDrawing draw (emptyEnvironment {streamId = streamRef, xobjectb = myBounds}) oldState+ modifyStrict $ \s -> s {streams = IM.insert streamRef (Just page,(state',mappend oldW w')) lStreams}+ return a
Graphics/PDF/Draw.hs view
@@ -19,7 +19,7 @@ , DrawEnvironment(..) , supplyName , emptyDrawing- , writeCmd+-- , writeCmd , runDrawing , setResource , emptyEnvironment@@ -62,10 +62,10 @@ , AnnotationStyle(..) , PDFShading(..) , getRgbColor+ , emptyDrawState ) where import Graphics.PDF.LowLevel.Types-import qualified Data.ByteString.Lazy as B import Control.Monad.RWS import Control.Monad.Writer import Control.Monad.Reader@@ -75,6 +75,9 @@ import qualified Data.IntMap as IM import Graphics.PDF.Data.PDFTree(PDFTree) import Data.Maybe+import qualified Data.Binary.Builder as BU+import Graphics.PDF.LowLevel.Serializer+import Data.Monoid data AnnotationStyle = AnnotationStyle !(Maybe Color) @@ -119,21 +122,20 @@ data DrawEnvironment = DrawEnvironment { streamId :: Int , xobjectb :: IM.IntMap (PDFFloat,PDFFloat)- , currentp :: Maybe Int } emptyEnvironment :: DrawEnvironment-emptyEnvironment = DrawEnvironment 0 IM.empty Nothing+emptyEnvironment = DrawEnvironment 0 IM.empty -- | The drawing monad-newtype Draw a = Draw {unDraw :: RWS DrawEnvironment B.ByteString DrawState a} +newtype Draw a = Draw {unDraw :: RWS DrawEnvironment BU.Builder DrawState a} #ifndef __HADDOCK__- deriving(Monad,MonadWriter B.ByteString, MonadReader DrawEnvironment, MonadState DrawState, Functor)+ deriving(Monad,MonadWriter BU.Builder, MonadReader DrawEnvironment, MonadState DrawState, Functor) #else instance Monad Draw-instance MonadWriter B.ByteString Draw+instance MonadWriter BU.Builder Draw instance MonadReader DrawEnvironment Draw instance MonadState DrawState Draw instance Functor Draw@@ -142,16 +144,16 @@ instance MonadPath Draw -- | A PDF stream object-data PDFStream = PDFStream !B.ByteString !Bool !(PDFReference PDFLength) !PDFDictionary+data PDFStream = PDFStream !BU.Builder !Bool !(PDFReference PDFLength) !PDFDictionary instance PdfObject PDFStream where toPDF (PDFStream s c l d) = - B.concat $ [ toPDF dict- , toByteString "\nstream"+ mconcat $ [ toPDF dict+ , serialize "\nstream" , newline , s , newline- , toByteString "endstream"]+ , serialize "endstream"] where compressedStream False = [] compressedStream True = if not (pdfDictMember (PDFName "Filter") d) then [(PDFName "Filter",AnyPdfObject $ [AnyPdfObject . PDFName $ "FlateDecode"])] else []@@ -165,10 +167,6 @@ -- | is member of the dictionary pdfDictMember :: PDFName -> PDFDictionary -> Bool pdfDictMember k (PDFDictionary d) = M.member k d- --- | Write a command to the drawing-writeCmd :: (MonadWriter B.ByteString m) => String -> m ()-writeCmd = tell . toByteString -- | Get a new resource name supplyName :: Draw String@@ -176,27 +174,24 @@ (x:xs) <- gets supplyNames modifyStrict $ \s -> s {supplyNames = xs} return x+ +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 -- | Execute the drawing commands to get a new state and an uncompressed PDF stream-runDrawing :: Draw a -> DrawEnvironment -> (a,DrawState,B.ByteString)-runDrawing drawing environment = - let names = (map (("O" ++ (show . streamId $ environment)) ++ ) $ [replicate k ['a'..'z'] | k <- [1..]] >>= sequence)- state = DrawState - names- emptyRsrc- M.empty M.empty M.empty M.empty - emptyDictionary [] M.empty M.empty M.empty- (a,state',w') = (runRWS . unDraw $ drawing) environment state - in- (a,state',w')+runDrawing :: Draw a -> DrawEnvironment -> DrawState -> (a,DrawState,BU.Builder)+runDrawing drawing environment state = (runRWS . unDraw $ drawing) environment state + -- | 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- writeCmd "\nq"+ tell . serialize $ "\nq" a <- m- writeCmd "\nQ"+ tell . serialize $ "\nQ" return a -- | Set a resource in the resource dictionary@@ -222,7 +217,10 @@ xobjectMap <- gets xobjects (newName,newMap) <- setResource "XObject" (PDFReference r) xobjectMap modifyStrict $ \s -> s { xobjects = newMap }- writeCmd ("\n/" ++ newName ++ " Do")+ tell . mconcat $ [ serialize "\n/" + , serialize newName+ , serialize " Do"+ ] drawXObject = privateDrawXObject bounds (PDFReference r) = getBound r@@ -270,7 +268,7 @@ data PdfState = PdfState { supplySrc :: !Int -- ^ Supply of unique identifiers , objects :: !(IM.IntMap AnyPdfObject) -- ^ Dictionary of PDF objects , pages :: !Pages -- ^ Pages- , streams :: !(IM.IntMap ((Maybe (PDFReference PDFPage)),Draw ())) -- ^ Draw commands+ , streams :: !(IM.IntMap ((Maybe (PDFReference PDFPage)),(DrawState,BU.Builder))) -- ^ Draw commands , catalog :: !(PDFReference PDFCatalog) -- ^ Reference to the PDF catalog , defaultRect :: !PDFRect -- ^ Default page size , docInfo :: !PDFDocumentInfo -- ^ Document infos@@ -340,14 +338,13 @@ deriving(Eq) -- | The PDF Monad-newtype PDF a = PDF {unPDF :: StateT PdfState IO a}+newtype PDF a = PDF {unPDF :: State PdfState a} #ifndef __HADDOCK__- deriving (Functor, Monad, MonadState PdfState, MonadIO)+ deriving (Functor, Monad, MonadState PdfState) #else instance Functor PDF instance Monad PDF instance MonadState PdfState PDF-instance MonadIO PDF #endif -- | Transition style@@ -405,9 +402,9 @@ , (PDFName "Last",AnyPdfObject lasto) ] -data OutlineStyle = Normal- | Italic- | Bold+data OutlineStyle = NormalOutline+ | ItalicOutline+ | BoldOutline deriving(Eq) data PDFOutlineEntry = PDFOutlineEntry !PDFString @@ -521,9 +518,9 @@ instance PdfObject OutlineStyle where- toPDF Normal = toPDF (PDFInteger 0)- toPDF Italic = toPDF (PDFInteger 1)- toPDF Bold = toPDF (PDFInteger 2)+ toPDF NormalOutline = toPDF (PDFInteger 0)+ toPDF ItalicOutline = toPDF (PDFInteger 1)+ toPDF BoldOutline = toPDF (PDFInteger 2) instance PdfObject PDFOutlineEntry where toPDF (PDFOutlineEntry title theParent prev next first theLast count dest color style) =
Graphics/PDF/Image.hs view
@@ -14,8 +14,10 @@ -- * Images -- ** Types PDFJpeg+ , JpegFile -- ** Functions , createPDFJpeg+ , readJpegFile ) where import Graphics.PDF.LowLevel.Types@@ -31,6 +33,7 @@ import Data.Bits import Control.Monad.Error import Graphics.PDF.Coordinates+import Data.Binary.Builder(Builder,fromLazyByteString) m_sof0 :: Int m_sof0 = 0xc0 @@ -143,7 +146,7 @@ io = FA . liftIO -- | File analyzer monad-newtype FA a = FA {unFA :: ErrorT String PDF a} +newtype FA a = FA {unFA :: ErrorT String IO a} #ifndef __HADDOCK__ deriving(Monad,MonadError String,Functor) #else@@ -153,7 +156,7 @@ instance Functor FA #endif -runFA :: FA a -> PDF (Either String a)+runFA :: FA a -> IO (Either String a) runFA = runErrorT . unFA readWord16 :: Handle -> FA Int@@ -238,42 +241,53 @@ --test = analyzePng "Test/logo.png" --- | Create a PDF XObject for a JPEG image-createPDFJpeg :: FilePath- -> PDF (Either String (PDFReference PDFJpeg))-createPDFJpeg f = do+-- | Read a JPEG file and return an abstract description of its content or an error+readJpegFile :: FilePath+ -> IO (Either String JpegFile)+readJpegFile f = do h <- liftIO $ openBinaryFile f ReadMode r <- runFA (analyzeJpeg h) liftIO $ hClose h case r of- Right settings@(_,height,width,_) -> do+ Right (bits_per_component,height,width,color_space) -> do img <- liftIO $ B.readFile f- PDFReference s <- createContent (a' img settings) Nothing - recordBound s width height- return (Right $ PDFReference s) + return (Right $ JpegFile bits_per_component width height color_space (fromLazyByteString img)) Left s -> return $ Left s - where- color c = case c of- 1 -> [(PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceGray")]- 3 -> [(PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceRGB")]- 4 -> [(PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceCMYK")- ,(PDFName "Decode",AnyPdfObject . map (AnyPdfObject . PDFInteger) $ [1,0,1,0,1,0,1,0])- ]- _ -> error "Jpeg color space not supported"- a' img (bits_per_component,height,width,color_space) = - do modifyStrict $ \s -> s {otherRsrcs = PDFDictionary. M.fromList $ - [ (PDFName "Type",AnyPdfObject . PDFName $ "XObject")- , (PDFName "Subtype",AnyPdfObject . PDFName $ "Image")- , (PDFName "Width",AnyPdfObject . PDFInteger $ round width)- , (PDFName "Height",AnyPdfObject . PDFInteger $ round height)- , (PDFName "BitsPerComponent",AnyPdfObject . PDFInteger $ bits_per_component)- , (PDFName "Interpolate", AnyPdfObject True)- , (PDFName "Filter",AnyPdfObject . PDFName $ "DCTDecode")- ] ++ color color_space- }- tell img- ++ +-- | 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 + -> PDF (PDFReference PDFJpeg)+createPDFJpeg (JpegFile bits_per_component width height color_space img) = do+ PDFReference s <- createContent a' Nothing + recordBound s width height+ return (PDFReference s) + where+ color c = case c of+ 1 -> [(PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceGray")]+ 3 -> [(PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceRGB")]+ 4 -> [(PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceCMYK")+ ,(PDFName "Decode",AnyPdfObject . map (AnyPdfObject . PDFInteger) $ [1,0,1,0,1,0,1,0])+ ]+ _ -> error "Jpeg color space not supported"+ a' = + do modifyStrict $ \s -> s {otherRsrcs = PDFDictionary. M.fromList $ + [ (PDFName "Type",AnyPdfObject . PDFName $ "XObject")+ , (PDFName "Subtype",AnyPdfObject . PDFName $ "Image")+ , (PDFName "Width",AnyPdfObject . PDFInteger $ round width)+ , (PDFName "Height",AnyPdfObject . PDFInteger $ round height)+ , (PDFName "BitsPerComponent",AnyPdfObject . PDFInteger $ bits_per_component)+ , (PDFName "Interpolate", AnyPdfObject True)+ , (PDFName "Filter",AnyPdfObject . PDFName $ "DCTDecode")+ ] ++ color color_space+ }+ tell img + +-- | A Jpeg file +data JpegFile = JpegFile !Int !PDFFloat !PDFFloat !Int !Builder +-- | A Jpeg PDF object data PDFJpeg instance PDFXObject PDFJpeg where drawXObject a = withNewContext $ do
+ Graphics/PDF/LowLevel/Serializer.hs view
@@ -0,0 +1,76 @@+---------------------------------------------------------+-- |+-- Copyright : (c) alpha 2006+-- License : BSD-style+--+-- Maintainer : misc@NOSPAMalpheccar.org+-- Stability : experimental+-- Portability : portable+--+-- Serializer+---------------------------------------------------------+-- #hide+module Graphics.PDF.LowLevel.Serializer(+ SerializeValue(..)+ ) where+ +import Data.Word +import qualified Data.ByteString.Lazy as B+import qualified Data.Binary.Builder as BU+import qualified Data.ByteString.Lazy.Char8 as C+import Data.Encoding+import Data.Encoding.UTF8+import Foreign.Ptr(Ptr)+import Data.Monoid+import Data.ByteString.Base++foreign import ccall "conversion.h c_floatToString" cfloatToString :: Double -> Ptr Word8 -> IO Int+foreign import ccall "conversion.h c_shortToString" cshortToString :: Int -> Ptr Word8 -> IO Int++++class (Monoid s) => SerializeValue s a where+ serialize :: a -> s+ cons :: a -> s -> s+ cons a b = (serialize a) `mappend` b+ +instance SerializeValue B.ByteString Word8 where+ serialize = B.singleton+ cons = B.cons+ +instance SerializeValue B.ByteString Char where+ serialize = C.singleton+ cons = C.cons + +instance SerializeValue B.ByteString [Char] where+ serialize = encodeLazy UTF8+ +instance SerializeValue B.ByteString B.ByteString where+ serialize = id+ +instance SerializeValue B.ByteString Int where+ serialize a = LPS [inlinePerformIO (createAndTrim 12 (cshortToString a))]+ +instance SerializeValue B.ByteString Double where+ serialize a = LPS [inlinePerformIO (createAndTrim 12 (cfloatToString a))]++ +instance SerializeValue BU.Builder Word8 where+ serialize = BU.singleton++instance SerializeValue BU.Builder Char where+ serialize = BU.singleton . c2w+ +instance SerializeValue BU.Builder [Char] where+ serialize = BU.fromLazyByteString . serialize++instance SerializeValue BU.Builder B.ByteString where+ serialize = BU.fromLazyByteString++instance SerializeValue BU.Builder Int where+ serialize = BU.fromLazyByteString . serialize++instance SerializeValue BU.Builder Double where+ serialize = BU.fromLazyByteString . serialize++
Graphics/PDF/LowLevel/Types.hs view
@@ -12,8 +12,6 @@ -- #hide module Graphics.PDF.LowLevel.Types where -import qualified Data.ByteString.Lazy as B-import Data.ByteString.Base(c2w) import qualified Data.Map as M import Data.List(intersperse) import Data.Int@@ -22,12 +20,19 @@ import Control.Monad.Writer import Data.Encoding-import Data.Encoding.UTF8 import Data.Encoding.ISO88591 +import System.Random +import Data.Binary.Builder(Builder,fromByteString)+import Graphics.PDF.LowLevel.Serializer+import Data.Monoid+import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString as S+import Data.ByteString.Base(LazyByteString(..))+ -- | PDF Objects class PdfObject a where- toPDF :: a -> B.ByteString+ toPDF :: a -> Builder -- | Anonymous PDF object data AnyPdfObject = forall a . PdfObject a => AnyPdfObject a@@ -50,36 +55,43 @@ fromInteger a = PDFLength (fromInteger a) -- | A real number in a PDF document-newtype PDFFloat = PDFFloat Double deriving(Eq,Ord,Num,Fractional,Floating,RealFrac,Real)+newtype PDFFloat = PDFFloat Double deriving(Eq,Ord,Num,Fractional,Floating,RealFrac,Real,Random) instance Show PDFFloat where show (PDFFloat x) = printf "%.5f" x instance PdfObject PDFInteger where- toPDF (PDFInteger a) = toByteString (show a)- + toPDF (PDFInteger a) = serialize a++instance PdfObject Int where+ toPDF a = serialize a+ instance PdfObject PDFLength where- toPDF (PDFLength a) = toByteString (show a)+ toPDF (PDFLength a) = serialize (show a) instance PdfObject PDFFloat where- toPDF (PDFFloat a) = toByteString (show a)+ toPDF (PDFFloat a) = serialize a +instance PdfObject Double where+ toPDF a = serialize a+ instance PdfObject Bool where- toPDF (True) = toByteString "true"- toPDF (False) = toByteString "false"+ toPDF (True) = serialize "true"+ toPDF (False) = serialize "false" --- | A PDFString-newtype PDFString = PDFString B.ByteString deriving(Eq,Ord)+-- | A PDFString containing a strict bytestring+newtype PDFString = PDFString S.ByteString deriving(Eq,Ord,Show) -- | Create a PDF string from an Haskell one toPDFString :: String -> PDFString-toPDFString = PDFString . encodeLazy ISO88591 . escapeString+toPDFString = PDFString . encode ISO88591 . escapeString --- | Convert an Haskell string to an UTF8 encoded bytestring-toByteString :: String -> B.ByteString---toByteString = B.pack . encode-toByteString = encodeLazy UTF8+instance SerializeValue B.ByteString PDFString where+ serialize (PDFString t) = LPS [t] +instance SerializeValue Builder PDFString where+ serialize (PDFString t) = fromByteString t+ -- | Escape PDF characters which have a special meaning escapeString :: String -> String escapeString [] = []@@ -90,69 +102,69 @@ -- Misc strings useful to build bytestrings -lparen :: B.ByteString-lparen = B.singleton . c2w $ '('--rparen :: B.ByteString-rparen = B.singleton . c2w $ ')'+lparen :: SerializeValue s Char => s+lparen = serialize '(' -lbracket :: B.ByteString-lbracket = B.singleton . c2w $ '['+rparen :: SerializeValue s Char => s+rparen = serialize ')' -rbracket :: B.ByteString-rbracket = B.singleton . c2w $ ']'+lbracket :: SerializeValue s Char => s+lbracket = serialize '[' -bspace :: B.ByteString-bspace = B.singleton . c2w $ ' '+rbracket :: SerializeValue s Char => s+rbracket = serialize ']' -blt :: B.ByteString-blt = B.singleton . c2w $ '<'+bspace :: SerializeValue s Char => s+bspace = serialize ' ' -bgt :: B.ByteString-bgt = B.singleton . c2w $ '>'+blt :: SerializeValue s Char => s+blt = serialize '<' -newline :: B.ByteString-newline = B.singleton . c2w $ '\n'+bgt :: SerializeValue s Char => s+bgt = serialize '>' -noPdfObject :: B.ByteString-noPdfObject = B.empty+newline :: SerializeValue s Char => s+newline = serialize '\n' +noPdfObject :: Monoid s => s+noPdfObject = mempty+ instance PdfObject PDFString where- toPDF (PDFString a) = B.concat [ lparen- , a- , rparen- ]+ toPDF a = mconcat [ lparen+ , serialize a+ , rparen+ ] -- | A PDFName object newtype PDFName = PDFName String deriving(Eq,Ord) instance PdfObject PDFName where- toPDF (PDFName a) = toByteString ("/" ++ a)+ toPDF (PDFName a) = serialize ("/" ++ a) -- | A PDFArray type PDFArray = [AnyPdfObject] -instance PdfObject PDFArray where- toPDF l = B.concat $ (lbracket:intersperse bspace (map toPDF l)) ++ [bspace] ++ [rbracket]+instance PdfObject a => PdfObject [a] where+ toPDF l = mconcat $ (lbracket:intersperse bspace (map toPDF l)) ++ [bspace] ++ [rbracket] -- | A PDFDictionary newtype PDFDictionary = PDFDictionary (M.Map PDFName AnyPdfObject) instance PdfObject PDFDictionary where- toPDF (PDFDictionary a) = B.concat $ [blt,blt,newline]+ toPDF (PDFDictionary a) = mconcat $ [blt,blt,newline] ++ [convertLevel a] ++ [bgt,bgt] where- convertLevel _ = let convertItem key value current = B.concat $ [ toPDF key- , bspace- , toPDF value- , newline- , current- ]+ convertLevel _ = let convertItem key value current = mconcat $ [ toPDF key+ , bspace+ , toPDF value+ , newline+ , current+ ] in - M.foldWithKey convertItem B.empty a+ M.foldWithKey convertItem mempty a -- | Am empty dictionary emptyDictionary :: PDFDictionary@@ -180,12 +192,12 @@ instance PdfObject a => PdfObject (PDFReferencedObject a) where toPDF (PDFReferencedObject referenceId obj) =- B.concat $ [ toByteString . show $ referenceId- , toByteString " 0 obj"+ mconcat $ [ serialize . show $ referenceId+ , serialize " 0 obj" , newline , toPDF obj , newline- , toByteString "endobj"+ , serialize "endobj" , newline , newline ] @@ -205,8 +217,8 @@ fromInteger a = PDFReference (fromInteger a) instance PdfObject s => PdfObject (PDFReference s) where- toPDF (PDFReference i) = B.concat $ [ toByteString . show $ i- , toByteString " 0 R"]+ toPDF (PDFReference i) = mconcat $ [ serialize . show $ i+ , serialize " 0 R"] @@ -220,4 +232,4 @@ put $! (f s) -- | A monad where paths can be created-class MonadWriter B.ByteString m => MonadPath m+class MonadWriter Builder m => MonadPath m
Graphics/PDF/Pages.hs view
@@ -78,7 +78,9 @@ createContent d page = do -- Create a new stream referenbce streamref <- supply- modifyStrict $ \s -> s {streams = IM.insert streamref (page,d >> return ()) (streams s)}+ myBounds <- gets xobjectBound+ let (_,state',w') = runDrawing d (emptyEnvironment {streamId = streamref, xobjectb = myBounds}) (emptyDrawState streamref)+ modifyStrict $ \s -> s {streams = IM.insert streamref (page,(state',w')) (streams s)} return (PDFReference streamref) -- | Returns a new unique identifier@@ -244,7 +246,7 @@ (-(length c)) dest (maybe (Rgb 0 0 0) id col)- (maybe Normal id style)+ (maybe NormalOutline id style) updateObject current o
Graphics/PDF/Pattern.hs view
@@ -29,6 +29,9 @@ import qualified Data.Map as M import Graphics.PDF.Pages(recordBound,createContent) import Control.Monad.State+import Control.Monad.Writer+import Graphics.PDF.LowLevel.Serializer+import Data.Monoid data PaintType = ColoredTiling | UncoloredTiling@@ -100,8 +103,11 @@ patternMap <- gets patterns (newName,newMap) <- setResource "Pattern" (PDFReference a) patternMap modifyStrict $ \s -> s { patterns = newMap }- writeCmd ("\n/Pattern cs")- writeCmd ("\n/" ++ newName ++ " scn")+ tell . serialize $ ("\n/Pattern cs")+ tell . mconcat $[ serialize "\n/" + , serialize newName+ , serialize " scn"+ ] -- | Set the stroke pattern setColoredStrokePattern :: PDFReference PDFColoredPattern -> Draw ()@@ -109,8 +115,11 @@ patternMap <- gets patterns (newName,newMap) <- setResource "Pattern" (PDFReference a) patternMap modifyStrict $ \s -> s { patterns = newMap }- writeCmd ("\n/Pattern CS")- writeCmd ("\n/" ++ newName ++ " SCN") + tell . serialize $ ("\n/Pattern CS")+ tell . mconcat $[ serialize "\n/" + , serialize newName+ , serialize " SCN"+ ] @@ -123,8 +132,21 @@ patternMap <- gets patterns (newName,newMap) <- setResource "Pattern" (PDFReference a) patternMap modifyStrict $ \s -> s { patterns = newMap }- writeCmd ("\n/" ++ newColorName ++ " cs")- writeCmd ("\n" ++ (show r) ++ " " ++ (show g) ++ " " ++ (show b) ++ " /" ++ newName ++ " scn")+ tell . mconcat $[ serialize "\n/" + , serialize newColorName+ , serialize " cs"+ ]+ tell . mconcat $[ serialize '\n'+ , toPDF r+ , serialize ' '+ , toPDF g+ , serialize ' '+ , toPDF b+ , serialize ' '+ , serialize " /"+ , serialize newName+ , serialize " scn"+ ] -- | Set the stroke pattern setUncoloredStrokePattern :: PDFReference PDFUncoloredPattern -> Color -> Draw ()@@ -135,5 +157,18 @@ patternMap <- gets patterns (newName,newMap) <- setResource "Pattern" (PDFReference a) patternMap modifyStrict $ \s -> s { patterns = newMap }- writeCmd ("\n/" ++ newColorName ++ " CS")- writeCmd ("\n" ++ (show r) ++ " " ++ (show g) ++ " " ++ (show b) ++ " /" ++ newName ++ " SCN")+ tell . mconcat $[ serialize "\n/" + , serialize newColorName+ , serialize " CS"+ ]+ tell . mconcat $ [ serialize '\n'+ , toPDF r+ , serialize ' '+ , toPDF g+ , serialize ' '+ , toPDF b+ , serialize ' '+ , serialize " /"+ , serialize newName+ , serialize " SCN"+ ]
Graphics/PDF/Resources.hs view
@@ -64,7 +64,7 @@ show Symbol = "Symbol" show ZapfDingbats = "ZapfDingbats" -data PDFFont = PDFFont FontName FontSize deriving(Eq)+data PDFFont = PDFFont FontName FontSize deriving(Eq,Show) instance Ord PDFFont where compare (PDFFont na sa) (PDFFont nb sb) = if sa == sb then compare na nb else compare sa sb
Graphics/PDF/Shading.hs view
@@ -20,6 +20,9 @@ import Graphics.PDF.LowLevel.Types import Control.Monad.State(gets) import Graphics.PDF.Shapes(setAsClipPath)+import Control.Monad.Writer+import Graphics.PDF.LowLevel.Serializer+import Data.Monoid -- | Set alpha value for transparency applyShading :: PDFShading -> Draw ()@@ -27,7 +30,10 @@ shadingMap <- gets shadings (newName,newMap) <- setResource "Shading" shade shadingMap modifyStrict $ \s -> s { shadings = newMap }- writeCmd ("\n/" ++ newName ++ " sh")+ tell . mconcat $[ serialize "\n/" + , serialize newName+ , serialize " sh"+ ] paintWithShading :: PDFShading -- ^ Shading -> Draw a -- ^ Shape to paint
Graphics/PDF/Shapes.hs view
@@ -53,7 +53,9 @@ import Graphics.PDF.LowLevel.Types import Graphics.PDF.Draw-import Data.List(intersperse)+import Control.Monad.Writer+import Graphics.PDF.LowLevel.Serializer+import Data.Monoid class Shape a where addShape :: a -> Draw ()@@ -148,11 +150,17 @@ -- | Set pen width setWidth :: MonadPath m => PDFFloat -> m ()-setWidth w = writeCmd $ "\n " ++ (show w) ++ " w"+setWidth w = tell . mconcat $[ serialize "\n" + , toPDF w+ , serialize " w"+ ] -- | Set pen width setMiterLimit :: MonadPath m => PDFFloat -> m ()-setMiterLimit w = writeCmd $ "\n " ++ (show w) ++ " M"+setMiterLimit w = tell . mconcat $[ serialize "\n" + , toPDF w+ , serialize " M"+ ] -- | Line cap styles data CapStyle = ButtCap@@ -168,17 +176,29 @@ -- | Set line cap setLineCap :: MonadPath m => CapStyle -> m ()-setLineCap w = writeCmd $ "\n " ++ (show . fromEnum $ w) ++ " J"+setLineCap w = tell . mconcat $[ serialize "\n " + , toPDF (fromEnum w)+ , serialize " J"+ ] -- | Set line join setLineJoin :: MonadPath m => JoinStyle -> m ()-setLineJoin w = writeCmd $ "\n " ++ (show . fromEnum $ w) ++ " j"+setLineJoin w = tell . mconcat $[ serialize "\n " + , toPDF (fromEnum w)+ , serialize " j"+ ] data DashPattern = DashPattern ![PDFFloat] PDFFloat deriving(Eq) -- | Set the dash pattern setDash :: MonadPath m => DashPattern -> m()-setDash (DashPattern a p) = writeCmd $ "\n " ++ show a ++ " " ++ (show p) ++ " d"+setDash (DashPattern a p) = + tell . mconcat$ [ serialize "\n " + , toPDF a+ , serialize ' '+ , toPDF p+ , serialize " d"+ ] -- | No dash pattern setNoDash :: MonadPath m => m ()@@ -192,7 +212,7 @@ -- | Close current path closePath :: Draw ()-closePath = writeCmd $ "\nh"+closePath = tell . serialize $ "\nh" -- | Append a cubic Bezier curve to the current path. The curve extends @@ -205,25 +225,58 @@ -> PDFFloat -- ^ x3 -> PDFFloat -- ^ y3 -> Draw ()-addBezierCubic x1 y1 x2 y2 x3 y3 = writeCmd $ "\n" ++ (concat . intersperse " ". map show $ [x1,y1,x2,y2,x3,y3]) ++ " c"-+addBezierCubic x1 y1 x2 y2 x3 y3 = + tell . mconcat $[ serialize "\n" + , toPDF x1+ , serialize ' '+ , toPDF y1+ , serialize ' '+ , toPDF x2+ , serialize ' '+ , toPDF y2+ , serialize ' '+ , toPDF x3+ , serialize ' '+ , toPDF y3+ , serialize " c"+ ]+ -- | Move pen to a given point without drawing anything moveto :: PDFFloat -- ^ Horizontal coordinate -> PDFFloat -- ^ Vertical coordinate -> Draw ()-moveto x y = writeCmd $ "\n" ++ (show x) ++ " " ++ (show y) ++ " m"+moveto x y = + tell . mconcat $[ serialize "\n" + , toPDF x+ , serialize ' '+ , toPDF y+ , serialize " m"+ ] -- | Draw a line from current point to the one specified by lineto lineto :: PDFFloat -- ^ Horizontal coordinate -> PDFFloat -- ^ Vertical coordinate -> Draw ()-lineto x y = writeCmd $ "\n" ++ (show x) ++ " " ++ (show y) ++ " l s"-+lineto x y = + tell . mconcat $[ serialize "\n" + , toPDF x+ , serialize ' '+ , toPDF y+ , serialize " l s"+ ]+ -- | Add a line from current point to the one specified by lineto addLineToPath :: PDFFloat -- ^ Horizontal coordinate -> PDFFloat -- ^ Vertical coordinate -> Draw ()-addLineToPath x y = writeCmd $ "\n" ++ (show x) ++ " " ++ (show y) ++ " l"+addLineToPath x y = + tell . mconcat $[ serialize "\n" + , toPDF x+ , serialize ' '+ , toPDF y+ , serialize " l"+ ]+ -- | A point type Point = (PDFFloat,PDFFloat)@@ -233,32 +286,32 @@ -> Draw () addPolygonToPath l = do (uncurry moveto) . head $ l- mapM_ (\(x,y) -> writeCmd $ "\n" ++ (show x) ++ " " ++ (show y) ++ " l") (tail l) + mapM_ (\(x,y) -> addLineToPath x y) (tail l) -- | Draw current path strokePath :: Draw () -strokePath = writeCmd "\nS"+strokePath = tell . serialize $ "\nS" -- | Fill current path fillPath :: Draw () -fillPath = writeCmd "\nf"+fillPath = tell . serialize $ "\nf" -- | Fill current path fillAndStrokePath :: Draw () -fillAndStrokePath = writeCmd "\nB"+fillAndStrokePath = tell . serialize $ "\nB" -- | Set clipping path setAsClipPathEO :: Draw () -setAsClipPathEO = writeCmd "\nW* n"+setAsClipPathEO = tell . serialize $ "\nW* n" -- | Set clipping path setAsClipPath :: Draw () -setAsClipPath = writeCmd "\nW n"+setAsClipPath = tell . serialize $ "\nW n" -- | Fill current path using even odd rule fillPathEO :: Draw () -fillPathEO = writeCmd "\nf*"+fillPathEO = tell . serialize $ "\nf*" -- | Fill current path using even odd rule fillAndStrokePathEO :: Draw () -fillAndStrokePathEO = writeCmd "\nB*"+fillAndStrokePathEO = tell . serialize $ "\nB*"
Graphics/PDF/Text.hs view
@@ -36,14 +36,14 @@ , textWidth , getDescent , getHeight- , textBox+ , ripText+ , charWidth ) where import Graphics.PDF.LowLevel.Types import Graphics.PDF.Draw import Control.Monad.State import Graphics.PDF.Resources-import qualified Data.ByteString.Lazy as B import Control.Monad.Writer import Control.Monad.Trans import qualified Data.Set as Set@@ -51,11 +51,15 @@ import Data.Word import Graphics.PDF.LowLevel.Kern(kerns) import qualified Data.Map as M(findWithDefault)-import Graphics.PDF.Shapes-import qualified Data.ByteString.Lazy.Char8 as B(words,unwords)+import Data.List(foldl')+import Data.Binary.Builder(Builder)+import Graphics.PDF.LowLevel.Serializer+import Data.Monoid+import qualified Data.ByteString as S+import Data.ByteString.Base(w2c,c2w) foreign import ccall "ctext.h c_getLeading" cgetLeading :: Int -> Int-foreign import ccall "ctext.h c_getAdvance" cgetAdvance :: Int -> Word8 -> Int+foreign import ccall "ctext.h c_getAdvance" cgetAdvance :: Int -> Int -> Int foreign import ccall "ctext.h c_getDescent" cgetDescent :: Int -> Int foreign import ccall "ctext.h c_hasKern" hasKern :: Int -> Bool @@ -76,13 +80,40 @@ getKern k = M.findWithDefault 0 k kerns textWidth :: PDFFont -> PDFString -> PDFFloat-textWidth (PDFFont n s) (PDFString t) = let w = sum . map (cgetAdvance (fromEnum n)) . B.unpack $ t in+textWidth (PDFFont n s) (PDFString t) = + let w = foldl' (\a b -> a + cgetAdvance (fromEnum n) (fromIntegral b)) 0 . S.unpack $ t+ in if hasKern (fromEnum n) then- trueSize s (w + (sum . map getKern $ [(fromEnum n,ca,cb) | (ca,cb) <- B.zip t (B.tail t)]))+ trueSize s (w + (foldl' (\a b -> a + getKern b) 0 $ [(fromEnum n,ca,cb) | (ca,cb) <- S.zip t (S.tail t)])) else trueSize s w+ +charWidth :: PDFFont -> Char -> PDFFloat+charWidth (PDFFont n s) c = let w = cgetAdvance (fromEnum n) (fromEnum c) in+ trueSize s w +c2i :: Char -> Int+c2i = fromEnum+ +ripText :: PDFFont -- ^ Font+ -> PDFString -- ^ String+ -> [(PDFFloat,Char)] -- ^ List of chars and char width taking into account kerning+ripText (PDFFont n s) (PDFString t) = getLetters (hasKern (fromEnum n)) . S.unpack $ t+ where+ getLetters _ [] = []+ getLetters _ [a] = [(trueSize s $ cgetAdvance (fromEnum n) (fromEnum a),w2c a)]+ getLetters False (a:l) = (trueSize s $ cgetAdvance (fromEnum n) (fromEnum a),w2c a) : getLetters False l+ getLetters True (a:b:c:d:l) | b == (c2w '/') && c == (c2w '-') = + let k = getKern (fromEnum n,a,d)+ kh = getKern (fromEnum n,a,c2w '-')+ hw = cgetAdvance (fromEnum n) (c2i '-') + in+ -- We record the hyphen size + an adaptation due to the different kerning with an hyphen+ (trueSize s $ cgetAdvance (fromEnum n) (fromEnum a) + k,w2c a):(0,'/'):(trueSize s $ hw-k+kh,'-'):getLetters True (d:l)+ | otherwise = (trueSize s $ cgetAdvance (fromEnum n) (fromEnum a) + getKern (fromEnum n,a,b),w2c a) : getLetters True (b:c:d:l)+ getLetters True (a:b:l) = (trueSize s $ cgetAdvance (fromEnum n) (fromEnum a) + getKern (fromEnum n,a,b),w2c a) : getLetters True (b:l)+ type FontState = (Set.Set FontName) data TextParameter = TextParameter { tc :: !PDFFloat@@ -95,43 +126,15 @@ defaultParameters :: TextParameter defaultParameters = TextParameter 0 0 100 0 0 (Set.empty) --- | Tolerance value when text is too long. We accept to overflow a little-tolerance :: PDFFloat-tolerance = 0.2---- | Format a text string inside a rectangle. Experimental and will be replaced by a better typesetting--- system in a next version-textBox :: PDFFont -- ^ Font to use- -> PDFString -- ^ Text to draw- -> Rectangle -- ^ Where to draw- -> Draw ()-textBox f@(PDFFont _ size) (PDFString s) (Rectangle xa _ xb yb) = do- let width = xb -xa- ws = textWidth f (toPDFString " ")- getLines _ l [] = [B.unwords . reverse $ l]- getLines c l (h:t) = let c' = c + ws + textWidth f (PDFString h) in- if c' > width + tolerance * (fromIntegral size)- then- (B.unwords . reverse $ l):getLines 0 [] (h:t)- else- getLines c' (h:l) t- drawText $ do- setFont f- leading $ getHeight f- textStart xa (yb + getDescent f)- startNewLine- mapM_ (\x -> displayText x >> startNewLine) (map PDFString . getLines 0 [] $ (B.words s))- - -- | The text monad -newtype PDFText a = PDFText {unText :: WriterT B.ByteString (State TextParameter) a} +newtype PDFText a = PDFText {unText :: WriterT Builder (State TextParameter) a} #ifndef __HADDOCK__ - deriving(Monad,Functor,MonadWriter B.ByteString)+ deriving(Monad,Functor,MonadWriter Builder) #else instance Monad PDFText instance Functor PDFText-instance MonadWriter B.ByteString PDFText+instance MonadWriter Builder PDFText #endif instance MonadPath PDFText@@ -154,7 +157,13 @@ setFont :: PDFFont -> PDFText () setFont (PDFFont n size) = PDFText $ do lift (modifyStrict $ \s -> s {fontState = Set.insert n (fontState s)})- writeCmd $ "\n/" ++ (show n) ++ " " ++ (show size) ++ " Tf"+ tell . mconcat$ [ serialize "\n/" + , serialize (show n)+ , serialize ' '+ , toPDF size+ , serialize " Tf"+ ]+ -- | Draw a text in the draw monad drawText :: PDFText a@@ -162,9 +171,9 @@ drawText t = do let ((a,w),s) = (runState . runWriterT . unText $ t) defaultParameters mapM_ addFontRsrc (Set.elems (fontState s))- writeCmd "\nBT"+ tell . serialize $ "\nBT" tell w- writeCmd "\nET"+ tell . serialize $ "\nET" return a where addFontRsrc f = modifyStrict $ \s -> s { rsrc = addResource (PDFName "Font") (PDFName (show f)) (toRsrc (PDFFont f 0)) (rsrc s)}@@ -173,59 +182,97 @@ textStart :: PDFFloat -> PDFFloat -> PDFText ()-textStart x y = writeCmd $ "\n" ++ (show x) ++ " " ++ (show y) ++ " Td" +textStart x y = tell . mconcat $ [ serialize '\n'+ , toPDF x+ , serialize ' '+ , toPDF y+ , serialize " Td"+ ]+ --writeCmd $ "\n" ++ (show x) ++ " " ++ (show y) ++ " Td" -- | Display some text displayText :: PDFString -> PDFText () displayText t = do tell . toPDF $ t- writeCmd " Tj"+ tell . serialize $ " Tj" -- | Start a new line (leading value must have been set) startNewLine :: PDFText ()-startNewLine = writeCmd "\nT*" +startNewLine = tell . serialize $ "\nT*" -- | Set leading value leading :: UnscaledUnit -> PDFText () leading v = PDFText $ do lift (modifyStrict $ \s -> s {tl = v})- writeCmd $ "\n" ++ (show v) ++ " TL"+ tell . mconcat $ [ serialize '\n'+ , toPDF v+ , serialize " TL"+ ] -- | Set the additional char space charSpace :: UnscaledUnit -> PDFText () charSpace v = PDFText $ do lift (modifyStrict $ \s -> s {tc = v})- writeCmd $ "\n" ++ (show v) ++ " Tc"+ tell . mconcat $ [ serialize '\n'+ , toPDF v+ , serialize " Tc"+ ] -- | Set the additional word space wordSpace :: UnscaledUnit -> PDFText () wordSpace v = PDFText $ do lift (modifyStrict $ \s -> s {tw = v})- writeCmd $ "\n" ++ (show v) ++ " Tw"+ tell . mconcat $ [ serialize '\n'+ , toPDF v+ , serialize " Tw"+ ] -- | Set scaling factor for text textScale :: PDFFloat -> PDFText () textScale v = PDFText $ do lift (modifyStrict $ \s -> s {tz = v})- writeCmd $ "\n" ++ (show v) ++ " Tz"+ tell . mconcat $ [ serialize '\n'+ , toPDF v+ , serialize " Tz"+ ] -- | Choose the text rendering mode renderMode :: TextMode -> PDFText ()-renderMode v = writeCmd $ "\n" ++ (show . fromEnum $ v) ++ " Tr"+renderMode v = + tell . mconcat $ [ serialize '\n'+ , toPDF (fromEnum v)+ , serialize " Tr"+ ] -- | Set the rise value rise :: UnscaledUnit -> PDFText () rise v = PDFText $ do lift (modifyStrict $ \s -> s {ts = v})- writeCmd $ "\n" ++ (show v) ++ " Ts"+ tell . mconcat $ [ serialize '\n'+ , toPDF v+ , serialize " Ts"+ ] -- | Set the text transformation matrix setTextMatrix :: Matrix -> PDFText() setTextMatrix (Matrix a b c d e f) = - writeCmd $ "\n" ++ show (a) ++ " " ++ show (b) ++ " " ++ show (c) ++ " " ++ show (d) ++ " " ++ show (e) ++ " " ++ show (f) ++ " Tm"-+ tell . mconcat $[ serialize '\n'+ , toPDF a+ , serialize ' '+ , toPDF b+ , serialize ' '+ , toPDF c+ , serialize ' '+ , toPDF d+ , serialize ' '+ , toPDF e+ , serialize ' '+ , toPDF f+ , serialize " Tm"+ ]+ -- | Utility function to quickly display one line of text text :: PDFFont -> PDFFloat
+ Graphics/PDF/Typesetting.hs view
@@ -0,0 +1,326 @@+---------------------------------------------------------+-- |+-- Copyright : (c) alpha 2007+-- License : BSD-style+--+-- Maintainer : misc@NOSPAMalpheccar.org+-- Stability : experimental+-- Portability : portable+--+-- Experimental typesetting. It is a work in progress+---------------------------------------------------------++module Graphics.PDF.Typesetting(+ -- * Typesetting+ -- ** Types+ Box(..)+ , DisplayableBox(..)+ , Style(..)+ , TextStyle(..)+ , StyleFunction(..)+ , AnyStyle+ , ParagraphStyle(..)+ , AnyParagraphStyle+ , MonadStyle(..)+ , Letter(..)+ , BoxDimension+ -- * Functions+ -- ** Text display+ , displayFormattedText+ -- ** Text construction operators+ , endParagraph+ , txt+ , paragraph+ -- * Paragraph construction operators+ , kern+ , addPenalty+-- , nullChar+ , mkLetter+ -- * Misc+ , mkDrawBox+ -- * Settings (similar to TeX ones)+ -- ** Line breaking settings+ , setFirstPassTolerance + , setSecondPassTolerance+ , setHyphenPenaltyValue + , setFitnessDemerit+ , setHyphenDemerit+ , setLinePenalty+ , getFirstPassTolerance + , getSecondPassTolerance+ , getHyphenPenaltyValue + , getFitnessDemerit+ , getHyphenDemerit+ , getLinePenalty+ -- ** Vertical mode settings+ , setBaseLineSkip+ , setLineSkipLimit+ , setLineSkip+ , getBaseLineSkip+ , getLineSkipLimit+ , getLineSkip+ -- * Styles+ -- ** Functions useful to change the paragraph style+ , getParaStyle+ , setParaStyle+ , getTextArea+ ) where+ +import Graphics.PDF.LowLevel.Types+import Graphics.PDF.Text+import Graphics.PDF.Draw+import Graphics.PDF.Shapes+import Control.Monad.RWS+import Graphics.PDF.Typesetting.Breaking+import Graphics.PDF.Typesetting.Vertical+import Graphics.PDF.Typesetting.Box++-- | 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+ -> s -- ^ Default horizontal style+ -> TM a -- ^ Typesetting monad+ -> Draw a -- ^ Draw monad+displayFormattedText area@(Rectangle xa y' _ y'') 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'')+ return a+ +--endParagraphBoxes :: [Letter] +--endParagraphBoxes = [glueBox Nothing 0 10000.0 0,penalty (-infinity)]++-- | Add a penalty+addPenalty :: Int -> Para()+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+ , paraSettings = defaultBreakingSettings+ , pageSettings = defaultVerState s'+ }+ +data TMState = TMState { tmStyle :: !AnyStyle+ , paraSettings :: !BRState+ , pageSettings :: !VerState+ }+ +newtype TM a = TM { unTM :: RWS Rectangle [VBox] TMState a} +#ifndef __HADDOCK__+ deriving(Monad,MonadWriter [VBox], MonadState TMState, MonadReader Rectangle, Functor)+#else+instance Monad TM+instance MonadWriter [VBox] TM+instance MonadState TMState TM+instance Functor TM+instance MonadReader Rectangle TM+#endif++newtype Para a = Para { unPara :: RWS BRState [Letter] AnyStyle a} +#ifndef __HADDOCK__+ deriving(Monad,MonadWriter [Letter], MonadReader BRState, MonadState AnyStyle, Functor)+#else+instance Monad Para+instance MonadWriter [Letter] Para+instance MonadState AnyStyle Para+instance Functor Para+instance MonadReader BRState Para+#endif++-- | A MonadStyle where some typesetting operators can be used+class Monad m => MonadStyle m where+ -- | Set the current text style+ setStyle :: Style a => a -> m ()+ + -- | Get the current text style+ currentStyle :: m AnyStyle+ + -- | 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 + -> PDFFloat -- ^ Width+ -> PDFFloat -- ^ Height+ -> PDFFloat -- ^ Descent+ -> m ()+ + -- | Add a glue using the current style+ glue :: PDFFloat -- ^ Size of glue (width or height depending on the mode)+ -> PDFFloat -- ^ Dilatation factor+ -> PDFFloat -- ^ Compression factor+ -> m ()+ + -- | Add a glue with no style (it is just a translation)+ unstyledGlue :: PDFFloat -- ^ Size of glue (width or height depending on the mode) + -> PDFFloat -- ^ Dilatation factor + -> PDFFloat -- ^ Compression factor + -> m ()+ + +instance MonadStyle TM where+ -- Set style of text+ setStyle f = modifyStrict $ \s -> s {tmStyle = AnyStyle f}++ -- Get current text style+ currentStyle = gets tmStyle+ + -- Add a box to the stream in vertical mode+ addBox a w h d = do+ style <- getParaStyle+ tell $ ([SomeVBox 0 (w,h,d) (AnyBox a) (Just style)])+ + -- Add a glue+ glue h y z = do+ style <- getParaStyle+ Rectangle xa _ xb _ <- getTextArea+ tell $ [vglue (Just style) h y z (xb-xa) 0]+ + -- Add a glue+ unstyledGlue h y z = do+ Rectangle xa _ xb _ <- getTextArea+ tell $ [vglue Nothing h y z (xb-xa) 0]+ +instance MonadStyle Para where+ -- Set style of text+ setStyle f = put $! AnyStyle f++ -- Get current text style+ currentStyle = get+ + -- Add a box to the stream in horizontal mode+ addBox a w h d = do+ f <- currentStyle+ addLetter . mkLetter (w,h,d) (Just f) $ a+ + -- Add a glue+ glue w y z = do+ f <- currentStyle+ tell $ [glueBox (Just f) w y z]+ + -- Add a glue+ unstyledGlue w y z = do+ tell $ [glueBox Nothing w y z]+ +-- | Run a paragraph. Style changes are local to the paragraph+runPara :: Para a -> TM a+runPara m = do+ TMState f settings pagesettings <- get+ let (a, s', boxes) = (runRWS . unPara $ closedPara ) settings f+ put $! TMState s' settings pagesettings+ style <- getParaStyle+ tell $ [Paragraph boxes (Just style) settings]+ return a+ where+ closedPara = do+ x <- m+ endParagraph False+ return x+ +-- | Get the current paragraph style+getParaStyle :: TM AnyParagraphStyle+getParaStyle = gets pageSettings >>= TM . return . paraStyle++-- | Change the current paragraph style+setParaStyle :: ParagraphStyle s => s -> TM ()+setParaStyle style = do+ modifyStrict $ \s -> s {pageSettings = (pageSettings s){paraStyle = AnyParagraphStyle style}}++-- | Add a letter to the paragraph+addLetter :: Letter -> Para ()+addLetter l = Para . tell $ [l]++-- | Add a new paragraph to the text+paragraph :: Para a -> TM a+paragraph = runPara++-- | Add a null char+--nullChar :: Para ()+--nullChar = Para . tell $ [nullLetter]+ +-- | Add a text line+txt :: String -> Para ()+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 w = do+ f <- currentStyle+ tell $ [kernBox f w]++setBaseLineSkip :: PDFFloat -> PDFFloat -> PDFFloat -> TM ()+setBaseLineSkip w y z = modifyStrict $ \s -> s {pageSettings = (pageSettings s){baselineskip = (w,y,z)}}+ +getBaseLineSkip :: TM (PDFFloat,PDFFloat,PDFFloat)+getBaseLineSkip = do+ s <- gets pageSettings+ return (baselineskip s)+ +setLineSkipLimit :: PDFFloat -> TM ()+setLineSkipLimit l = modifyStrict $ \s -> s {pageSettings = (pageSettings s){lineskiplimit=l}}++getLineSkipLimit :: TM PDFFloat+getLineSkipLimit = gets pageSettings >>= return . lineskiplimit++setLineSkip :: PDFFloat -> PDFFloat -> PDFFloat -> TM ()+setLineSkip w y z = modifyStrict $ \s -> s {pageSettings = (pageSettings s){lineskip = (w,y,z)}}++getLineSkip :: TM (PDFFloat,PDFFloat,PDFFloat)+getLineSkip = gets pageSettings >>= return . lineskip+ +setFirstPassTolerance :: PDFFloat -> TM ()+setFirstPassTolerance x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){firstPassTolerance = x}}++getFirstPassTolerance :: TM PDFFloat+getFirstPassTolerance = gets paraSettings >>= return . firstPassTolerance++setSecondPassTolerance :: PDFFloat -> TM ()+setSecondPassTolerance x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){secondPassTolerance = x}}++getSecondPassTolerance :: TM PDFFloat+getSecondPassTolerance = gets paraSettings >>= return . secondPassTolerance++setHyphenPenaltyValue :: Int -> TM ()+setHyphenPenaltyValue x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){hyphenPenaltyValue = x}}++getHyphenPenaltyValue :: TM Int+getHyphenPenaltyValue = gets paraSettings >>= return . hyphenPenaltyValue++setFitnessDemerit :: PDFFloat -> TM ()+setFitnessDemerit x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){fitness_demerit = x}}++getFitnessDemerit :: TM PDFFloat+getFitnessDemerit = gets paraSettings >>= return . fitness_demerit++setHyphenDemerit :: PDFFloat -> TM ()+setHyphenDemerit x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){flagged_demerit = x}}++getHyphenDemerit :: TM PDFFloat+getHyphenDemerit = gets paraSettings >>= return . flagged_demerit+ +setLinePenalty :: PDFFloat -> TM ()+setLinePenalty x = modifyStrict $ \s -> s {paraSettings = (paraSettings s){line_penalty = x}}+ +getLinePenalty :: TM PDFFloat+getLinePenalty = gets paraSettings >>= return . line_penalty+
+ Graphics/PDF/Typesetting/Box.hs view
@@ -0,0 +1,173 @@+---------------------------------------------------------+-- |+-- Copyright : (c) alpha 2006+-- License : BSD-style+--+-- Maintainer : misc@NOSPAMalpheccar.org+-- Stability : experimental+-- Portability : portable+--+-- Box+---------------------------------------------------------+-- #hide+module Graphics.PDF.Typesetting.Box (+ Box(..)+ , DisplayableBox(..)+ , AnyBox(..)+ , NullChar(..)+ , Overfull(..)+ , Style(..)+ , TextStyle(..)+ , StyleFunction(..)+ , AnyStyle(..)+ , BoxDimension+ , DrawBox+ ,mkDrawBox+ ) where+ +import Graphics.PDF.LowLevel.Types+import Graphics.PDF.Draw+import Graphics.PDF.Text+import Graphics.PDF.Shapes+import Graphics.PDF.Coordinates++-- | Make a drawing box. A box object containing a Draw value+mkDrawBox :: Draw () -> DrawBox+mkDrawBox d = DrawBox d++-- | A box containing a Draw value+newtype DrawBox = DrawBox (Draw())++instance Box DrawBox where+ boxWidth _ = 0+ boxHeight _ = 0+ boxDescent _ = 0+ +instance DisplayableBox DrawBox where+ strokeBox (DrawBox a) x y = do+ withNewContext $ do+ applyMatrix $ translate x y+ a+ +instance Show DrawBox where+ show _ = "DrawBox"++-- | Dimension of a box : width, height and descent+type BoxDimension = (PDFFloat,PDFFloat,PDFFloat)++-- | Text style used by PDF operators+data TextStyle = TextStyle { textFont :: !PDFFont+ , textStrokeColor :: !Color+ , textFillColor :: !Color+ , textMode :: !TextMode+ , penWidth :: !PDFFloat+ , scaleSpace :: !PDFFloat -- ^ Scaling factor for normal space size (scale also the dilation and compression factors)+ , scaleDilatation :: !PDFFloat -- ^ Scale the dilation factor of glues+ , scaleCompression :: !PDFFloat -- ^ Scale the compression factor of glues+ }+ deriving(Eq)+ +-- | What kind of style drawing function is required for a word+-- when word styling is enabled +data StyleFunction = DrawWord -- ^ Must style a word+ | DrawGlue -- ^ Must style a glue+ deriving(Eq) + +-- | Style of text (sentences and words) +class 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+ sentenceStyle _ = Nothing+ -- ^ Modify the look of a word+ wordStyle :: a -- ^ The style+ -> 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+ styleHeight :: a -> PDFFloat+ + -- | A style may change the descent of lines+ 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+ boxWidth :: a -- ^ Box+ -> PDFFloat -- ^ Width of the box+ + -- | Box height+ boxHeight :: a -> PDFFloat+ -- | Distance between box bottom and box baseline+ boxDescent :: a -> PDFFloat+ -- | Distance between box top and box baseline+ boxAscent :: a -> PDFFloat+ boxAscent a = boxHeight a - boxDescent a+ +instance Box BoxDimension where+ boxWidth (w,_,_) = w+ boxHeight (_,h,_) = h+ boxDescent (_,_,d) = d++-- | A box that can be displayed+class DisplayableBox a where+ -- | Draw a box+ strokeBox :: a -- ^ The box+ -> 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+ boxHeight (AnyBox a) = boxHeight a+ boxDescent (AnyBox a) = boxDescent a++instance DisplayableBox AnyBox where+ strokeBox (AnyBox a) = strokeBox a+ +instance Show AnyBox where+ show (AnyBox a) = show a+ +data AnyBox = forall a. (Show a,Box a, DisplayableBox a) => AnyBox a
+ Graphics/PDF/Typesetting/Breaking.hs view
@@ -0,0 +1,526 @@+---------------------------------------------------------+-- |+-- Copyright : (c) alpha 2006+-- License : BSD-style+--+-- Maintainer : misc@NOSPAMalpheccar.org+-- Stability : experimental+-- Portability : portable+--+-- Breaking algorithm used to split a paragraph into lines+-- or a text into pages+---------------------------------------------------------+-- #hide+module Graphics.PDF.Typesetting.Breaking (+ Letter(..)+ , formatList+ , infinity+ , createChar+ , kernBox+ , glueBox+ , penalty+ , spaceGlueBox+ , nullLetter+ , hyphenPenalty+ , splitText+ , MaybeGlue(..)+ , defaultBreakingSettings+ , BRState(..)+ , glueWidth+ , mkLetter+ ) where+ +import Graphics.PDF.LowLevel.Types+import Data.List(minimumBy) +import qualified Data.Map as Map+import Graphics.PDF.Text+import Graphics.PDF.Typesetting.Box+import Data.Maybe(fromJust)++-- | Create a null box+nullLetter :: Letter+nullLetter = mkLetter (0,0,0) Nothing NullChar++-- | Make a letter from any box+mkLetter :: (Show a, Box a, DisplayableBox a) => BoxDimension -- ^ Dimension of the box+ -> Maybe AnyStyle -- ^ Text style of the box (can use t)+ -> a -- ^ Box+ -> Letter+mkLetter d s a = Letter d (AnyBox a) s++-- | A letter which can be anything. Sizes are widths and for glue the dilation and compression factors+-- For the generic letter, height and descent are also provided+data Letter = Letter BoxDimension !AnyBox !(Maybe AnyStyle) -- ^ Any box as a letter+ | Glue !PDFFloat !PDFFloat !PDFFloat !(Maybe AnyStyle) -- ^ A glue with style to know if it is part of the same sentence+ | FlaggedPenalty !PDFFloat !Int !AnyStyle -- ^ Hyphen point+ | Penalty !Int -- ^ Penalty+ | AChar !AnyStyle !Char !PDFFloat -- ^ A char+ | Kern !PDFFloat !(Maybe AnyStyle) -- ^ A kern : non dilatable and non breakable glue+ +class MaybeGlue a where+ boxWidthWithRatio :: a -> PDFFloat -> PDFFloat+ +instance MaybeGlue Letter where+ boxWidthWithRatio = letterWidth+ +-- | Compute glue width with dilation+glueWidth :: PDFFloat -> PDFFloat -> PDFFloat -> PDFFloat -> PDFFloat+glueWidth w y z r = + if r >= 0 + then+ r*y + w+ else+ r*z + w+ +letterWidth :: Letter -- ^ letter+ -> PDFFloat -- ^ Adjustement ratio+ -> PDFFloat -- ^ Width+letterWidth (AChar _ _ w) _ = w+letterWidth (Letter dim _ _) _ = boxWidth dim+letterWidth (Glue w yi zi _) r = glueWidth w yi zi r+letterWidth (FlaggedPenalty _ _ _) _ = 0+letterWidth (Penalty _) _ = 0+letterWidth (Kern w _) _ = w+ +instance Show Letter where+ show (Letter _ a _) = "(Letter " ++ show a ++ ")"+ show (Glue a b c _) = "(Glue " ++ show a ++ " " ++ show b ++ " " ++ show c ++ ")"+ show (FlaggedPenalty a b _) = "(FlaggedPenalty " ++ show a ++ " " ++ show b ++ ")"+ show (Penalty a) = "(Penalty " ++ show a ++ ")"+ show (AChar _ t _) = "(Text " ++ show t ++ ")"+ show (Kern _ _) = "(Kern)"++type CB a = (PDFFloat,PDFFloat,PDFFloat,Int,a)+++class PointedBox a where+ isFlagged :: a -> Bool+ getPenalty :: a -> Int+ isPenalty :: a -> Bool+ letter :: a -> Letter+ position :: a -> Int+ cumulatedW :: a -> PDFFloat+ cumulatedY :: a -> PDFFloat+ cumulatedZ :: a -> PDFFloat+ isForcedBreak :: a -> Bool+ +instance PointedBox (PDFFloat,PDFFloat,PDFFloat,Int,Letter) where+ isFlagged (_,_,_,_,FlaggedPenalty _ _ _) = True + isFlagged _ = False+ isPenalty (_,_,_,_,FlaggedPenalty _ _ _) = True + isPenalty (_,_,_,_,Penalty _) = True + isPenalty _ = False+ getPenalty (_,_,_,_,FlaggedPenalty _ p _) = p+ getPenalty (_,_,_,_,Penalty p) = p+ getPenalty _ = 0+ letter (_,_,_,_,a) = a+ position (_,_,_,p,_) = p+ cumulatedW (w,_,_,_,_) = w+ cumulatedY (_,y,_,_,_) = y+ cumulatedZ (_,_,z,_,_) = z+ isForcedBreak (_,_,_,_,FlaggedPenalty _ p _) = p <= (-infinity)+ isForcedBreak (_,_,_,_,Penalty p) = p <= (-infinity)+ isForcedBreak _ = False+ + +instance PointedBox ZList where+ isPenalty (ZList _ b _) = isPenalty b+ isFlagged (ZList _ b _) = isFlagged b+ letter (ZList _ b _) = letter b+ position (ZList _ b _) = position b+ cumulatedW (ZList _ b _) = cumulatedW b+ cumulatedY (ZList _ b _) = cumulatedY b+ cumulatedZ (ZList _ b _) = cumulatedZ b+ getPenalty (ZList _ b _) = getPenalty b+ isForcedBreak (ZList _ b _) = isForcedBreak b+ +-- A penalty has no width unless you break on it so it needs a special processing+penaltyWidth :: Letter -> PDFFloat+penaltyWidth (FlaggedPenalty w _ _) = w+penaltyWidth _ = 0++data BreakNode = + BreakNode { totalWidth :: !PDFFloat+ , totalDilatation :: !PDFFloat+ , totalCompression :: !PDFFloat+ , demerit :: !PDFFloat+ , flagged :: !Bool+ , fitnessValue :: !Int+ , ratio :: !PDFFloat+ , previous :: Maybe (Int,Int,Int,BreakNode)+ }+ deriving(Show)+ +adjustRatio :: BreakNode+ -> ZList+ -> PDFFloat+ -> PDFFloat+adjustRatio a l maxw = + let w = cumulatedW l - totalWidth a + penaltyWidth (letter l)+ y = cumulatedY l - totalDilatation a+ z = cumulatedZ l - totalCompression a+ in+ if w == maxw + then 0.0+ else if w < maxw+ then+ if y > 0.0 then ((maxw - w) / y) else bigAdjustRatio+ else+ if z > 0.0 then ((maxw - w) / z) else bigAdjustRatio++badness :: PDFFloat -> PDFFloat+badness r = if r < (-1) then bigAdjustRatio else 100.0 * abs(r)**3.0++fitness :: PDFFloat -> Int+fitness r = + if r < (-0.5)+ then + 0+ else if r <= (-0.5)+ then+ 1+ else+ if r <= 1 + then+ 2+ else+ 3+ +-- | Breaking algorithm settings +data BRState = BRState { firstPassTolerance :: !PDFFloat -- ^ Default value 100+ , secondPassTolerance :: !PDFFloat -- ^ Default value 200+ , hyphenPenaltyValue :: !Int -- ^ Default value 50+ , fitness_demerit :: !PDFFloat -- ^ Default value 10000+ , flagged_demerit :: !PDFFloat -- ^ Default value 10000+ , line_penalty :: !PDFFloat -- ^ Default value 10+ }+ +defaultBreakingSettings :: BRState+defaultBreakingSettings = BRState 100 200 50 10000 10000 10+ +++computeDemerit :: BRState+ -> Bool+ -> PDFFloat -- ^ adjust ratio+ -> BreakNode -- ^ Flag for previous+ -> ZList -- ^ Flag for current+ -> Maybe(PDFFloat,Int) -- ^ Demerit for the breakpoint+computeDemerit settings sndPass r a z =+ let b = badness r+ p = getPenalty z + fitness' = fitness r+ tolerance = if sndPass then (secondPassTolerance settings) else (firstPassTolerance settings)+ in+ if (b <= tolerance) || sndPass+ then + let fld = if isFlagged z && (flagged a) then (flagged_demerit settings) else 0.0+ fid = if fitness' /= (fitnessValue a) then (fitness_demerit settings) else 0.0+ dem = max 1000.0 $ if p >= 0+ then+ fid + fld + ((line_penalty settings) + b) ** 2.0 + (fromIntegral p) ** 2.0+ else if p < 0 && p > (-infinity)+ then+ fid + fld + ((line_penalty settings) + b) ** 2.0 - (fromIntegral p)**2.0+ else+ fid + fld + ((line_penalty settings) + b) ** 2.0+ in+ Just (dem,fitness')+ else+ Nothing ++data MaybeCB a = NoCB + | OneCB !(CB a)+ deriving(Show)++data ZList = ZList (MaybeCB Letter) (PDFFloat,PDFFloat,PDFFloat,Int,Letter) [Letter] deriving(Show)+++createZList :: [Letter] -> ZList+createZList [] = error "List cannot be empty to create a zipper"+createZList l = ZList NoCB (0,0,0,1,head l) (tail l)++theEnd :: ZList -> Bool+theEnd (ZList _ _ []) = True+theEnd _ = False++-- | We create a new breakpoint but we get the cumulated dimensions only at the next box following the break+-- since glues and penalties are removed at the beginning of a line+createBreaknode :: Maybe (Int,Int,Int,BreakNode) -> ZList -> BreakNode+createBreaknode prev (ZList _ (w,y,z,_,FlaggedPenalty _ _ _) []) = BreakNode (w) (y) (z) 0.0 True 0 0.0 prev +createBreaknode prev (ZList _ (w,y,z,_,Penalty _) []) = BreakNode w (y) (z) 0.0 False 0 0.0 prev +createBreaknode prev (ZList _ (w,y,z,_,Glue w' y' z' _) []) = BreakNode (w + w') (y+y') (z+z') 0.0 False 0 0.0 prev +createBreaknode prev (ZList _ (w,y,z,_,a) []) = BreakNode (w + boxWidthWithRatio a 0.0) (y) (z) 0.0 False 0 0.0 prev +createBreaknode prev (ZList _ (w,y,z,_,FlaggedPenalty _ p _) _) | p <= infinity = BreakNode w y z 0.0 True 0 0.0 prev +createBreaknode prev (ZList _ (w,y,z,_,Penalty p) _) | p <= infinity = BreakNode w y z 0.0 False 0 0.0 prev +createBreaknode prev (ZList _ (w,y,z,_,Letter _ _ _) _) = BreakNode w y z 0.0 False 0 0.0 prev +createBreaknode prev (ZList _ (w,y,z,_,AChar _ _ _) _) = BreakNode w y z 0.0 False 0 0.0 prev +createBreaknode prev (ZList _ (w,y,z,_,Kern _ _) _) = BreakNode w y z 0.0 False 0 0.0 prev +createBreaknode prev z = createBreaknode prev (moveRight z)++-- | Create an hyphen penalty+hyphenPenalty :: BRState+ -> AnyStyle -- ^ Style of future hyphen+ -> PDFFloat -- ^ Size of hyphen taking into account the kerning that was perturbed by the hyphen introduction. The char before the hyphen is now bigger+ -> Letter+hyphenPenalty settings s w = FlaggedPenalty w (hyphenPenaltyValue settings) s++moveRight :: ZList -> ZList+moveRight (ZList _ c@(w,y,z,p,Glue w' y' z' _) r) = + let w'' = w + w'+ y''=y+y'+ z''=z+z'+ in+ ZList (OneCB c) (w'',y'',z'',p+1,head r) (tail r)+moveRight (ZList _ c@(w,y,z,p,a) r) = + let w' = boxWidthWithRatio a 0.0+ w'' = w + w'+ in+ ZList (OneCB c) (w'',y,z,p+1,head r) (tail r)++isFeasibleBreakpoint :: Bool -- ^ Second pass+ -> ZList -- ^ Current analyzed box+ -> Bool -- ^ Result+isFeasibleBreakpoint True (ZList _ (_,_,_,_,FlaggedPenalty _ p _) _) = p < infinity+isFeasibleBreakpoint False (ZList _ (_,_,_,_,FlaggedPenalty _ _ _) _) = False+isFeasibleBreakpoint _ (ZList _ (_,_,_,_,Penalty p) _) = p < infinity+isFeasibleBreakpoint _ (ZList NoCB _ _) = False+isFeasibleBreakpoint _ (ZList (OneCB (_,_,_,_,Letter _ _ _)) (_,_,_,_,Glue _ _ _ _) _) = True+isFeasibleBreakpoint _ (ZList (OneCB (_,_,_,_,AChar _ _ _)) (_,_,_,_,Glue _ _ _ _) _) = True+isFeasibleBreakpoint _ _ = False+++++-- Update a feasible breakpoint remembering only the best one+type PossibleBreak = ActiveNodes -- Line, demerit and break node+type ActiveNodes = Map.Map (Int,Int,Int) BreakNode++updateBreak :: BreakNode+ -> BreakNode+ -> BreakNode+updateBreak a b = if demerit a < demerit b then a else b ++-- | Check is a break point is possible+-- otherwise, if none is possible and there is only one remaining active point,+-- we force a breakpoint+updateWithNewRIfNoSolution :: Bool+ -> PDFFloat -- ^ Old r+ -> ZList -- ^ Current+ -> (Int,Int,Int)+ -> PossibleBreak+ -> ActiveNodes-- ^ Actives+ -> (PDFFloat -> ActiveNodes -> (PossibleBreak,ActiveNodes))+ -> (PossibleBreak,ActiveNodes)+updateWithNewRIfNoSolution sndPass r z key newbreak newmap f =+ if r < -1 + then + --if Map.size newmap > 1 then (newbreak,Map.delete key newmap) else f (-0.99) (Map.delete key newmap)+ if sndPass + then+ f (-0.99) (Map.delete key newmap)+ else+ (newbreak,Map.delete key newmap)+ else if isForcedBreak z+ then+ f r (Map.delete key newmap)+ else+ f r newmap ++getNewActiveBreakpoints :: BRState -> Bool -> (Int -> PDFFloat) -> ActiveNodes -> ZList -> (PossibleBreak,ActiveNodes)+getNewActiveBreakpoints settings sndPass fmaxw actives z = + if isFeasibleBreakpoint sndPass z+ then+ let analyzeActive key@(p,line,f) b (newbreak,newmap') = + let r' = adjustRatio b z (fmaxw (line+1))+ in+ updateWithNewRIfNoSolution sndPass r' z key newbreak newmap' $+ \r newmap -> let dem' = computeDemerit settings sndPass r b z in+ case dem' of+ Nothing -> (newbreak,newmap)+ Just (d',f') -> + let b' = createBreaknode (Just (p,line,f,b)) z in+ -- We keep only the best new break+ (Map.insertWith updateBreak (position z,line+1,f') (b' {demerit = d',fitnessValue = f', ratio = r}) newbreak ,newmap)+ in+ let (breaks',actives') = Map.foldWithKey analyzeActive (Map.empty,actives) actives+ dmin = minimum . map demerit . Map.elems $ breaks'+ nbreaks = Map.filter (\x -> demerit x < dmin + (fitness_demerit settings)) breaks'+ in+ if Map.null nbreaks+ then+ (breaks' , actives') + else+ (nbreaks , actives') + else+ (Map.empty,actives )+ +-- (position, line, fitness) -> (adjust ratio, break position)+genNodeList :: (Int,Int,Int,BreakNode) -> [(PDFFloat,Int,Bool)]+genNodeList (p,_,_,b@(BreakNode _ _ _ _ f _ _ Nothing)) = [(ratio b,p,f)]+genNodeList (p,_,_,b@(BreakNode _ _ _ _ f _ _ (Just _))) = (ratio b,p,f):genNodeList (fromJust . previous $ b)+++-- Analyze the boxes to compute breaks+analyzeBoxes :: BRState -> Bool -> (Int -> PDFFloat) -> ActiveNodes -> ZList -> [(PDFFloat,Int,Bool)]+analyzeBoxes settings pass fmaxw actives z = + let getMinBreak b' = (\((xc,yc,zc),w) -> (xc,yc,zc,w)) . minimumBy (\(_,a) (_,b) -> compare (demerit a) (demerit b)) . Map.toList $ b'+ (breaks',actives') = getNewActiveBreakpoints settings pass fmaxw actives z + newActives = Map.union breaks' actives'+ getRightOrderNodeList = tail . reverse . genNodeList+ getKey (a,b,c,_) = (a,b,c)+ getNode (_,_,_,BreakNode a b c d e f r _) = BreakNode a b c d e f r Nothing+ in+ -- If forced breakpoint or no breakpoint found+ if Map.null actives'+ then+ -- If no breakpoint found+ if Map.null breaks'+ then+ -- Second pass analysis+ if not pass+ then+ analyzeBoxes settings True fmaxw actives z+ else+ error "Second pass analysis failed ! Generally due to wrong width in the text area or an end of text before end of paragraph detected"+ else + -- Forced breakpoint then we gen a list from it and continue the analysis+ let minBreak = getMinBreak breaks' + someNewBreaks = getRightOrderNodeList minBreak+ in+ if theEnd z+ then+ someNewBreaks+ else+ someNewBreaks ++ analyzeBoxes settings pass fmaxw (Map.insert (getKey minBreak) (getNode minBreak) Map.empty) (moveRight z)+ -- Normal feasible breakpoint+ else+ if Map.null breaks'+ then+ if theEnd z+ then+ error "End of text found but no paragraph end detected"+ else+ analyzeBoxes settings pass fmaxw actives' (moveRight z)+ else+ -- If the end it must be a possible breakpoint+ -- We should NEVER reach this part. The end should always be a forced breakpoint+ if theEnd z+ then+ let minBreak = getMinBreak breaks' in+ getRightOrderNodeList minBreak+ else+ -- We continue the analysis+ analyzeBoxes settings pass fmaxw newActives (moveRight z)++-- | Create an hyphen box+hyphenBox :: AnyStyle -> Letter+hyphenBox s = AChar s '-' (charWidth (textFont . textStyle $ s) '-')++-- Use a list of breakpoint and adjustement ratios to generate a list of lines. Bool means if the break was done on a flagged penalty (hyphen)+cutList :: [Letter] -> Int -> [(PDFFloat,Int,Bool)] -> [(PDFFloat,[Letter])]+cutList [] _ _ = []+cutList t _ [] = [(0.0,t)]+cutList t c ((ra,ba,fa):l) = + let (theLine,t') = splitAt (ba-c) t + in+ if null theLine + then+ []+ else + if null t'+ then+ [(ra,theLine)]+ else+ case head t' of+ FlaggedPenalty _ _ s -> if not fa + then+ error $ "Breakpoint marked as not flagged but detected as flagged ! Send a bug report ! " ++ show (ra,ba,fa)+ else+ (ra,theLine ++ [hyphenBox s]) : cutList t' ba l+ _ -> if fa + then+ error "Breakpoint marked as flagged but detected as not flagged ! Send a bug report !"+ else+ (ra,theLine) : cutList t' ba l+ +-- Compute the breakpoints and generate a list of lines with the adjustement ratios+-- The line are not interpreted. Some additional postprocessing is required+-- for horizontal lines of vertical boxes+formatList :: BRState -> (Int -> PDFFloat) -> [Letter] -> [(PDFFloat,[Letter])]+formatList settings maxw boxes = + let active = Map.insert (0,0,1) (BreakNode 0 0 0 0 False 0 0.0 Nothing) Map.empty+ theBreaks = analyzeBoxes settings False maxw active (createZList boxes)+ in+ cutList boxes 1 theBreaks+ +-- | Value modeling infinity +infinity :: Int +infinity = 10000++bigAdjustRatio :: PDFFloat+bigAdjustRatio = 10000.0++-- | Add a glue to the stream+glueBox :: Maybe AnyStyle+ -> PDFFloat -- ^ Glue width+ -> PDFFloat -- ^ Glue dilatation+ -> PDFFloat -- ^ Glue compression+ -> Letter+glueBox s w y z = Glue w y z s++-- | Add a glue to the stream+spaceGlueBox :: AnyStyle -- ^ The style+ -> Letter+spaceGlueBox s = + let ws = (textWidth (textFont . textStyle $ s) (toPDFString " ") )+ h = scaleSpace . textStyle $ s+ sy = scaleDilatation . textStyle $ s+ sz = scaleCompression . textStyle $ s+ in+ Glue (ws*h) (h*sy*ws/2.0) (h*sz*ws/3.0) (Just s)++-- | Add a glue to the stream+punctuationGlue :: AnyStyle -- ^ The style+ -> Letter+punctuationGlue s = + let ws = (textWidth (textFont . textStyle $ s) (toPDFString " ") )+ h = scaleSpace . textStyle $ s+ sy = scaleDilatation . textStyle $ s+ sz = scaleCompression . textStyle $ s+ in+ Glue (ws*h) (h*sy*ws) (h*sz*ws/3.0) (Just s)+ +-- | Add a penalty to the stream+penalty :: Int -- ^ Penalty value+ -> Letter+penalty p = Penalty p++-- | Create a box containing text+createChar :: AnyStyle -- ^ Char style+ -> PDFFloat -- ^ Char width+ -> Char -- ^ Char code+ -> Letter+createChar s w t = AChar s t w+++-- | Create boxes for the letters+createLetterBoxes :: BRState+ -> AnyStyle -- ^ Letter style+ -> [(PDFFloat,Char)] -- ^ Letter and size + -> [Letter] -- ^ Boxes+createLetterBoxes _ _ [] = [] +createLetterBoxes settings s ((wa,'.'):b@(_,bc):l') | bc /= ' ' = (createChar s wa '.'): punctuationGlue s : createLetterBoxes settings s (b:l') + | otherwise = (createChar s wa '.') : punctuationGlue s : createLetterBoxes settings s l'+createLetterBoxes settings s ((_,'/'):(w,'-'):l) = hyphenPenalty settings s w : createLetterBoxes settings s l+createLetterBoxes settings s ((_,' '):l) = (spaceGlueBox s) : createLetterBoxes settings s l+createLetterBoxes settings s ((w,t):l) = (createChar s w t) : createLetterBoxes settings s l+ +-- WARNING : must generate a list of LETTERS+-- word are created with the analysis of style just above+-- | split a line into boxes+splitText :: BRState -> AnyStyle -> PDFString -> [Letter]+splitText settings f t = createLetterBoxes settings f . ripText (textFont . textStyle $ f) $ t++kernBox :: AnyStyle -> PDFFloat -> Letter+kernBox s w = Kern w (Just s)
+ Graphics/PDF/Typesetting/Horizontal.hs view
@@ -0,0 +1,345 @@+---------------------------------------------------------+-- |+-- Copyright : (c) alpha 2006f+-- License : BSD-style+--+-- Maintainer : misc@NOSPAMalpheccar.org+-- Stability : experimental+-- Portability : portable+--+-- Horizontal mode+---------------------------------------------------------+-- #hide+module Graphics.PDF.Typesetting.Horizontal (+ HBox(..)+ , mkHboxWithRatio+ , horizontalPostProcess+ ) where++import Graphics.PDF.LowLevel.Types+import Graphics.PDF.Typesetting.Breaking+import Graphics.PDF.Shapes+import Graphics.PDF.Draw+import qualified Data.ByteString.Char8 as S(pack)+import Data.Maybe(isJust,fromJust)+import Data.List(foldl')+import Graphics.PDF.Colors+import Graphics.PDF.Text+import Graphics.PDF.Typesetting.Box+import Control.Monad.Writer(tell)+import Control.Monad(when)+import Graphics.PDF.LowLevel.Serializer+import Data.Monoid++-- | Current word (created from letter) is converted to a PDFString+saveCurrentword :: String -> PDFString+saveCurrentword = PDFString . S.pack . reverse++-- 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 _ Nothing [] = []+-- Empty list, current word or sentence is added+createWords _ (Just (s,t,w)) [] = [createText s (saveCurrentword t) w]++-- 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+ | 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+createWords r (Just (s,t,w)) ((Glue w' y z (Just s')):l) = (createText s (saveCurrentword $ t) w):(HGlue w' (Just(y,z)) (Just s')):createWords r Nothing l++-- Penalties are invisible. The are needed just to compute breaks+createWords r c (Penalty _:l) = createWords r c l+createWords r c (FlaggedPenalty _ _ _:l) = createWords r c l++-- We just add the box+createWords r Nothing ((Glue w' y z s):l) = (HGlue w' (Just(y,z)) s):createWords r Nothing l+createWords r (Just (s,t,w)) ((Glue w' y z Nothing):l) = (createText s (saveCurrentword $ t) w):(HGlue w' (Just(y,z)) Nothing):createWords r Nothing l+ +createWords r Nothing ((Kern w' s):l) = (HGlue w' Nothing s):createWords r Nothing l+createWords r (Just (s,t,w)) ((Kern w' s'):l) = (createText s (saveCurrentword $ t) w):(HGlue w' Nothing s'):createWords r Nothing l++createWords r Nothing ((Letter d a s):l) = (SomeHBox d a s):createWords r Nothing l+createWords r (Just (s,t,w)) ((Letter d a st):l) = (createText s (saveCurrentword $ t) w):(SomeHBox d a st):createWords r Nothing l+ + +-- 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 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 [] = []+horizontalPostProcess ((r,l'):l) = let l'' = simplify r l' in+ if null l''+ then+ horizontalPostProcess l+ else+ (mkHboxWithRatio r l''):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)+ +-- | Change the style of the box +withNewStyle :: AnyStyle -> HBox -> HBox+withNewStyle _ a@(HBox _ _ _ _) = a+withNewStyle s (HGlue a b _) = HGlue a b (Just s)+withNewStyle s (Text _ a b) = Text s a b+withNewStyle s (SomeHBox d a _) = SomeHBox d a (Just s) + +-- | 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 r l = + let w = foldl' (\x y -> x + boxWidthWithRatio 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 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+ + +-- | Create an HBox +createText :: Style s => s -- ^ Style+ -> PDFString -- ^ String+ -> PDFFloat -- ^ Width+ -> HBox+createText s t w = Text (AnyStyle s) t w+++instance Show HBox 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 _ [] _ _ = return ()+drawTextLine style l@(a:l') x y | (isJust . wordStyle $ style) = do+ let h = boxHeight a+ d = boxDescent a+ y' = y + h - d+ strokeBox (withNewStyle style a) x y'+ drawTextLine (updateStyle style) l' (x + boxWidth a) y+ | 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 _ [] _ _ = return ()++drawWords s ((Text _ t w):l) x y = do+ (l',x') <- drawText $ do+ drawTheTextBox StartText s x y (Just t)+ drawPureWords s l (x + w) y+ drawWords s l' x' y+ +drawWords s l@((HGlue _ _ _ ):_) x y = do+ (l',x') <- drawText $ do+ drawTheTextBox StartText s x y Nothing+ drawPureWords s l x y+ drawWords s l' x' y+ +drawWords s (a@(SomeHBox _ _ _):l) x y = do+ let h = boxHeight a+ d = boxDescent a+ w = boxWidth a+ y' = y - d + h+ strokeBox a x y'+ drawWords s l (x + w) y++drawWords _ _ _ _ = return ()++-- | Draw only words and glues using PDF text commands+drawPureWords :: AnyStyle -> [HBox] -> PDFFloat -> PDFFloat -> PDFText ([HBox],PDFFloat) ++drawPureWords s [] x y = do+ drawTheTextBox StopText s x y Nothing+ return ([],x)+ +drawPureWords s ((Text _ t w):l) x y = do+ drawTheTextBox ContinueText s x y (Just t)+ drawPureWords s l (x + w) y+ +drawPureWords s ((HGlue w _ _):l) x y = do+ drawTextGlue s w+ drawPureWords s l (x + w) y + +drawPureWords s l@((SomeHBox _ _ _):_) x y = do+ drawTheTextBox StopText s x y Nothing+ return (l,x)+ +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 hl dl l x y style = + do+ -- Position of draw line based upon the whole line and not just this word+ let y' = y - hl + dl+ (l',l'') = span (isSameStyle style) l+ w' = foldl' (\x' ny -> x' + boxWidth ny) 0.0 l'+ if (isJust . sentenceStyle $ style)+ then do+ (fromJust . sentenceStyle $ style) (Rectangle x (y - hl) (x+w') (y)) (drawTextLine style l' x y')+ else do+ drawTextLine style l' x y'+ drawLineOfHboxes hl dl l'' (x + w') y+ ++drawLineOfHboxes :: 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+ -> PDFFloat -- ^ x for the remaining boxes+ -> PDFFloat -- ^ y for the whole line+ -> Draw ()+drawLineOfHboxes _ _ [] _ _ = return ()+-- | Start a new text+drawLineOfHboxes hl dl l@((Text style _ _):_) x y = startDrawingNewLineOfText hl dl l x y style+drawLineOfHboxes hl dl l@((HGlue _ _ (Just style)):_) x y = startDrawingNewLineOfText hl dl l x y style++drawLineOfHboxes hl dl (a:l) x y = do+ let h = boxHeight a+ d = boxDescent a+ -- Compute top of box a+ y' = y - hl + dl - d + h+ strokeBox a x y'+ drawLineOfHboxes hl dl l (x + boxWidth a) y++instance Box HBox where+ boxWidth (Text _ _ w) = w+ boxWidth (HBox w _ _ _) = w+ boxWidth (SomeHBox d _ _) = boxWidth d+ boxWidth (HGlue w _ _) = w + + boxHeight (Text style _ _) = styleHeight style+ boxHeight (HBox _ h _ _) = h+ boxHeight (SomeHBox d _ _) = boxHeight d+ boxHeight (HGlue _ _ (Just s)) = styleHeight s+ boxHeight (HGlue _ _ _) = 0+ + boxDescent (Text style _ _) = styleDescent style+ boxDescent (HBox _ _ d _) = d+ boxDescent (SomeHBox d _ _) = boxDescent d+ boxDescent (HGlue _ _ (Just s)) = styleDescent s+ boxDescent (HGlue _ _ _) = 0+ + +-- Draw a text box+drawTheTextBox :: Style style => TextDrawingState+ -> style+ -> PDFFloat+ -> PDFFloat+ -> Maybe PDFString+ -> PDFText ()+drawTheTextBox state style x y t = do+ when (state == StartText || state == OneBlock) $ (do+ setFont (textFont . textStyle $ style)+ strokeColor (textStrokeColor . textStyle $ style)+ fillColor (textFillColor . textStyle $ style)+ renderMode (textMode . 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+ when (state == StartText || state == OneBlock || state == ContinueText) $ (do+ case t of+ Nothing -> return ()+ Just myText -> tell $ toPDF myText+ )+ when (state == StopText || state == OneBlock) $ (do+ tell rbracket+ tell $ serialize " TJ")+ +-- | Draw the additional displacement required for a space in a text due to the dilaton of the glue+drawTextGlue :: Style style => style+ -> PDFFloat+ -> PDFText ()+drawTextGlue style w = do + let ws = (textWidth (textFont . textStyle $ style) (toPDFString " "))+ PDFFont _ size = textFont . textStyle $ style+ delta = w - ws + return ()+ tell . mconcat $ [ lparen, bspace,rparen,bspace,toPDF ((-delta) * 1000.0 / (fromIntegral size) ), bspace] + + +data TextDrawingState = StartText -- ^ Send PDF commands needed to start a text+ | ContinueText -- ^ Continue adding text+ | StopText -- ^ Stop the text+ | OneBlock -- ^ One block of text+ deriving(Eq)+ +instance DisplayableBox HBox where+ strokeBox a@(HBox _ _ _ l) x y = do+ let he = boxHeight a+ de = boxDescent a+ drawLineOfHboxes he de l x y+ + strokeBox a@(HGlue w _ (Just style)) x y = do+ let de = boxDescent a+ he = boxHeight a+ y' = y - he + de+ -- In word mode we have to apply a special function to the word+ -- otherwise we apply a different function to the sentence+ if (isJust . wordStyle $ style)+ then+ (fromJust . wordStyle $ style) (Rectangle x (y' - de) (x+w) (y' - de + he)) DrawGlue (return ())+ else+ return ()+ + strokeBox a@(Text style t w) x y = do+ let de = boxDescent a+ he = boxHeight a+ y' = y - he + de+ -- In word mode we have to apply a special function to the word+ -- otherwise we apply a different function to the sentence+ if (isJust . wordStyle $ style)+ then+ (fromJust . wordStyle $ style) (Rectangle x (y' - de) (x+w) (y' - de + he)) DrawWord (drawText $ drawTheTextBox OneBlock style x y' (Just t))+ else + drawText $ drawTheTextBox OneBlock style x y' (Just t)++ strokeBox (SomeHBox _ a _) x y = strokeBox a x y+ strokeBox (HGlue _ _ _) _ _ = return ()+ + -- Test is a box has same style+isSameStyle :: Style s => s + -> HBox+ -> 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 _ _ = False
+ Graphics/PDF/Typesetting/Vertical.hs view
@@ -0,0 +1,316 @@+---------------------------------------------------------+-- |+-- Copyright : (c) alpha 2006+-- License : BSD-style+--+-- Maintainer : misc@NOSPAMalpheccar.org+-- Stability : experimental+-- Portability : portable+--+-- Vertical mode+---------------------------------------------------------+-- #hide+module Graphics.PDF.Typesetting.Vertical (+ VBox(..)+ , VerState(..)+ , verticalPostProcess+ , mkVboxWithRatio+ , strokeVBoxes+ , vglue+ , defaultVerState+ , ParagraphStyle(..)+ , AnyParagraphStyle(..)+ ) 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+ }+ +defaultVerState :: ParagraphStyle s => s -> VerState +defaultVerState s = VerState { baselineskip = (12,0.17,0.0)+ , lineskip = (3.0,0.33,0.0)+ , lineskiplimit = 2+ , paraStyle = AnyParagraphStyle 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+mkVboxWithRatio r l = + let w = foldl' (\x y -> x + boxWidthWithRatio 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 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++getInterlineStyle _ _ = Nothing++-- | 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+ in+ if p <= -1000 + then+ a:addInterlineGlue settings (b:l)+ 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)++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+ + 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'+ 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''))+ 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++instance ParagraphStyle AnyParagraphStyle where+ lineWidth (AnyParagraphStyle a) = lineWidth a+ linePosition (AnyParagraphStyle a) = linePosition a+ paraStyleCode (AnyParagraphStyle a) = paraStyleCode a+ interline (AnyParagraphStyle a) = interline a+ paraChange (AnyParagraphStyle a) l = let (a',l') = paraChange a l in (AnyParagraphStyle a',l')+ paragraphStyle (AnyParagraphStyle a) = paragraphStyle a
HPDF.cabal view
@@ -1,19 +1,21 @@ Name: HPDF-Version: 1.0+Version: 1.1 License: LGPL License-file:LICENSE Copyright: Copyright (c) 2007, alpheccar category: Graphics synopsis: Generation of PDF documents maintainer: misc@NOSPAMalpheccar.org-homepage: http://www.alpheccar.org/en/posts/show/80-build-depends: base, haskell98,mtl,encoding >= 0.1 ,zlib >= 0.3+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 ghc-options: -Wall -funbox-strict-fields -fglasgow-exts -O2 extensions: ForeignFunctionInterface, CPP-description: A PDF library allowing to generate multipage PDF documents with outlines, links ...+description: A PDF library with support for several pages, page transitions, outlines, annotations, compression, colors, shapes, patterns, jpegs, fonts, typesetting ... extra-source-files: c/ctext.h c/metrics.h+ c/conversion.h Test/AFMParser.hs Test/logo.jpg Test/Makefile@@ -22,9 +24,11 @@ README.txt C-Sources: c/metrics.c+ c/conversion.c Include-Dirs: c Install-Includes: ctext.h+ conversion.h exposed-Modules: Graphics.PDF Graphics.PDF.Colors@@ -38,7 +42,7 @@ Graphics.PDF.Annotation Graphics.PDF.Pattern Graphics.PDF.Shading- Graphics.PDF.Demo+ Graphics.PDF.Typesetting Other-Modules: Graphics.PDF.LowLevel.Types Graphics.PDF.Data.PDFTree@@ -46,3 +50,8 @@ Graphics.PDF.Resources Graphics.PDF.Draw Graphics.PDF.LowLevel.Kern+ Graphics.PDF.Typesetting.Breaking+ Graphics.PDF.Typesetting.Horizontal+ Graphics.PDF.Typesetting.Vertical+ Graphics.PDF.Typesetting.Box+ Graphics.PDF.LowLevel.Serializer
Test/Makefile view
@@ -1,8 +1,14 @@ debug:- ghc -o test -ffi -cpp -Wall -funbox-strict-fields -fglasgow-exts -O2 -hidir interfaces -odir bin -optc-I../c -i.. ../c/metrics.c --make test.hs+ ghc -o test -ffi -cpp -Wall -funbox-strict-fields -fglasgow-exts -O2 -hidir interfaces -odir bin -optc-I../c -i.. ../c/metrics.c ../c/conversion.c --make test.hs++profile:+ ghc -o test -prof -auto-all -ffi -cpp -Wall -funbox-strict-fields -fglasgow-exts -O2 -hidir interfaces -odir bin -optc-I../c -i.. ../c/metrics.c ../c/conversion.c --make test.hs+ +runprof:+ ./test +RTS -p demo:- ghc -o test --make test.hs+ ghc -o test -fglasgow-exts -O2 --make test.hs buildafm: ghc -o afm --make AFMParser.hs
Test/test.hs view
@@ -16,6 +16,7 @@ import Graphics.PDF import Penrose+import System.Random fontDebug :: PDFFont -> PDFString -> Draw ()@@ -68,9 +69,6 @@ fillAndStroke $ Ellipse 300 300 600 400 where - myDrawing = do- stroke (Line 0 0 100 100)- fill (Rectangle 100 100 200 200) pattern = do stroke (Ellipse 0 0 100 50) cpattern = do@@ -89,12 +87,12 @@ textTest = do strokeColor red fillColor blue- fontDebug (PDFFont Times_Roman 48) (toPDFString "This is a test !")+ fontDebug (PDFFont Times_Roman 48) (toPDFString "This is a test (éèçàù)!") -testImage :: PDFReference PDFPage -> PDF ()-testImage page = do- Right jpg <- createPDFJpeg "logo.jpg" +testImage :: JpegFile -> PDFReference PDFPage -> PDF ()+testImage jpgf page = do+ jpg <- createPDFJpeg jpgf drawWithPage page $ do withNewContext $ do setFillAlpha 0.4@@ -104,46 +102,326 @@ applyMatrix $ translate 200 200 applyMatrix $ scale 2 2 drawXObject jpg- -testAll :: PDF ()-testAll = do- page <- addPage Nothing+ +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+ +instance Style Bold where+ textStyle _ = TextStyle (PDFFont Times_Bold 12) black black FillText 1.0 1.0 1.0 1.0+ styleCode _ = 2 + +instance Style RedRectStyle where+ sentenceStyle _ = 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 ->+ 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 + where+ ws _ DrawGlue _ = return ()+ ws (Rectangle xa ya xb yb) DrawWord drawWord = do+ let [a,b,c,d,e,f,g,h] :: [PDFFloat] = map (\x -> x / 16.0) . map fromIntegral . take 8 $ l+ --angle = head angl+ p = Polygon [ (xa-a,ya+b)+ , (xb+c,ya+d)+ , (xb+e,yb-f)+ , (xa-g,yb-h)+ , (xa-a,ya+b)+ ]+ strokeColor red+ stroke p+ fillColor $ Rgb 0.8 1.0 0.8+ fill p+ withNewContext $ do+ --applyMatrix . rotate . Degree $ angle+ drawWord+ return ()++instance ParagraphStyle Normal where+ paraStyleCode _ = 1+ +data CirclePara = CirclePara deriving(Eq)+data BluePara = BluePara PDFFloat deriving(Eq)++instance ParagraphStyle BluePara where+ paraStyleCode _ = 3+ lineWidth (BluePara a) w nb = (if nb > 3 then w else w-a) - 20.0+ linePosition (BluePara a) _ nb = (if nb > 3 then 0.0 else a) + 10.0+ interline _ = 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) = + let f = PDFFont Helvetica_Bold 45+ w' = charWidth f c + charRect = Rectangle 0 (- getDescent f) w' (getHeight f - getDescent f)+ c' = mkLetter (0,0,0) Nothing . mkDrawBox $ do+ withNewContext $ do+ applyMatrix $ translate (-w') (getDescent f - getHeight f + styleHeight st - styleDescent st)+ fillColor $ Rgb 0.6 0.6 1+ strokeColor $ Rgb 0.6 0.6 1+ fillAndStroke $ charRect+ fillColor black+ drawText $ do+ renderMode AddToClip+ textStart 0 0+ setFont f+ displayText (toPDFString [c])+ 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+ let f = Rectangle (xa-3) (ya-3) (xb+3) (yb+3)+ fillColor $ Rgb 0.6 0.6 1+ fill f+ b+ 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+ +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)+ -- ]+ debugText = do+ paragraph $ do+ txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor "+ setStyle Bold+ txt $ "incididunt ut labore et dolore magna aliqua. "+ setStyle Normal+ txt $ "Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure "+ setStyle RedRectStyle+ txt $ "dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. "+ setStyle Normal+ glue 3 0 0+ paragraph $ do+ txt $ "Excepteur sint occaecat cupidatat non"+ txt $ " proident, sunt in culpa qui officia deserunt mollit anim id est laborum."+ setStyle superCrazy+ txt $ " And now, a super crazy style to test the code. "+ setStyle Normal+ txt $ "Return to a normal style :-)"+ glue 3 0 0+ paragraph $ do+ txt $ "More crazy styles ... "+ setStyle Crazy+ par+ setStyle Normal+ 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 = 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 "+ 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."+ myText = do+ -- Duplicate paragraph several times+ paragraph normalPar+ glue 3 0 0+ setStyle BlueStyle+ setParaStyle (BluePara 0)+ setFirstPassTolerance 5000+ setSecondPassTolerance 10000+ unstyledGlue 3 0 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 "+ --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+ setFirstPassTolerance 100+ setSecondPassTolerance 200+ setStyle Normal+ setParaStyle Normal+ glue 3 0 0+ paragraph normalPar+ glue 3 0 0+ paragraph normalPar+ --textStart = 300 - getHeight f + getDescent f+ maxw = 400+ drawWithPage page $ do+ --strokeColor red+ --setWidth 0.5+ --stroke $ Rectangle 10 0 (10+maxw) 300+ --stroke $ Line 10 textStart (10+maxw) textStart+ strokeColor black+ case test of+ 1 -> do+ strokeColor red+ stroke $ Line 10 300 (10+maxw) 300+ displayFormattedText (Rectangle 10 0 (10+maxw) 300) Normal Normal myText+ 2 -> do+ strokeColor red+ stroke $ Line 10 300 (10+maxw) 300+ displayFormattedText (Rectangle 10 0 (10+maxw) 300) Normal 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+ 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+ + +testAll :: JpegFile -> PDF ()+testAll jpg = do+ page1 <- addPage Nothing+ newSection (toPDFString "Typesetting") Nothing Nothing $ do+ newSection (toPDFString "Normal text") Nothing Nothing $ do+ typesetTest 1 page1+ + 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+ + page4 <- addPage Nothing newSection (toPDFString "Shapes") Nothing Nothing $ do newSection (toPDFString "Geometry") Nothing Nothing $ do- drawWithPage page $ do+ drawWithPage page4 $ do geometryTest - page <- addPage Nothing+ page5 <- addPage Nothing newSection (toPDFString "Line style") Nothing Nothing $ do- drawWithPage page $ do+ drawWithPage page5 $ do lineStyle- page <- addPage Nothing+ + page6 <- addPage Nothing newSection (toPDFString "Object reuse") Nothing Nothing $ do r <- createPDFXForm 0 0 200 200 lineStyle- drawWithPage page $ do+ drawWithPage page6 $ do drawXObject r - page <- addPage Nothing- newSectionWithPage (toPDFString "Painting") Nothing Nothing page $ do+ page7 <- addPage Nothing+ newSectionWithPage (toPDFString "Painting") Nothing Nothing page7 $ do newSection (toPDFString "Patterns") Nothing Nothing $ do- patternTest page- page <- addPage Nothing+ patternTest page7+ + page8 <- addPage Nothing newSection (toPDFString "Shading") Nothing Nothing $ do- drawWithPage page $ do+ drawWithPage page8 $ do shadingTest- page <- addPage Nothing+ + page9 <- addPage Nothing newSection (toPDFString "Media") Nothing Nothing $ do newSection (toPDFString "image") Nothing Nothing $ do - testImage page + testImage jpg page9 - page <- addPage Nothing+ page10 <- addPage Nothing newSection (toPDFString "Annotations") Nothing Nothing $ do- drawWithPage page $ do+ drawWithPage page10 $ do testAnnotation - page <- addPage Nothing- newSection (toPDFString "Text") Nothing Nothing $ do- drawWithPage page $ do+ + page11 <- addPage Nothing+ newSection (toPDFString "Text encoding") Nothing Nothing $ do+ drawWithPage page11 $ do textTest newSection (toPDFString "Fun") Nothing Nothing $ do penrose@@ -153,6 +431,7 @@ main :: IO() main = do let rect = PDFRect 0 0 600 400- runPdf "demo.pdf" (standardDocInfo { author=toPDFString $ "alpheccar"}) rect $ do- testAll+ Right jpg <- readJpegFile "logo.jpg" + runPdf "demo.pdf" (standardDocInfo { author=toPDFString "alpheccar", compressed = True}) rect $ do+ testAll jpg
+ c/conversion.c view
@@ -0,0 +1,17 @@+#include <stdlib.h>+#include <stdio.h>+#include <string.h>+#include "conversion.h"+++short c_floatToString(double f,char* s)+{+ sprintf(s,"%.5f",f);+ return(strlen(s));+}++short c_shortToString(short d,char* s)+{+ sprintf(s,"%d",d);+ return(strlen(s));+}
+ c/conversion.h view
@@ -0,0 +1,5 @@+#ifndef _CONVERSION_H_+#define _CONVERSION_H_+extern short c_floatToString(double f,char* s);+extern short c_shortToString(short d,char* s);+#endif
c/ctext.h view
@@ -1,6 +1,6 @@ #ifndef _CTEXT_H_ #define _CTEXT_H_-extern short c_getAdvance(unsigned short,unsigned char);+extern short c_getAdvance(unsigned short,short); extern short c_getLeading(unsigned short); extern short c_getDescent(unsigned short); extern int c_hasKern(unsigned short);
c/metrics.c view
@@ -5,9 +5,11 @@ #define GFONTSIZE (255-32+1) #define FFONTSIZE (5) -short c_getAdvance(unsigned short font,unsigned char c)+short c_getAdvance(unsigned short font,short c) { if (c<32)+ return(0);+ if (c-32 >= GFONTSIZE) return(0); return(gmetric[font*GFONTSIZE+c-32]); }