HPDF (empty) → 0.3
raw patch · 11 files changed
+968/−0 lines, 11 filesdep +basedep +haskell98dep +mtlbuild-type:Customsetup-changed
Dependencies added: base, haskell98, mtl, regex-compat
Files
- Graphics/PDF.hs +66/−0
- Graphics/PDF/Color.hs +60/−0
- Graphics/PDF/File.hs +174/−0
- Graphics/PDF/Font.hs +61/−0
- Graphics/PDF/Geometry.hs +71/−0
- Graphics/PDF/LowLevel.hs +308/−0
- Graphics/PDF/Shading.hs +80/−0
- Graphics/PDF/Shape.hs +75/−0
- Graphics/PDF/Text.hs +50/−0
- HPDF.cabal +20/−0
- Setup.hs +3/−0
+ Graphics/PDF.hs view
@@ -0,0 +1,66 @@+---------------------------------------------------------+-- |+-- Copyright : (c) alpha 2006+-- License : BSD-style+--+-- Maintainer : misc@NOSPAMalpheccar.org+-- Stability : experimental+-- Portability : portable+--+-- PDF API for Haskell+---------------------------------------------------------+module Graphics.PDF+ (-- * HPDF+ -- ** The PDF type+ PDF+ -- ** PDF Operator used to build a PDF document (in addition to the Monoid ones)+ ,withContext, (<>), emptyPdf, PdfCmd+ -- ** PDF Transformations+ , module Graphics.PDF.Geometry+ -- ** PDF Text+ , module Graphics.PDF.Text+ -- ** PDF Shapes+ , module Graphics.PDF.Shape+ -- ** PDF Colors+ , module Graphics.PDF.Color+ -- ** PDF Shadings+ , module Graphics.PDF.Shading+ -- ** PDF Font+ , module Graphics.PDF.Font+ -- ** PDF File+ , module Graphics.PDF.File+ -- * Example+ -- $example+ ) where+ ++import Graphics.PDF.LowLevel+import Graphics.PDF.Geometry+import Graphics.PDF.Shape+import Graphics.PDF.Color+import Graphics.PDF.Shading+import Graphics.PDF.File+import Graphics.PDF.Text+import Graphics.PDF.Font+++-- $example+-- > test :: IO ()+-- > test = let document = rgbSpace <>+-- > chooseFont Helvetica 70 <> +-- > applyMatrix (translate 50 0) <>+-- > applyMatrix (rotate (Degree 45)) <>+-- > clipText 0 0 "HPDF" <> +-- > applyMatrix (rotate (Degree (-45))) <>+-- > applyMatrix (translate (-50) 0) <>+-- > fillColor (Rgb 0 0 1) <>+-- > fillRectangle 0 0 100 100 <>+-- > fillColor (Rgb 1 0 0) <>+-- > setAlpha 0.4 <>+-- > fillRectangle 50 50 100 100 <>+-- > resetAlpha <>+-- > fillColor (Rgb 0 1 0) <>+-- > fillRectangle 80 80 100 100 <>+-- > emptyPdf 180 180+-- > in+-- > writePdf "test.pdf" document
+ Graphics/PDF/Color.hs view
@@ -0,0 +1,60 @@+-- | Functions used to control the colors in a PDF document++module Graphics.PDF.Color + (-- * Colors+ -- ** Data types+ Color(..)+ -- ** Operators+ , strokeColor,fillColor,rgbSpace, setAlpha,resetAlpha+ )+ where+ +import Graphics.PDF.LowLevel+import Text.Printf+ +-- | Color data type+data Color = Rgb Float Float Float -- ^ RGB Color++instance Show Color where+ show (Rgb r g b) = "rgb" ++ (show r) ++ (show g) ++ (show b)++-- | Create a new state dictionary for an alpha value +newState :: Float -> PdfObject+newState a = pdfDictionary [("Type",PdfName "ExtGState"),+ ("CA",PdfFloat a),+ ("ca",PdfFloat a)+ ]+ ++ +-- | Change the stroke color in a PDF document +strokeColor :: Color -> PdfCmd+strokeColor c = case c of+ Rgb r g b -> (PdfSC r g b,[])+ + + +-- | Change the fill color in a PDF document +fillColor :: Color -> PdfCmd+fillColor c = case c of+ Rgb r g b -> (PdfSF r g b,[])+ + +-- | Change the alpha setting for transparency in the document +setAlpha :: Float -> PdfCmd+setAlpha a = (PdfAlpha dictName,[(PdfState,dictName,PdfUnknownPointer dictName),+ (PdfAnyObject,dictName,newState a)]) + where+ dictName = printf "alpha%f" a+ ++ +-- | Reset alpha value to opaque for stroke and fill colors +resetAlpha :: PdfCmd+resetAlpha = (PdfResetAlpha,[])+ +-- | Set color space to RGB. Must always be used before starting to use any color. +rgbSpace :: PdfCmd+rgbSpace = (PdfRgbSpace,[])++
+ Graphics/PDF/File.hs view
@@ -0,0 +1,174 @@+module Graphics.PDF.File+ (-- * PDF generation+ writePdf+ ) where+ +import System.IO+import Control.Monad+import Control.Monad.State+import Graphics.PDF.LowLevel+import Text.Printf+import qualified Data.Map as Map+import Data.List+import System.Mem++-- writeSome text and increment the size counter+writeText :: Handle -> String -> StateT (Int,String) IO ()+writeText f text = do (s,t) <- get+ put (s + (length text),t)+ lift $ hPutStr f (seq s text)+ + +writeStream :: Handle -> [Cmd] -> StateT (Int,String) IO () +writeStream f c = mapM_ (drawAction f) c++drawAction :: Handle -> Cmd -> StateT (Int,String) IO () +drawAction f (PdfQ actions) = do writeText f "\nq"+ writeStream f actions+ writeText f "\nQ"+ + +drawAction f action = writeText f (show action)++class PdfWrite a where + writePdfObject :: Handle -> a -> Int -> StateT (Int,String) IO Int+ +instance PdfWrite PdfDictionary where+ writePdfObject f (PdfDictionary d) k = do writeText f "<<\n" + Map.foldWithKey item (return ()) d+ writeText f ">>" + return 0+ where+ item key itm m = do m+ writeText f ("/" ++ key ++ " " )+ writePdfObject f itm k+ writeText f "\n"++instance PdfWrite PdfObject where+ writePdfObject f (PdfInt a) k = do writeText f (show a) + return 0+ writePdfObject f (PdfFloat a) k = do writeText f (show a) + return 0+ writePdfObject f (PdfUnknownPointer s) k = error ("The object " ++ s ++ " has not been found or defined")+ writePdfObject f (PdfPointer a) k = do writeText f $ (show a) ++ " 0 R"+ return 0+ writePdfObject f (PdfString a) k = do writeText f $ "(" ++ a ++ ")"+ return 0+ writePdfObject f (PdfBool a) k = if a then do writeText f $ "true"+ return 0+ else do writeText f $ "false"+ return 0+ writePdfObject f (PdfName a) k = do writeText f $ "/" ++ a+ return 0+ writePdfObject f (PdfDict d) k | pdfDictionaryEmpty d = do writeText f "<< >>" + return 0+ | otherwise = do writePdfObject f d k+ return 0+ writePdfObject f (PdfArray []) k = do writeText f "[]" + return 0 + writePdfObject f (PdfArray l) k = do writeText f "["+ mapM_ (\x -> writePdfObject f x k >> writeText f " ") $ l + writeText f " ]"+ return 0+ + writePdfObject f (PdfStream c) k = do writeText f "<<\n"+ writeText f ("/Length " ++ (show (k+1)) ++ " 0 R")+ writeText f "\n>>\n"+ writeText f "stream"+ (before,_) <- get+ writeStream f (stream c)+ (after,_) <- get+ writeText f "\nendstream"+ return (after-before)+ where+ stream (Content(s)) = s+ + ++resources = pdfDictionary [("ExtGState",PdfUnknownPointer "ExtGState"),+ ("XObject",PdfUnknownPointer "XObject"),+ ("Font",PdfUnknownPointer "Font"),+ ("Pattern",PdfUnknownPointer "Pattern"),+ ("Shading",PdfUnknownPointer "Shading"),+ ("ProcSet",PdfUnknownPointer "ProcSet")+ ]+header = "%PDF-1.4\n"+obj1 = pdfDictionary [("Type", PdfName "Catalog"),+ ("Outlines",PdfUnknownPointer "Obj2"),+ ("Pages",PdfUnknownPointer "Obj3")+ ]+obj2 = pdfDictionary [("Type",PdfName "Outlines"),+ ("Count", PdfInt 0)+ ]+obj3 = pdfDictionary [("Type", PdfName "Pages"),+ ("Kids",PdfArray [PdfUnknownPointer "Obj4"]),+ ("Count",PdfInt 1)+ ]+obj4 pdf = pdfDictionary [("Type",PdfName "Page"),+ ("Parent",PdfUnknownPointer "Obj3"),+ ("MediaBox",PdfArray [PdfInt 0,PdfInt 0,PdfInt (round (x pdf)),PdfInt (round (y pdf))]),+ ("Contents",PdfUnknownPointer "Main"),+ ("Resources",resources)+ ]+obj6 = PdfArray [PdfName "PDF"]+beginxref nb = ("xref\n" ++ printf "0 %d\n" (nb+1))+trailer np = ("trailer\n" +++ (printf " << /Size %d\n" ((nbObjects np)+1)) +++ (printf " /Root %d 0 R\n" (objectIndex "Obj1" np) ) +++ " >>\n\+ \startxref\n")+eof = "%%EOF"++ +standardAlpha = pdfDictionary [("Type",PdfName "ExtGState"),+ ("ca",PdfFloat 1.0),+ ("CA",PdfFloat 1.0)+ ]+ +-- write and object, increment the size counter and the object number+writeObj f k o maxnb = do (s,t) <- get+ put (s,t ++ printf "%010d 00000 n \n" (s::Int) )+ writeText f (printf "%d 0 obj\n" k)+ len <- writePdfObject f o maxnb+ writeText f ("\nendobj\n\n")+ return len+ + -- Write the xref table+writeXref f p = do (_,t) <- get+ writeText f (beginxref (nbObjects p))+ writeText f t+ writeText f ("\n")+ -- write all pending objects+writeObjects f thepdf = do len <- foldM write 0 (allObjects thepdf)+ return len+ where+ write old (k,s) = do len <- writeObj f k s maxnb+ return(len+old)+ maxnb = nbObjects thepdf+ +-- Write the PDF document to file+writePdf :: String -> PDF -> IO ()+writePdf fileName pdf = + -- New pdf with object describing a one page PDF+ let newpdf = computeObjectPos .+ addObject "Obj1" obj1 .+ addObject "Obj2" obj2 .+ addObject "Obj3" obj3 .+ addObject "Obj4" (obj4 pdf) .+ addObject "ProcSet" obj6 .+ addState "standardAlpha" standardAlpha $ pdf+ in+ do f <- lift $ openBinaryFile fileName WriteMode+ writeText f header+ len <- writeObjects f newpdf+ writeEndPdf f len (addObject "ZZZ" (PdfInt len) newpdf)+ `evalStateT` (0,"0000000000 65535 f \n")+ where+ writeEndPdf f len epdf = do writeObj f (nbObjects epdf) (PdfInt len) (nbObjects epdf)+ (xrefStart,_) <- get+ writeXref f epdf+ writeText f (trailer epdf)+ writeText f (printf "%d\n" (xrefStart::Int))+ writeText f eof+ lift $ hClose f+
+ Graphics/PDF/Font.hs view
@@ -0,0 +1,61 @@+-- | Function used to control the fonts in a PDF document++module Graphics.PDF.Font+ (-- * Font+ -- * Font type+ Font(..)+ -- ** Font selection+ ,chooseFont+ )+ where+ +import Graphics.PDF.LowLevel+++-- | List of supported fonts+data Font = TimesRoman+ | TimesBold+ | TimesItalic+ | Helvetica+ | HelveticaBold+ | HelveticaOblique+ | HelveticaBoldOblique+ | Courier+ | CourierBold+ | CourierOblique+ | CourierBoldOblique+ | Symbol+ | ZapfDingbats+ +instance Show Font where+ show TimesRoman = "Times-Roman"+ show TimesBold = "Times-Bold"+ show TimesItalic = "Times-Italic"+ show Helvetica = "Helvetica"+ show HelveticaBold = "Helvetica-Bold"+ show HelveticaOblique = "Helvetica-Oblique"+ show HelveticaBoldOblique = "Helvetica-BoldOblique"+ show Courier = "Courier"+ show CourierBold = "Courier-Bold"+ show CourierOblique = "Courier-Oblique"+ show CourierBoldOblique = "Courier-BoldOblique"+ show Symbol = "Symbol"+ show ZapfDingbats = "ZapfDingbats"+ +type Size = Int++-- | Create a new font dictionary+newFont :: String -> PdfObject+newFont name= pdfDictionary [("Type",PdfName "FontDescriptor"),+ ("Subtype",PdfName "Type1"),+ ("BaseFont",PdfName name)+ ]++-- | Select new font in the document +chooseFont :: Font -> Size -> PdfCmd+chooseFont font fontSize = (PdfBT fontName fontSize,[(PdfFont,fontName,PdfUnknownPointer fontName),+ (PdfAnyObject, fontName, newFont fontName)+ ]) + where+ fontName = show font+
+ Graphics/PDF/Geometry.hs view
@@ -0,0 +1,71 @@+-- | Transformations of a PDF document++module Graphics.PDF.Geometry + (-- * Geometry+ -- ** Units+ Angle(..)+ -- ** Data types+ , Matrix+ -- ** Transformations+ , rotate, translate, scale, applyMatrix, identity+ )+ where+ +import Graphics.PDF.LowLevel+++-- | Angle +data Angle = Degree Float -- ^ Angle in degrees+ | Radian Float -- ^ Angle in radians++-- | A transformation matrix (affine transformation) +newtype Matrix = Matrix(Float,Float,Float,Float,Float,Float) deriving (Eq)++-- | Identity matrix+identity :: Matrix+identity = Matrix(1.0,0,0,1.0,0,0)++instance Show Matrix where+ show (Matrix(ma,mb,mc,md,me,mf)) = "Matrix " ++ (unwords [(show ma),(show mb),(show mc),(show md),(show me),(show mf)])+ +instance Num Matrix where+ -- Matrix addition+ (+) (Matrix(ma,mb,mc,md,me,mf)) (Matrix(na,nb,nc,nd,ne,nf)) = + Matrix( (ma+na), (mb+nb), (mc+nc), (md+nd), (me+ne), (mf+nf)) + -- Matrix multiplication+ -- ma mb 0 na nb 0+ -- mc md 0 nc nd 0+ -- me mf 1 ne nf 1+ (*) (Matrix(ma,mb,mc,md,me,mf)) (Matrix(na,nb,nc,nd,ne,nf)) = + Matrix( (ma*na+mb*nc), (ma*nb + mb*nd ), (mc*na+md*nc), (mc*nb +md*nd), (me*na+mf*nc+ne), (me*nb+mf*nd+nf)) + negate (Matrix(ma,mb,mc,md,me,mf)) =+ Matrix( (-ma), (-mb), (-mc), (-md), (-me), (-mf))+ abs m = m+ signum _ = identity+ fromInteger i = Matrix(r,0,0,r, 0, 0)+ where+ r = fromInteger i+++-- | Apply a transformation matrix to the current coordinate frame+applyMatrix :: Matrix -> PdfCmd+applyMatrix (Matrix(a,b,c,d,e,f)) = (PdfCM a b c d e f,[])++-- | Rotation matrix+rotate :: Angle -> Matrix+rotate r = Matrix ((cos(radian)), (sin(radian)), (-sin(radian)) ,(cos(radian)), 0, 0)+ where+ radian = case r of+ Degree angle -> angle / 180 * pi+ Radian angle -> angle+ + +-- | Translation matrix +translate :: Float -> Float -> Matrix+translate tx ty = Matrix( 1, 0, 0, 1 ,tx ,ty)+ ++-- | Scaling matrix +scale :: Float -> Float -> Matrix+scale sx sy = Matrix (sx, 0, 0, sy, 0 ,0 )+
+ Graphics/PDF/LowLevel.hs view
@@ -0,0 +1,308 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-- #hide+module Graphics.PDF.LowLevel+ (-- * PDF low level operators+ -- ** Data types+ PdfObject(..),PdfDictionary(..),PDF(..),Content(..),PdfCmd,CreatedObject,ObjectKind(..), Cmd(..), PdfString(..),TextRendering(..)+ -- ** Data type support functions+ ,dictionaryExtract, pdfDictionaryEmpty, emptyDictionary, emptyPdf+ -- ** Low level object operators+ ,nbObjects, objectIndex, allObjects,pdfDictionary+ -- ** Low level PDF operators+ ,addObject, addFont, addState, addNewContent, applyCommand,computeObjectPos,(<>),withContext+ ) where+ +import qualified Data.Map as Map+import Data.Monoid+import Text.Printf+import Text.Show++-- | A PDF string+newtype PdfString = S String++data TextRendering = TextStroke + | TextFill+ | TextFillStroke+ | TextClip++data Cmd = PdfRgbSpace+ | PdfSC Float Float Float+ | PdfSF Float Float Float+ | PdfBT String Int+ | PdfCM Float Float Float Float Float Float + | PdfL Float Float Float Float+ | PdfW Float+ | PdfRect Float Float Float Float+ | PdfFillRect Float Float Float Float+ | PdfDash [Float] Float+ | PdfStartPath Float Float+ | PdfAddLineToPath Float Float+ | PdfAddRectangleToPath Float Float Float Float+ | PdfText TextRendering Float Float [PdfString]+ | PdfStroke+ | PdfFill+ | PdfClip+ | PdfFillAndStroke+ | PdfClosePath+ | PdfAlpha String+ | PdfQ [Cmd] + | PdfResetAlpha+ | PdfCharSpacing Float+ | PdfWordSpacing Float+ | PdfLeading Float+ | PdfStrokePattern String+ | PdfFillPattern String+ | PdfNone+ +-- | Escape character whose meaning is special in a PDF String+instance Show PdfString where+ show (S a) = "("++a++")"+ showList l = \s -> r ++ s+ where+ r = case l of+ [] -> ""+ (a:l) -> (show a) ++ " Tj " ++ concat (zipWith (++) (map show l) (repeat " ' "))+ +instance Show Cmd where+ show (PdfQ l) = error "Require a special processing"+ show PdfNone = ""+ show PdfClip = "\nW"+ show PdfResetAlpha = "\n/standardAlpha gs"+ show (PdfAlpha s) = printf "\n/%s gs" s+ show (PdfStrokePattern s) = printf "\n/Pattern CS /%s SCN" s+ show (PdfFillPattern s) = printf "\n/Pattern cs /%s scn" s+ show PdfRgbSpace = "\n/DeviceRGB CS\n/DeviceRGB cs\n/standardAlpha gs"+ show (PdfSC r g b) = printf "\n%f %f %f SC" r g b+ show (PdfSF r g b) = printf "\n%f %f %f sc" r g b+ show (PdfBT fontName fontSize) = printf "\nBT /%s %d Tf ET" fontName fontSize+ show (PdfCM a b c d e f) = printf "\n%f %f %f %f %f %f cm" a b c d e f+ show (PdfL xa ya xb yb) = printf "\nh %f %f m %f %f l S" xa ya xb yb+ show (PdfW w) = printf "\n%f w" w+ show (PdfRect xa ya width height) = printf "\nh %f %f %f %f re S" xa ya width height+ show (PdfFillRect xa ya width height) = printf "\nh %f %f %f %f re f" xa ya width height+ show (PdfDash a phase) = printf "\n[%s] %f d" (unwords . map show $ a) phase+ show (PdfStartPath xa ya) = printf "\nh %f %f m" xa ya+ show (PdfClosePath) = "\nh"+ show (PdfAddLineToPath xa ya) = printf "\n%f %f l" xa ya+ show (PdfAddRectangleToPath xa ya width height) = printf "\n%f %f %f %f re" xa ya width height+ show PdfStroke = "\nS"+ show PdfFill = "\nf"+ show PdfFillAndStroke = "\nB"+ show (PdfText TextStroke px py s) = printf "\n1 Tr BT %f %f Td %s ET" px py (show s)+ show (PdfText TextFill px py s) = printf "\n0 Tr BT %f %f Td %s ET" px py (show s)+ show (PdfText TextFillStroke px py s) = printf "\n2 Tr BT %f %f Td %s ET" px py (show s)+ show (PdfText TextClip px py s) = printf "\n7 Tr BT %f %f Td %s ET" px py (show s)+ show (PdfCharSpacing x) = printf "\n%f Tc" x+ show (PdfWordSpacing x) = printf "\n%f Tw" x+ show (PdfLeading x) = printf "\n%f TL" x+ +-- | PDF commands for a picture+newtype Content = Content ([Cmd])++instance Monoid Content where+ mempty = Content ([])+ mappend (Content(ca)) (Content(cb)) = Content(ca ++ cb)+ +-- | A PDF object as defined in PDF specification+data PdfObject = PdfInt Int + | PdfFloat Float + | PdfString String + | PdfName String + | PdfDict PdfDictionary + | PdfUnknownPointer String + | PdfPointer Int + | PdfBool Bool+ | PdfArray [PdfObject]+ | PdfStream Content+ +-- | A dictionary of objects+newtype PdfDictionary = PdfDictionary (Map.Map String PdfObject)++dictionaryExtract :: PdfDictionary -> Map.Map String PdfObject+dictionaryExtract (PdfDictionary a) = a++-- | Kind of created object+data ObjectKind = PdfAnyObject | PdfFont | PdfState | PdfShading | PdfPatternObject++-- | Object created by a command+type CreatedObject = (ObjectKind,String,PdfObject)++-- | Type returned by a PDF command creator+type PdfCmd = (Cmd,[CreatedObject])++-- | Number of objects in the PDF+nbObjects :: PDF -> Int+nbObjects p = let PdfDictionary d = (objects p) + in+ Map.size d+ + + +-- | Object index in the PDF +objectIndex :: String -> PDF -> Int+objectIndex s p = let PdfDictionary d = (objects p) + in+ (Map.findIndex s d) + 1++-- | List of object contents with their index+allObjects :: PDF -> [(Int,PdfObject)]+allObjects p = let d = dictionaryExtract (objects p)+ in+ map createItem . Map.toAscList $ d+ where+ createItem (k,s) = ((objectIndex k p),s)++-- Name of PDF object containing the content+contentName :: String+contentName = "Main"++-- | PDF data with its state, xobject and font dictionary+data PDF = PDF {content :: Content,+ objects :: PdfDictionary,+ extgstate :: PdfDictionary,+ xobject :: PdfDictionary,+ font :: PdfDictionary,+ pattern :: PdfDictionary,+ shading :: PdfDictionary,+ x :: Float,+ y :: Float+ }+ ++-- | Check is a dictionary is empty+pdfDictionaryEmpty :: PdfDictionary -> Bool+pdfDictionaryEmpty (PdfDictionary m) | Map.null m = True+ | otherwise = False + +emptyDictionary :: PdfDictionary+emptyDictionary = PdfDictionary Map.empty++-- | Create a new empty document of given width and height+emptyPdf :: Float -> Float -> PDF+emptyPdf width height = PDF {+ objects = emptyDictionary,+ content = mempty, + extgstate=emptyDictionary,+ xobject=emptyDictionary,+ font=emptyDictionary,+ pattern=emptyDictionary,+ shading=emptyDictionary,+ x = width,+ y = height+ }+ +-- | Insert an object into a PdfDictionary+insertObject :: String -> PdfObject -> PdfDictionary -> PdfDictionary+insertObject name object (PdfDictionary d) = PdfDictionary (Map.insert name object d)++-- | Add an object of a PDF+addObject :: String -> PdfObject -> PDF -> PDF+addObject name object p = p {objects = insertObject name object (objects p)}+ +-- | Add a font object of a PDF+addFont :: String -> PdfObject -> PDF -> PDF+addFont name object p = p {font=insertObject name object (font p)}+ +-- | Add a font object of a PDF+addState :: String -> PdfObject -> PDF -> PDF+addState name object p = p {extgstate=insertObject name object (extgstate p)}++-- | Add a shading object of a PDF+addShading :: String -> PdfObject -> PDF -> PDF+addShading name object p = p {shading=insertObject name object (shading p)}++-- | Add a pattern object of a PDF+addPattern :: String -> PdfObject -> PDF -> PDF+addPattern name object p = p {pattern=insertObject name object (pattern p)}++ +-- | Add a created object +addCreatedObject :: CreatedObject -> PDF -> PDF+addCreatedObject (PdfFont,name,object) p = addFont name object p+addCreatedObject (PdfState,name,object) p = addState name object p+addCreatedObject (PdfShading,name,object) p = addShading name object p+addCreatedObject (PdfPatternObject,name,object) p = addPattern name object p+addCreatedObject (_,name,object) p = addObject name object p+ +pdfDictionary :: [(String,PdfObject)] -> PdfObject+pdfDictionary l = PdfDict (PdfDictionary(Map.fromList l))+ ++-- PDF document can be concatenated +instance Monoid PDF where+ mempty = emptyPdf 0 0+ mappend pdfa pdfb = PDF {objects = union (objects pdfa) (objects pdfb),+ content = (content pdfa) `mappend` (content pdfb),+ extgstate = union (extgstate pdfa) (extgstate pdfb),+ xobject = union (xobject pdfa) (xobject pdfb),+ font = union (font pdfa) (font pdfb),+ pattern = union (pattern pdfa) (pattern pdfb),+ shading = union (shading pdfa) (shading pdfb),+ x = max (x pdfa) (x pdfb),+ y = max (y pdfa) (y pdfb)+ } where+ union (PdfDictionary a) (PdfDictionary b) = PdfDictionary (Map.union a b)+ ++-- | Generate a new PDF with an updated content+addNewContent :: Cmd -> PDF -> PDF+addNewContent s p = p {content = Content(s : c)} + where+ Content(c) = content p+ +-- | Generate a new PDF with an updated content+replaceContent :: Content -> PDF -> PDF+replaceContent s p = p {content = s}+ +-- | Create a new PDF graphic where the graphic context is saved\/restored and thus isolated+-- from additional modifications that could be applied to this PDF document+withContext :: PDF -> PdfCmd+withContext f = (PdfQ l,newobjs)+ where+ Content(l) = content f + newobjs = listOfObjects PdfState (extgstate f) ++ listOfObjects PdfFont (font f)+ listOfObjects s d = map tag (Map.toList (dictionaryExtract d))+ where+ tag (n,o) = (s,n,o)++--addNewContent "\nq" (f `mappend` (addNewContent "\nQ" mempty))++ ++-- | add a PDF command to the current PDF content +applyCommand :: Cmd -> PDF -> PDF+applyCommand cmd p = addNewContent cmd p++-- | Update the pointer value of the PDF dictionary given element of list objects.+-- The specific dictionary extgstate, xobject and font are merged with the generic dictionary+computeObjectPos :: PDF -> PDF+computeObjectPos p = p {content = mempty,+ objects = renumber newobjects,+ extgstate= emptyDictionary,+ xobject= emptyDictionary,+ font= emptyDictionary,+ pattern= emptyDictionary,+ shading= emptyDictionary+ } + where+ newobjects = foldl insertObjs (objects p) [(contentName,(PdfStream (content p))),+ ("ExtGState",PdfDict (extgstate p)),+ ("XObject",PdfDict (xobject p)),+ ("Font",PdfDict (font p)),+ ("Pattern",PdfDict (pattern p)),+ ("Shading",PdfDict (shading p))+ ]+ insertObjs dict (s,o) = insertObject s o dict+ renumber (PdfDictionary objs) = PdfDictionary(Map.map (setNumber objs) objs) + setNumber objs (PdfUnknownPointer s) = PdfPointer ((Map.findIndex s objs)+1)+ setNumber objs (PdfDict (PdfDictionary d)) = PdfDict . PdfDictionary . Map.map (setNumber objs) $ d+ setNumber objs (PdfArray l) = PdfArray . map (setNumber objs) $ l+ setNumber _ a = a+ +infixr 9 <>+-- | Combine two PDF actions+(<>) :: PdfCmd -> PDF -> PDF+(<>) (c,l) p = addNewContent c (foldr addCreatedObject p l)+ ++
+ Graphics/PDF/Shading.hs view
@@ -0,0 +1,80 @@+-- | Function used to create shading patterns +module Graphics.PDF.Shading + (-- * Shading + -- ** Data types + Shading(..) + -- ** Operators + , createShading, strokeShading, fillShading + ) + where + +import Graphics.PDF.LowLevel +import Text.Printf +import Graphics.PDF.Color + +-- | Axial or radial shading +data Shading = Axial Color Color Float Float Float Float -- ^ Axial shading with start end color and the start and ending points + | Radial Color Color Float Float Float Float Float Float -- ^ Radial shading with start and end color, center and radius of start and end circle + +instance Show Shading where + show (Axial a b x0 y0 x1 y1) = printf "axial%s%s%f%f%f%f" (show a) (show b) x0 y0 x1 y1 + show (Radial a b x0 y0 r0 x1 y1 r1) = printf "axial%s%s%f%f%f%f%f%f" (show a) (show b) x0 y0 r0 x1 y1 r1 + +-- | Interpolation function +interpole :: Int -> Float -> Float -> PdfObject +interpole n x y = pdfDictionary [ + ("FunctionType", PdfInt 2), + ("Domain", PdfArray [PdfFloat 0,PdfFloat 1]), + ("C0", PdfArray [PdfFloat x]), + ("C1", PdfArray [PdfFloat y]), + ("N", PdfInt n) + ] + +-- | Create a shading dictionary +createShadingObject :: Shading -> CreatedObject +createShadingObject a@(Axial (Rgb ra ga ba) (Rgb rb gb bb) x0 y0 x1 y1) = (PdfAnyObject,(show a),pdfDictionary [("Type",PdfName "Shading"), + ("ShadingType",PdfInt 2), + ("ColorSpace",PdfName "DeviceRGB"), + ("Coords",PdfArray (map PdfFloat [x0,y0,x1,y1])), + ("Function",PdfArray [interpole 1 ra rb,interpole 1 ga gb,interpole 1 ba bb]) + ] + ) +createShadingObject a@(Radial (Rgb ra ga ba) (Rgb rb gb bb) x0 y0 r0 x1 y1 r1) = (PdfAnyObject,(show a),pdfDictionary [("Type",PdfName "Shading"), + ("ShadingType",PdfInt 3), + ("ColorSpace",PdfName "DeviceRGB"), + ("Coords",PdfArray (map PdfFloat [x0,y0,r0,x1,y1,r1])), + ("Function",PdfArray [interpole 1 ra rb,interpole 1 ga gb,interpole 1 ba bb]) + ] + ) +createShadingObject _ = error "Shading object only with RGB colors" + +-- Name of a pattern +patternName :: Shading -> String +patternName s = "pattern" ++ (show s) + +-- | Create a new shading made of several dictionaries +newPattern :: Shading -> [CreatedObject] +newPattern a = [(PdfAnyObject,patternName a,pdfDictionary [("Type",PdfName "Pattern"), + ("PatternType",PdfInt 2), + ("Shading",PdfUnknownPointer (show a)) + ] + ), + createShadingObject a, + (PdfPatternObject,patternName a, PdfUnknownPointer (patternName a)), + (PdfShading,show a, PdfUnknownPointer (show a)) + ] + +-- | Create a new kind of shading +createShading :: Shading -> PdfCmd +createShading s = (PdfNone,newPattern s) + + +-- | Select a shading for stroking (it must have been created before) +strokeShading :: Shading -> PdfCmd +strokeShading s = (PdfStrokePattern (patternName s),[]) + +-- | Select a shading for filling (it must have been created before) +fillShading :: Shading -> PdfCmd +fillShading s = (PdfFillPattern (patternName s),[]) + +
+ Graphics/PDF/Shape.hs view
@@ -0,0 +1,75 @@+-- | Functions used to add shapes to a PDF documents++module Graphics.PDF.Shape + (-- * Shapes+ -- ** Drawing operators+ line, rectangle, fillRectangle+ -- ** Path operators+ ,startPathAt,closePath,addLineToPath,addRectangleToPath,strokePath,fillPath, fillAndStrokePath, clipPath+ -- ** Shape settings+ , lineWidth, dashPattern+ )+ where+ +import Graphics.PDF.LowLevel++-- | Add a line to a PDF document +line :: Float -> Float -> Float -> Float -> PdfCmd+line xa ya xb yb = (PdfL xa ya xb yb,[])+ ++-- | Change the line width used in a PDF document +lineWidth :: Float -> PdfCmd+lineWidth w = (PdfW w,[])+ +-- | Add a rectangle to the PDF+rectangle :: Float -> Float -> Float -> Float -> PdfCmd+rectangle xa ya width height = (PdfRect xa ya width height,[])+ + +-- | Add a filled a rectangle to the PDF+fillRectangle :: Float -> Float -> Float -> Float -> PdfCmd+fillRectangle xa ya width height = (PdfFillRect xa ya width height,[])+ + +-- | Set the dash array and phase+dashPattern :: [Float] -> Float -> PdfCmd+dashPattern a phase = (PdfDash a phase,[])+ + +-- | Start a new path+startPathAt :: Float -> Float -> PdfCmd+startPathAt xa ya = (PdfStartPath xa ya,[])+ + +-- | Close path+closePath :: PdfCmd+closePath = (PdfClosePath,[])+ + +-- | Add a line to the current path+addLineToPath :: Float -> Float -> PdfCmd+addLineToPath xa ya = (PdfAddLineToPath xa ya,[])+ + +-- | Add a rectangle to the PDF+addRectangleToPath :: Float -> Float -> Float -> Float -> PdfCmd+addRectangleToPath xa ya width height = (PdfAddRectangleToPath xa ya width height,[])+ + +-- | Stroke path+strokePath :: PdfCmd+strokePath = (PdfStroke,[])+ +-- | Fill path+fillPath :: PdfCmd+fillPath = (PdfFill,[])+ ++-- | Fill and stroke path+fillAndStrokePath :: PdfCmd+fillAndStrokePath = (PdfFillAndStroke,[])++-- | Clip path+clipPath :: PdfCmd+clipPath = (PdfClip,[])
+ Graphics/PDF/Text.hs view
@@ -0,0 +1,50 @@+-- | Function used to draw text++module Graphics.PDF.Text+ (-- * Text + drawText, clipText,fillAndDrawText,fillText,charSpacing,wordSpacing,textLeading+ , pdfString+ )+ where+ +import Graphics.PDF.LowLevel+import Text.Regex++leftPar = mkRegex "[(]"+rightPar = mkRegex "[)]"+backslash = mkRegex "[\\]"++-- | Create a pdf string+pdfString :: String -> [PdfString]+pdfString s = map (S . escape) . lines $ s+ where+ escape s = replace rightPar "\\)" . replace leftPar "\\(" . replace backslash "\\\\\\\\" $ s+ replace reg repl s = subRegex reg s repl+ +-- | Stroke text at a given position and use the current font settings +drawText :: Float -> Float -> String -> PdfCmd+drawText px py s = (PdfText TextStroke px py (pdfString s),[])++-- | Fill and stroke text at a given position and use the current font settings +fillAndDrawText :: Float -> Float -> String -> PdfCmd+fillAndDrawText px py s = (PdfText TextFillStroke px py (pdfString s),[])++-- | Fill text at a given position and use the current font settings +fillText :: Float -> Float -> String -> PdfCmd+fillText px py s = (PdfText TextFill px py (pdfString s),[])+ +-- | Intersect clip region with text shape +clipText :: Float -> Float -> String -> PdfCmd+clipText px py s = (PdfText TextClip px py (pdfString s),[])+ +-- | Set char spacing value +charSpacing :: Float -> PdfCmd+charSpacing value = (PdfCharSpacing value,[])++-- | Set word spacing value +wordSpacing :: Float -> PdfCmd+wordSpacing value = (PdfWordSpacing value,[])++-- | Set text leading value (used for line separation when text is containing a \\n) +textLeading :: Float -> PdfCmd+textLeading value = (PdfLeading value,[])
+ HPDF.cabal view
@@ -0,0 +1,20 @@+Name: HPDF+Version: 0.3+License: LGPL+Copyright: Copyright (c) 2006, alpha+category: Graphics+synopsis: PDF API for Haskell+maintainer: misc@NOSPAMalpheccar.org+homepage: http://www.alpheccar.org+exposed-Modules: + Graphics.PDF,+ Graphics.PDF.Geometry,+ Graphics.PDF.Shape,+ Graphics.PDF.Text,+ Graphics.PDF.Font,+ Graphics.PDF.Color,+ Graphics.PDF.Shading,+ Graphics.PDF.File,+ Graphics.PDF.LowLevel+build-depends: base, haskell98,mtl,regex-compat+ghc-options: -Wall -O2
+ Setup.hs view
@@ -0,0 +1,3 @@+module Main where+import Distribution.Simple( defaultMain )+main = defaultMain