HPDF-1.0: Graphics/PDF/Draw.hs
---------------------------------------------------------
-- |
-- Copyright : (c) alpha 2006
-- License : BSD-style
--
-- Maintainer : misc@NOSPAMalpheccar.org
-- Stability : experimental
-- Portability : portable
--
-- PDF API for Haskell
---------------------------------------------------------
-- #hide
module Graphics.PDF.Draw(
-- * Draw monad
Draw(..)
, PDFStream(..)
, withNewContext
, DrawState(..)
, DrawEnvironment(..)
, supplyName
, emptyDrawing
, writeCmd
, runDrawing
, setResource
, emptyEnvironment
, PDFXForm
, PDFXObject(..)
, AnyPdfXForm
, pdfDictMember
, getBound
-- PDF types
, PDF(..)
, PDFPage(..)
, PDFPages(..)
, PdfState(..)
, PDFCatalog(..)
, Pages(..)
, PDFDocumentPageMode(..)
, PDFDocumentPageLayout(..)
, PDFViewerPreferences(..)
, PDFDocumentInfo(..)
-- ** Page transitions
, PDFTransition(..)
, PDFTransStyle(..)
, PDFTransDirection(..)
, PDFTransDimension(..)
, PDFTransDirection2(..)
-- ** Outlines
, PDFOutline(..)
, OutlineStyle(..)
, PDFOutlineEntry(..)
, Destination(..)
, Outline
, OutlineLoc(..)
, Tree(..)
, OutlineCtx(..)
, AnnotationObject(..)
, Color(..)
, hsvToRgb
, OutlineData
, AnyAnnotation(..)
, AnnotationStyle(..)
, PDFShading(..)
, getRgbColor
) 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
import Control.Monad.State
import qualified Data.Map as M
import Graphics.PDF.Resources
import qualified Data.IntMap as IM
import Graphics.PDF.Data.PDFTree(PDFTree)
import Data.Maybe
data AnnotationStyle = AnnotationStyle !(Maybe Color)
class AnnotationObject a where
addAnnotation :: a -> PDF (PDFReference a)
annotationType :: a -> PDFName
annotationContent :: a -> PDFString
annotationRect :: a -> [PDFFloat]
data AnyAnnotation = forall a.(PdfObject a,AnnotationObject a) => AnyAnnotation a
instance PdfObject AnyAnnotation where
toPDF (AnyAnnotation a) = toPDF a
instance AnnotationObject AnyAnnotation where
addAnnotation (AnyAnnotation a) = do
PDFReference r <- addAnnotation a
return (PDFReference r)
annotationType (AnyAnnotation a) = annotationType a
annotationContent (AnyAnnotation a) = annotationContent a
annotationRect (AnyAnnotation a) = annotationRect a
-- | A PDF color
data Color = Rgb !Double !Double !Double
| Hsv !Double !Double !Double
deriving(Eq,Ord)
data DrawState = DrawState {
supplyNames :: [String]
, rsrc :: PDFResource
, strokeAlphas :: M.Map StrokeAlpha String
, fillAlphas :: M.Map FillAlpha String
, theFonts :: M.Map PDFFont String
, xobjects :: M.Map (PDFReference AnyPdfXForm) String
, otherRsrcs :: PDFDictionary
, annots :: [AnyAnnotation]
, patterns :: M.Map (PDFReference AnyPdfPattern) String
, colorSpaces :: M.Map PDFColorSpace String
, shadings :: M.Map PDFShading String
}
data DrawEnvironment = DrawEnvironment {
streamId :: Int
, xobjectb :: IM.IntMap (PDFFloat,PDFFloat)
, currentp :: Maybe Int
}
emptyEnvironment :: DrawEnvironment
emptyEnvironment = DrawEnvironment 0 IM.empty Nothing
-- | The drawing monad
newtype Draw a = Draw {unDraw :: RWS DrawEnvironment B.ByteString DrawState a}
#ifndef __HADDOCK__
deriving(Monad,MonadWriter B.ByteString, MonadReader DrawEnvironment, MonadState DrawState, Functor)
#else
instance Monad Draw
instance MonadWriter B.ByteString Draw
instance MonadReader DrawEnvironment Draw
instance MonadState DrawState Draw
instance Functor Draw
#endif
instance MonadPath Draw
-- | A PDF stream object
data PDFStream = PDFStream !B.ByteString !Bool !(PDFReference PDFLength) !PDFDictionary
instance PdfObject PDFStream where
toPDF (PDFStream s c l d) =
B.concat $ [ toPDF dict
, toByteString "\nstream"
, newline
, s
, newline
, toByteString "endstream"]
where
compressedStream False = []
compressedStream True = if not (pdfDictMember (PDFName "Filter") d) then [(PDFName "Filter",AnyPdfObject $ [AnyPdfObject . PDFName $ "FlateDecode"])] else []
lenDict = PDFDictionary. M.fromList $ [ (PDFName "Length",AnyPdfObject l)] ++ compressedStream c
dict = pdfDictUnion lenDict d
-- | An empty drawing
emptyDrawing :: Draw ()
emptyDrawing = return ()
-- | 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
supplyName = do
(x:xs) <- gets supplyNames
modifyStrict $ \s -> s {supplyNames = xs}
return x
-- | 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')
-- | 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"
a <- m
writeCmd "\nQ"
return a
-- | Set a resource in the resource dictionary
setResource :: (Ord a, PdfResourceObject a) => String -- ^ Dict name
-> a -- ^ Resource value
-> M.Map a String -- ^ Old cache value
-> Draw (String,M.Map a String) -- ^ New cache value
setResource dict values oldCache = do
case M.lookup values oldCache of
Nothing -> do
newName <- supplyName
modifyStrict $ \s -> s { rsrc = addResource (PDFName dict) (PDFName newName) (toRsrc values) (rsrc s)}
return (newName,M.insert values newName oldCache)
Just n -> return (n,oldCache)
-- | A PDF Xobject which can be drawn
class PDFXObject a where
drawXObject :: PDFReference a -> Draw ()
bounds :: PDFReference a -> Draw (PDFFloat,PDFFloat)
privateDrawXObject :: PDFReference a -> Draw ()
privateDrawXObject (PDFReference r) = do
xobjectMap <- gets xobjects
(newName,newMap) <- setResource "XObject" (PDFReference r) xobjectMap
modifyStrict $ \s -> s { xobjects = newMap }
writeCmd ("\n/" ++ newName ++ " Do")
drawXObject = privateDrawXObject
bounds (PDFReference r) = getBound r
-- | An XObject
data AnyPdfXForm = forall a. (PDFXObject a,PdfObject a) => AnyPdfXForm a
instance PdfObject AnyPdfXForm where
toPDF (AnyPdfXForm a) = toPDF a
instance PDFXObject AnyPdfXForm
data PDFXForm
instance PDFXObject PDFXForm
instance PdfObject PDFXForm where
toPDF _ = noPdfObject
instance PdfResourceObject (PDFReference PDFXForm) where
toRsrc = AnyPdfObject
instance PdfResourceObject (PDFReference AnyPdfXForm) where
toRsrc = AnyPdfObject
-- | Get the bounds for an xobject
getBound :: Int -- ^ Reference
-> Draw (PDFFloat,PDFFloat)
getBound ref = do
theBounds <- asks xobjectb
return $ IM.findWithDefault (0.0,0.0) ref theBounds
-----------
--
-- PDF types
--
------------
-- | The PDF Catalog
data PDFCatalog = PDFCatalog
!(Maybe (PDFReference PDFOutline))
!(PDFReference PDFPages)
!PDFDocumentPageMode
!PDFDocumentPageLayout
!PDFViewerPreferences
-- | The PDF state
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
, catalog :: !(PDFReference PDFCatalog) -- ^ Reference to the PDF catalog
, defaultRect :: !PDFRect -- ^ Default page size
, docInfo :: !PDFDocumentInfo -- ^ Document infos
, outline :: Maybe Outline -- ^ Root outline
, currentPage :: Maybe (PDFReference PDFPage) -- ^ Reference to the current page used to create outlines
, xobjectBound :: !(IM.IntMap (PDFFloat,PDFFloat)) -- ^ Width and height of xobjects
, firstOutline :: [Bool] -- ^ Used to improve the outline API
}
-- | A PDF Page object
#ifndef __HADDOCK__
data PDFPage = PDFPage
!(Maybe (PDFReference PDFPages)) -- ^ Reference to parent
!PDFRect -- ^ Media box
!(PDFReference PDFStream) -- ^ Reference to content
!(Maybe (PDFReference PDFResource)) -- ^ Reference to resources
!(Maybe PDFFloat) -- ^ Optional duration
!(Maybe PDFTransition) -- ^ Optional transition
![AnyPdfObject] -- ^ Annotation array
#else
data PDFPage
#endif
instance Show PDFPage where
show _ = "PDFPage"
-- | List of all pages
newtype Pages = Pages (PDFTree PDFPage)
-- | PDF Pages
#ifndef __HADDOCK__
data PDFPages = PDFPages
!Int
!(Maybe (PDFReference PDFPages)) -- ^ Reference to parent
[Either (PDFReference PDFPages) (PDFReference PDFPage)]
#else
data PDFPages
#endif
-- | A PDF Transition
data PDFTransition = PDFTransition !PDFFloat !PDFTransStyle
deriving(Eq)
-- | Dimension of a transition
data PDFTransDimension = Horizontal | Vertical
deriving(Eq)
instance Show PDFTransDimension where
show Horizontal = "H"
show Vertical = "V"
-- | Direction of a transition
data PDFTransDirection = Inward | Outward deriving(Eq)
instance Show PDFTransDirection where
show Inward = "I"
show Outward = "O"
-- | Direction of a transition
data PDFTransDirection2 = LeftToRight
| BottomToTop -- ^ Wipe only
| RightToLeft -- ^ Wipe only
| TopToBottom
| TopLeftToBottomRight -- ^ Glitter only
deriving(Eq)
-- | The PDF Monad
newtype PDF a = PDF {unPDF :: StateT PdfState IO a}
#ifndef __HADDOCK__
deriving (Functor, Monad, MonadState PdfState, MonadIO)
#else
instance Functor PDF
instance Monad PDF
instance MonadState PdfState PDF
instance MonadIO PDF
#endif
-- | Transition style
data PDFTransStyle = Split PDFTransDimension PDFTransDirection
| Blinds PDFTransDimension
| Box PDFTransDirection
| Wipe PDFTransDirection2
| Dissolve
| Glitter PDFTransDirection2
deriving(Eq)
-- | Document metadata
data PDFDocumentInfo = PDFDocumentInfo {
author :: PDFString
, subject :: PDFString
, pageMode :: PDFDocumentPageMode
, pageLayout :: PDFDocumentPageLayout
, viewerPreferences :: PDFViewerPreferences
, compressed :: Bool
}
-- | Document page mode
data PDFDocumentPageMode = UseNone
| UseOutlines
| UseThumbs
| FullScreen
deriving(Eq,Show)
-- | Document page layout
data PDFDocumentPageLayout = SinglePage
| OneColumn
| TwoColumnLeft
| TwoColumnRight
| TwoPageLeft
| TwoPageRight
deriving(Eq,Show)
-- | Viewer preferences
data PDFViewerPreferences = PDFViewerPreferences { hideToolbar :: Bool -- ^ To hide the toolbar
, hideMenuBar :: Bool -- ^ To hide the menubar
, hideWindowUI :: Bool -- ^ To hide the window
, fitWindow :: Bool -- ^ Fit window to screen
, centerWindow :: Bool -- ^ Center window on screen
, displayDoctitle :: Bool -- ^ Display the docu,ent title
, nonFullScreenPageMode :: PDFDocumentPageMode -- ^ Display mode when exiting the full screen mode
}
data PDFOutline = PDFOutline !(PDFReference PDFOutlineEntry) !(PDFReference PDFOutlineEntry)
instance PdfObject PDFOutline where
toPDF (PDFOutline first lasto) = toPDF $ PDFDictionary. M.fromList $ [
(PDFName "Type",AnyPdfObject . PDFName $ "Outlines")
, (PDFName "First",AnyPdfObject first)
, (PDFName "Last",AnyPdfObject lasto)
]
data OutlineStyle = Normal
| Italic
| Bold
deriving(Eq)
data PDFOutlineEntry = PDFOutlineEntry !PDFString
!(PDFReference PDFOutlineEntry) -- Parent
!(Maybe (PDFReference PDFOutlineEntry)) -- Prev
!(Maybe (PDFReference PDFOutlineEntry)) -- Next
!(Maybe (PDFReference PDFOutlineEntry)) -- First
!(Maybe (PDFReference PDFOutlineEntry)) -- Last
Int -- Count of descendent (negative)
Destination
Color --
OutlineStyle
data Destination = Destination !(PDFReference PDFPage) deriving(Eq,Show)
-- Outline types without a position pointer. The true outline is the derivative
type OutlineData = (PDFString,Maybe Color, Maybe OutlineStyle,Destination)
type Outline = OutlineLoc OutlineData
data Tree a = Node a [Tree a]
data OutlineCtx a = Top | Child { value :: a
, parent :: OutlineCtx a
, lefts :: [Tree a]
, rights :: [Tree a]
}
data OutlineLoc a = OutlineLoc (Tree a) (OutlineCtx a)
instance PdfObject PDFViewerPreferences where
toPDF (PDFViewerPreferences ht hm hwui fw cw ddt nfspm ) = toPDF $ PDFDictionary. M.fromList $
[ (PDFName "HideToolbar",AnyPdfObject ht)
, (PDFName "HideMenubar",AnyPdfObject hm)
, (PDFName "HideWindowUI",AnyPdfObject hwui)
, (PDFName "FitWindow",AnyPdfObject fw)
, (PDFName "CenterWindow",AnyPdfObject cw)
, (PDFName "DisplayDocTitle",AnyPdfObject ddt)
, (PDFName "NonFullScreenPageMode",AnyPdfObject . PDFName . show $ nfspm)
]
instance Show PDFTransStyle where
show (Split _ _) = "Split"
show (Blinds _) = "Blinds"
show (Box _) = "Box"
show (Wipe _) = "Wipe"
show (Dissolve) = "Dissolve"
show (Glitter _) = "Glitter"
instance PdfObject PDFTransition where
toPDF (PDFTransition d t) = toPDF $ PDFDictionary. M.fromList $
[ (PDFName "Type",AnyPdfObject (PDFName "Trans"))
, (PDFName "S",AnyPdfObject (PDFName (show t)))
, (PDFName "D",AnyPdfObject d)
] ++ optionalDm t ++ optionalM t ++ optionalDi t
where
optionalDm (Split a _) = [ (PDFName "Dm",AnyPdfObject (PDFName (show a)))]
optionalDm (Blinds a) = [ (PDFName "Dm",AnyPdfObject (PDFName (show a)))]
optionalDm _ = []
optionalM (Split _ a) = [ (PDFName "M",AnyPdfObject (PDFName (show a)))]
optionalM (Box a) = [ (PDFName "M",AnyPdfObject (PDFName (show a)))]
optionalM _ = []
optionalDi (Wipe a) = [ (PDFName "Di",AnyPdfObject (floatDirection a))]
optionalDi (Glitter a) = [ (PDFName "Di",AnyPdfObject (floatDirection a))]
optionalDi _ = []
-- PDF Pages
instance PdfObject PDFPages where
toPDF (PDFPages c Nothing l) = toPDF $ PDFDictionary. M.fromList $
[ (PDFName "Type",AnyPdfObject (PDFName "Pages"))
, (PDFName "Kids",AnyPdfObject $ map AnyPdfObject l)
, (PDFName "Count",AnyPdfObject . PDFInteger $ c)
]
toPDF (PDFPages c (Just theParent) l) = toPDF $ PDFDictionary. M.fromList $
[ (PDFName "Type",AnyPdfObject (PDFName "Pages"))
, (PDFName "Parent",AnyPdfObject theParent)
, (PDFName "Kids",AnyPdfObject $ map AnyPdfObject l)
, (PDFName "Count",AnyPdfObject . PDFInteger $ c)
]
instance PdfObject PDFPage where
toPDF (PDFPage (Just theParent) box content theRsrc d t theAnnots) = toPDF $ PDFDictionary. M.fromList $
[ (PDFName "Type",AnyPdfObject (PDFName "Page"))
, (PDFName "Parent",AnyPdfObject theParent)
, (PDFName "MediaBox",AnyPdfObject box)
, (PDFName "Contents",AnyPdfObject content)
, if isJust theRsrc
then
(PDFName "Resources",AnyPdfObject . fromJust $ theRsrc)
else
(PDFName "Resources",AnyPdfObject emptyDictionary)
] ++ (maybe [] (\x -> [(PDFName "Dur",AnyPdfObject x)]) d)
++ (maybe [] (\x -> [(PDFName "Trans",AnyPdfObject x)]) t)
++ ((\x -> if null x then [] else [(PDFName "Annots",AnyPdfObject x)]) theAnnots)
toPDF (PDFPage Nothing _ _ _ _ _ _) = noPdfObject
-- Main objects in a PDF document
instance PdfObject PDFCatalog where
toPDF (PDFCatalog outlines lPages pgMode pgLayout viewerPrefs) = toPDF $ PDFDictionary . M.fromList $
[ (PDFName "Type",AnyPdfObject (PDFName "Catalog"))
, (PDFName "Pages",AnyPdfObject lPages)
, (PDFName "PageMode", AnyPdfObject . PDFName . show $ pgMode)
, (PDFName "PageLayout", AnyPdfObject . PDFName . show $ pgLayout)
, (PDFName "ViewerPreferences", AnyPdfObject viewerPrefs)
] ++ (maybe [] (\x -> [(PDFName "Outlines",AnyPdfObject x)]) outlines)
instance PdfObject OutlineStyle where
toPDF Normal = toPDF (PDFInteger 0)
toPDF Italic = toPDF (PDFInteger 1)
toPDF Bold = toPDF (PDFInteger 2)
instance PdfObject PDFOutlineEntry where
toPDF (PDFOutlineEntry title theParent prev next first theLast count dest color style) =
toPDF $ PDFDictionary. M.fromList $ [
(PDFName "Title",AnyPdfObject title)
, (PDFName "Parent",AnyPdfObject theParent)
]
++
maybe [] (\x -> [(PDFName "Prev",AnyPdfObject x)]) prev
++
maybe [] (\x -> [(PDFName "Next",AnyPdfObject x)]) next
++
maybe [] (\x -> [(PDFName "First",AnyPdfObject x)]) first
++
maybe [] (\x -> [(PDFName "Last",AnyPdfObject x)]) theLast
++
[ (PDFName "Count",AnyPdfObject (PDFInteger count))
, (PDFName "Dest",AnyPdfObject dest)
, (PDFName "C",AnyPdfObject color)
, (PDFName "F",AnyPdfObject style)
]
instance PdfObject Destination where
toPDF (Destination r) = toPDF [ AnyPdfObject r
, AnyPdfObject . PDFName $ "Fit"
]
instance PdfObject Color where
toPDF (Rgb r g b) = toPDF . map (AnyPdfObject . PDFFloat) $ [r,g,b]
toPDF (Hsv h s v) = let (r,g,b) = hsvToRgb (h,s,v)
in toPDF . map (AnyPdfObject . PDFFloat) $ [r,g,b]
-- Degree for a transition direction
floatDirection :: PDFTransDirection2 -> PDFFloat
floatDirection LeftToRight = 0
floatDirection BottomToTop = 90
floatDirection RightToLeft = 180
floatDirection TopToBottom = 270
floatDirection TopLeftToBottomRight = 315
hsvToRgb :: (Double,Double,Double) -> (Double,Double,Double)
hsvToRgb (h,s,v) =
let hi = fromIntegral (floor (h / 60) `mod` 6 :: Int) :: Double
f = h/60 - hi
p = v * (1-s)
q = v * (1 - f*s)
t = v * (1 - (1-f)*s) in
case hi of
0 -> (v,t,p)
1 -> (q,v,p)
2 -> (p,v,t)
3 -> (p,q,v)
4 -> (t,p,v)
5 -> (v,p,q)
_ -> error "Hue value incorrect"
getRgbColor :: Color -> (PDFFloat,PDFFloat,PDFFloat)
getRgbColor (Rgb r g b) = (PDFFloat r,PDFFloat g,PDFFloat b)
getRgbColor (Hsv h s v) = let (r,g,b) = hsvToRgb (h,s,v) in (PDFFloat r,PDFFloat g,PDFFloat b)
-- | Interpolation function
interpole :: Int -> PDFFloat -> PDFFloat -> AnyPdfObject
interpole n x y = AnyPdfObject . PDFDictionary . M.fromList $
[ (PDFName "FunctionType", AnyPdfObject . PDFInteger $ 2)
, (PDFName "Domain", AnyPdfObject . map AnyPdfObject $ [PDFFloat 0,PDFFloat 1])
, (PDFName "C0", AnyPdfObject . map AnyPdfObject $ [x])
, (PDFName "C1", AnyPdfObject . map AnyPdfObject $ [y])
, (PDFName "N", AnyPdfObject . PDFInteger $ n)
]
-- | A shading
data PDFShading = AxialShading PDFFloat PDFFloat PDFFloat PDFFloat Color Color
| RadialShading PDFFloat PDFFloat PDFFloat PDFFloat PDFFloat PDFFloat Color Color
deriving(Eq,Ord)
instance PdfResourceObject PDFShading where
toRsrc (AxialShading x0 y0 x1 y1 ca cb) = AnyPdfObject . PDFDictionary . M.fromList $
[ (PDFName "ShadingType",AnyPdfObject . PDFInteger $ 2)
, (PDFName "Coords",AnyPdfObject . map AnyPdfObject $ [x0,y0,x1,y1])
, (PDFName "ColorSpace",AnyPdfObject . PDFName $ "DeviceRGB")
, (PDFName "Function",AnyPdfObject $ [interpole 1 ra rb,interpole 1 ga gb,interpole 1 ba bb])
]
where
(ra,ga,ba) = getRgbColor ca
(rb,gb,bb) = getRgbColor cb
toRsrc (RadialShading x0 y0 r0 x1 y1 r1 ca cb) = AnyPdfObject . PDFDictionary . M.fromList $
[ (PDFName "ShadingType",AnyPdfObject . PDFInteger $ 3)
, (PDFName "Coords",AnyPdfObject . map AnyPdfObject $ [x0,y0,r0,x1,y1,r1])
, (PDFName "ColorSpace",AnyPdfObject . PDFName $ "DeviceRGB")
, (PDFName "Function",AnyPdfObject $ [interpole 1 ra rb,interpole 1 ga gb,interpole 1 ba bb])
]
where
(ra,ga,ba) = getRgbColor ca
(rb,gb,bb) = getRgbColor cb