HPDF-1.4: Graphics/PDF/Draw.hs
{-# OPTIONS_GHC -fglasgow-exts #-}
---------------------------------------------------------
-- |
-- 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(..)
, readDrawST
, writeDrawST
, modifyDrawST
, DrawTuple()
, penPosition
, supplyName
, emptyDrawing
-- , writeCmd
, runDrawing
, setResource
, emptyEnvironment
, PDFXForm
, PDFXObject(..)
, AnyPdfXForm
, pdfDictMember
-- 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
, emptyDrawState
, Matrix(..)
, identity
, applyMatrix
, currentMatrix
, multiplyCurrentMatrixWith
, PDFGlobals(..)
) where
import Data.Maybe
import Data.Monoid
import qualified Data.Map as M
import qualified Data.IntMap as IM
import qualified Data.Binary.Builder as BU
import Control.Monad.ST
import Data.STRef
import Control.Monad.Writer.Class
import Control.Monad.Reader.Class
import Control.Monad.State
import Graphics.PDF.Coordinates
import Graphics.PDF.LowLevel.Types
import Graphics.PDF.LowLevel.Serializer
import Graphics.PDF.Resources
import Graphics.PDF.Data.PDFTree(PDFTree)
data AnnotationStyle = AnnotationStyle !(Maybe Color)
class AnnotationObject a where
addAnnotation :: a -> PDF (PDFReference a)
annotationType :: a -> PDFName
annotationContent :: a -> PDFString
annotationRect :: a -> [PDFFloat]
annotationToGlobalCoordinates :: a -> Draw a
annotationToGlobalCoordinates = return
data AnyAnnotation = forall a.(PdfObject a,AnnotationObject a) => AnyAnnotation a
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
, matrix :: [Matrix]
}
data DrawEnvironment = DrawEnvironment {
streamId :: Int
, xobjectBoundD :: IM.IntMap (PDFFloat,PDFFloat)
}
data DrawTuple s
= DrawTuple { drawEnvironment :: DrawEnvironment
, drawStateRef :: STRef s DrawState
, builderRef :: STRef s BU.Builder
, penPosition :: STRef s Point
}
emptyEnvironment :: DrawEnvironment
emptyEnvironment = DrawEnvironment 0 IM.empty
class PDFGlobals m where
bounds :: PDFXObject a => PDFReference a -> m (PDFFloat,PDFFloat)
-- | The drawing monad
newtype Draw a = Draw {unDraw :: forall s. DrawTuple s -> ST s a }
instance Monad Draw where
m >>= f = Draw $ \env -> do
a <- unDraw m env
unDraw (f a) env
return x = Draw $ \_env -> return x
instance MonadReader DrawEnvironment Draw where
ask = Draw $ \env -> return (drawEnvironment env)
local f m = Draw $ \env -> let drawenv' = f (drawEnvironment env)
env' = env { drawEnvironment = drawenv' }
in unDraw m env'
instance MonadState DrawState Draw where
get = Draw $ \env -> readSTRef (drawStateRef env)
put st = Draw $ \env -> writeSTRef (drawStateRef env) st
instance MonadWriter BU.Builder Draw where
tell bu = Draw $ \env -> modifySTRef (builderRef env) (`mappend` bu)
listen m = Draw $ \env -> do
a <- unDraw m env
w <- readSTRef (builderRef env)
return (a,w)
pass m = Draw $ \env -> do
(a, f) <- unDraw m env
modifySTRef (builderRef env) f
return a
instance Functor Draw where
fmap f = \m -> do { a <- m; return (f a) }
instance MonadPath Draw
readDrawST :: (forall s. DrawTuple s -> STRef s a) -> Draw a
readDrawST f = Draw $ \env -> readSTRef (f env)
writeDrawST :: (forall s. DrawTuple s -> STRef s a) -> a -> Draw ()
writeDrawST f x = Draw $ \env -> writeSTRef (f env) x
modifyDrawST :: (forall s. DrawTuple s -> STRef s a) -> (a -> a) -> Draw ()
modifyDrawST f g = Draw $ \env -> modifySTRef (f env) g
-- | A PDF stream object
data PDFStream = PDFStream !BU.Builder !Bool !(PDFReference PDFLength) !PDFDictionary
instance PdfObject PDFStream where
toPDF (PDFStream s c l d) =
mconcat $ [ toPDF dict
, serialize "\nstream"
, newline
, s
, newline
, serialize "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
-- | Get a new resource name
supplyName :: Draw String
supplyName = do
(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 [identity]
-- | Execute the drawing commands to get a new state and an uncompressed PDF stream
runDrawing :: Draw a -> DrawEnvironment -> DrawState -> (a,DrawState,BU.Builder)
runDrawing drawing environment state
= runST $ do
dRef <- newSTRef state
bRef <- newSTRef mempty
posRef <- newSTRef 0
let tuple = DrawTuple { drawEnvironment = environment
, drawStateRef = dRef
, builderRef = bRef
, penPosition = posRef
}
a <- unDraw drawing tuple
drawSt <- readSTRef (drawStateRef tuple)
builder <- readSTRef (builderRef tuple)
return (a, drawSt, builder)
pushMatrixStack :: Matrix -> Draw ()
pushMatrixStack m = do
modifyStrict $ \s -> s {matrix = m : matrix s}
popMatrixStack :: Draw ()
popMatrixStack = do
modifyStrict $ \s -> s {matrix = tail (matrix s)}
multiplyCurrentMatrixWith :: Matrix -> Draw ()
multiplyCurrentMatrixWith m' = modifyStrict $ \s -> s {matrix = let (m:l) = matrix s in (m' * m ):l}
currentMatrix :: Draw Matrix
currentMatrix = gets matrix >>= return . head
-- | Draw in a new drawing context without perturbing the previous context
-- that is restored after the draw
withNewContext :: Draw a -> Draw a
withNewContext m = do
tell . serialize $ "\nq"
pushMatrixStack identity
a <- m
popMatrixStack
tell . serialize $ "\nQ"
return a
-- | 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)
instance PDFGlobals Draw where
bounds (PDFReference r) = getBoundInDraw r
instance PDFGlobals PDF where
bounds (PDFReference r) = getBoundInPDF r
-- | A PDF Xobject which can be drawn
class PDFXObject a where
drawXObject :: PDFReference a -> Draw ()
privateDrawXObject :: PDFReference a -> Draw ()
privateDrawXObject (PDFReference r) = do
xobjectMap <- gets xobjects
(newName,newMap) <- setResource "XObject" (PDFReference r) xobjectMap
modifyStrict $ \s -> s { xobjects = newMap }
tell . mconcat $ [ serialize "\n/"
, serialize newName
, serialize " Do"
]
drawXObject = privateDrawXObject
-- | 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
getBoundInDraw :: Int -- ^ Reference
-> Draw (PDFFloat,PDFFloat)
getBoundInDraw ref = do
theBounds <- asks xobjectBoundD
return $ IM.findWithDefault (0.0,0.0) ref theBounds
-- | Get the bounds for an xobject
getBoundInPDF :: Int -- ^ Reference
-> PDF (PDFFloat,PDFFloat)
getBoundInPDF ref = do
theBounds <- gets xobjectBound
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)),(DrawState,BU.Builder))) -- ^ 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 :: State PdfState a}
#ifndef __HADDOCK__
deriving (Functor, Monad, MonadState PdfState)
#else
instance Functor PDF
instance Monad PDF
instance MonadState PdfState 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 = NormalOutline
| ItalicOutline
| BoldOutline
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 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) =
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 $ [r,g,b]
toPDF (Hsv h s v) = let (r,g,b) = hsvToRgb (h,s,v)
in toPDF . map AnyPdfObject $ [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) = (r, g, b)
getRgbColor (Hsv h s v) = let (r,g,b) = hsvToRgb (h,s,v) in (r, g, 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 $ ([0,1] :: [PDFFloat]))
, (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
-- | Apply a transformation matrix to the current coordinate frame
applyMatrix :: Matrix -> Draw ()
applyMatrix m@(Matrix a b c d e f) = do
multiplyCurrentMatrixWith m
tell . mconcat $[ serialize '\n'
, toPDF a
, serialize ' '
, toPDF b
, serialize ' '
, toPDF c
, serialize ' '
, toPDF d
, serialize ' '
, toPDF e
, serialize ' '
, toPDF f
, serialize " cm"
]