diagrams-pdf-0.2.0: src/Diagrams/Backend/Pdf.hs
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module : Diagrams.Backend.Pdf
-- Copyright : (c) 2013 alpheccar.org (see LICENSE)
-- License : BSD-style (see LICENSE)
--
-- A Pdf rendering backend for diagrams.
--
-- To build diagrams for Pdf rendering use the @Pdf@
-- type in the diagram type construction
--
-- > d :: Diagram Pdf R2
-- > d = ...
--
-- and render giving the @Pdf@ token
--
-- > renderDia Pdf (PdfOptions (Width 400)) d
--
-- This IO action will write the specified file.
--
-----------------------------------------------------------------------------
module Diagrams.Backend.Pdf
( -- * Backend token
Pdf(..)
, Options(..)
, sizeFromSpec
) where
import Graphics.PDF hiding(transform,Style,translate,scale)
import qualified Graphics.PDF as P
import Diagrams.Prelude
import Diagrams.TwoD.Text
import Data.Maybe (catMaybes)
import qualified Data.Foldable as F
import Data.Monoid.Split
import Data.Typeable
import qualified Control.Monad.State.Strict as S
import Control.Monad.Trans(lift)
import Diagrams.TwoD.Path
import Control.Monad(when)
-- | This data declaration is simply used as a token to distinguish this rendering engine.
data Pdf = Pdf
deriving (Eq,Ord,Read,Show,Typeable)
{-
For a future release to support some specific HPDF features
-}
{-
data LabelStyle = LabelStyle Int Justification P.Orientation
data TextBox = TextBox T2 Double Double LabelStyle String
type instance V TextBox = R2
instance Transformable TextBox where
transform t (TextBox tt w h a s) = TextBox (t <> tt) w h a s
instance IsPrim TextBox
instance HasOrigin TextBox where
moveOriginTo p = translate (origin .-. p)
instance Renderable TextBox NullBackend where
render _ _ = mempty
pdfText :: (Renderable TextBox b)
=> LabelStyle
-> String
-> Double
-> Double
-> Diagram b R2
pdfText ls s w h = mkQD (Prim (TextBox mempty w h ls s))
(getEnvelope r)
(getTrace r)
mempty
(Query $ \p -> Any (isInsideEvenOdd p r))
where r :: Path R2
r = rect w h
drawStringLabel :: LabelStyle
-> String
-> PDFFloat
-> PDFFloat
-> PDFFloat
-> PDFFloat
-> Draw ()
drawStringLabel (LabelStyle fs j o) s x y w h = do
let (r,b) = drawTextBox x y w h o NormalParagraph (P.Font (PDFFont Times_Roman fs) P.black P.black) $ do
setJustification j
paragraph $ do
txt $ s
b
instance Renderable TextBox Pdf where
render _ (TextBox t w h ls text) = D $ do
let r :: Path R2
r = rect w h
r' = transform t r
b = boundingBox r'
corners = getCorners b
case corners of
Just (a,b) -> do
let (xa,ya) = unp2 a
(xb,yb) = unp2 b
drawM $ P.stroke $ Rectangle (xa :+ ya) (xb :+ yb)
drawM (drawStringLabel ls text xa ya (xb-xa) (yb-ya))
Nothing -> return()
-}
{-
End of the specific part
-}
-- | The drawing state
-- I should give a name to the different fields and use lens
-- The first three parameters are for the font
-- The P.Point is because the PDF specification is using absolute
-- coordinates but relative coordinates are needed for diagrams.
-- So the last point is tracked here.
-- The last bools are to disable fill and stroke.
-- Fill is disabled when transparency is total (color transparency and not diagram transparency)
-- Stroke is disabled when line width is 0 because in the PDF specification
-- line width 0 means the smallest width and something is displayed.
data DrawingState = DrawingState { _fontSlant :: FontSlant
, _fontWeight :: FontWeight
, _fontSize :: Int
, _fillRule :: FillRule
, _currentPoint :: P.Point
, _mustFill :: Bool
, _mustStroke :: Bool
, _isloop :: Bool
}
-- | The stack of drawing state
data StateStack = StateStack { _current :: DrawingState
, _last :: [DrawingState]
}
defaultFontSize :: Num a => a
defaultFontSize = 1
diagramDefaultUnit :: Fractional a => a
diagramDefaultUnit = 0.01
defaultWidth :: Fractional a => a
defaultWidth = 0.01
-- | Initial drawing state
initState :: StateStack
initState = StateStack (DrawingState FontSlantNormal FontWeightNormal 1 Winding (0 :+ 0) False True False) []
-- | The drawing monad with state
newtype DrawS a = DS (S.StateT StateStack Draw a) deriving(Monad,S.MonadState StateStack)
-- | List a Draw value into the DrawS monad
drawM :: Draw a -> DrawS a
drawM = DS . lift
-- | Get the MonadState wrapped in DS
unDS :: DrawS t -> S.StateT StateStack Draw t
unDS (DS r) = r
-- | Get the Draw value from an initial state
runDS :: DrawS a -> Draw a
runDS d = S.evalStateT (unDS d) initState
-- | Generate an HPDF font
mkFont :: DrawingState -> PDFFont
mkFont (DrawingState FontSlantNormal FontWeightNormal s _ _ _ _ _) = PDFFont Times_Roman s
mkFont (DrawingState FontSlantNormal FontWeightBold s _ _ _ _ _) = PDFFont Times_Bold s
mkFont (DrawingState FontSlantItalic FontWeightNormal s _ _ _ _ _) = PDFFont Times_Italic s
mkFont (DrawingState FontSlantItalic FontWeightBold s _ _ _ _ _) = PDFFont Times_BoldItalic s
mkFont (DrawingState FontSlantOblique FontWeightNormal s _ _ _ _ _) = PDFFont Helvetica_Oblique s
mkFont (DrawingState FontSlantOblique FontWeightBold s _ _ _ _ _) = PDFFont Helvetica_BoldOblique s
setFontSize :: Double -> DrawS ()
setFontSize fs = do
let s = floor fs
StateStack (DrawingState fsl fw _ wr p f st ilp) l <- S.get
S.put $! StateStack (DrawingState fsl fw s wr p f st ilp) l
setFontWeight :: FontWeight -> DrawS ()
setFontWeight w = do
StateStack (DrawingState fsl _ fs wr p f st ilp) l <- S.get
S.put $! StateStack (DrawingState fsl w fs wr p f st ilp) l
setFontSlant :: FontSlant -> DrawS ()
setFontSlant sl = do
StateStack (DrawingState _ fw fs wr p f st ilp) l <- S.get
S.put $! StateStack (DrawingState sl fw fs wr p f st ilp) l
setFillRule :: FillRule -> DrawS ()
setFillRule wr = do
StateStack (DrawingState sl fw fs _ p f st ilp) l <- S.get
S.put $! StateStack (DrawingState sl fw fs wr p f st ilp) l
savePoint :: P.Point -> DrawS ()
savePoint p = do
StateStack (DrawingState sl fw fs wr _ f st ilp) l <- S.get
S.put $! StateStack (DrawingState sl fw fs wr p f st ilp) l
currentPoint :: DrawS P.Point
currentPoint = do
StateStack (DrawingState _ _ _ _ p _ _ _) _ <- S.get
return p
getFillState :: DrawS FillRule
getFillState = do
StateStack (DrawingState _ _ _ w _ _ _ _) _ <- S.get
return w
mustFill :: DrawS Bool
mustFill = do
StateStack (DrawingState _ _ _ _ _ b _ _) _ <- S.get
return b
-- | From the alpha value of a fill color, we check if the filling must be disabled
setFillingColor :: Double -> DrawS()
setFillingColor alpha = do
let b | alpha /= 0.0 = True
| otherwise = False
StateStack (DrawingState fsl w fs wr p _ st ilp) l <- S.get
S.put $! StateStack (DrawingState fsl w fs wr p b st ilp) l
mustStroke :: DrawS Bool
mustStroke = do
StateStack (DrawingState _ _ _ _ _ _ b _) _ <- S.get
return b
-- | From the linew width we check if stroke must be disabled
setTrokeState :: Double -> DrawS ()
setTrokeState w = do
let st | w == 0 = False
| otherwise = True
StateStack (DrawingState fsl fw fs wr p b _ ilp) l <- S.get
S.put $! StateStack (DrawingState fsl fw fs wr p b st ilp) l
isALoop :: DrawS Bool
isALoop = do
StateStack s _ <- S.get
return $ _isloop s
setLoop :: Bool -> DrawS ()
setLoop b = do
StateStack s l <- S.get
S.put $! StateStack (s {_isloop = b}) l
-- | Initial settings before rendering the diagram
setTranform :: Draw () -> Draw ()
setTranform d = do
P.fillColor P.white
P.strokeColor P.black
P.setWidth defaultWidth
d
strokeOrFill :: DrawS ()
strokeOrFill = do
mf <- mustFill
ms <- mustStroke
fs <- getFillState
isloop <- isALoop
-- Set the diagram opacity in a new PDF context
case (ms,mf,fs,isloop) of
(True,True,Winding,True) -> drawM (P.fillAndStrokePath)
(True,True,EvenOdd,True) -> drawM (P.fillAndStrokePathEO)
(False,True,Winding,True) -> drawM (P.fillPath)
(False,True,EvenOdd,True) -> drawM (P.fillPathEO)
(True,_,_,_) -> drawM (P.strokePath)
(_,_,_,_) -> return ()
setLoop True
instance Backend Pdf R2 where
data Render Pdf R2 = D (DrawS ())
type Result Pdf R2 = Draw ()
data Options Pdf R2 = PdfOptions {
pdfsizeSpec :: SizeSpec2D
} deriving(Show)
-- There is something I don't understand here with the frozen style.
-- On the tests it is working but I would not have put
-- the calls in this order ... so it must be checked later
withStyle _ s t (D r) = D $ do
withContext $ do
pdfMiscStyle s
mf <- mustFill
ms <- mustStroke
-- Set the clip region into a new PDF context
-- since it is the only way to restore the old clip region
-- (by popping the PDF stack of contexts)
pdfTransf t
withClip s $ do
pdfFrozenStyle s
when (mf || ms) $ do
withPdfOpacity s $ do
r
strokeOrFill
doRender _ _ (D r) = setTranform (runDS r)
renderDia Pdf opts d =
centerAndScale opts d . doRender Pdf opts' . mconcat . map renderOne . prims $ d'
where (opts', d') = adjustDia Pdf opts d
renderOne :: (Prim Pdf R2, (Split (Transformation R2), Style R2))
-> Render Pdf R2
renderOne (p, (M t, s))
= withStyle Pdf s mempty (render Pdf (transform t p))
renderOne (p, (t1 :| t2, s))
-- Here is the difference from the default
-- implementation: "t2" instead of "t1 <> t2".
= withStyle Pdf s t1 (render Pdf (transform t2 p))
centerAndScale opts diag renderedDiagram = do
let bd = boundingBox diag
(w,h) = sizeFromSpec (pdfsizeSpec opts)
rescaledD (Just (ll,ur)) =
let (vx,vy) = unp2 $ centroid [ll,ur]
(xa,ya) = unp2 ll
(xb,yb) = unp2 ur
ps = max (abs (xb - xa)) (abs (yb - ya))
sx = w / ps
sy = h / ps
pageCenter = (w / 2.0) P.:+ (h/2.0)
in
do
P.applyMatrix (P.translate pageCenter)
P.applyMatrix (P.scale sx sy)
P.applyMatrix (P.translate $ (-vx) P.:+ (-vy))
rescaledD Nothing = return ()
rescaledD (getCorners bd)
P.withNewContext $ do
renderedDiagram
instance Monoid (Render Pdf R2) where
mempty = D (return ())
(D a) `mappend` (D b) = D (a >> b)
sizeFromSpec :: SizeSpec2D -> (Double,Double)
sizeFromSpec size = case size of
Width w' -> (w',w')
Height h' -> (h',h')
Dims w' h' -> (w',h')
Absolute -> (200,200)
-- | Relative lineto
relativeLine :: P.Point -> DrawS ()
relativeLine p = do
c <- currentPoint
let c' = p + c
drawM (lineto c')
savePoint c'
-- | Relative curveto
relativeCurveTo :: P.Point -> P.Point -> P.Point -> DrawS ()
relativeCurveTo x y z = do
c <- currentPoint
let x' = x + c
y' = y + c
z' = z + c
drawM (curveto x' y' z')
savePoint z'
-- | moveto but with saving of the point
moveToAndSave :: P.Point -> DrawS ()
moveToAndSave p = do
drawM (moveto p)
savePoint p
-- | Convenience functions
renderC :: (Renderable a Pdf, V a ~ R2) => a -> DrawS ()
renderC a = case render Pdf a of D r -> r
{-
push :: DrawS()
push = do
StateStack c l <- S.get
S.put $! (StateStack c (c:l))
pop :: DrawS()
pop = do
StateStack _ l <- S.get
S.put $! (StateStack (head l) (tail l))
-}
-- | With a new context do something
-- It is a bit comlex because the withNewContext from the HPDF library
-- must be used to push / pop a new PDF context
withContext :: DrawS a -> DrawS a
withContext d = do
s <- S.get
let d' = S.evalStateT (unDS d) s
a <- drawM (withNewContext d')
return a
pdfFillColor :: (Real b, Floating b) => AlphaColour b -> DrawS ()
pdfFillColor c = do
let (r,g,b,a) = colorToSRGBA c
drawM $ do
P.setFillAlpha a
P.fillColor (Rgb r g b)
setFillingColor a
pdfStrokeColor :: (Real b, Floating b) => AlphaColour b -> DrawS ()
pdfStrokeColor c = drawM $ do
let (r,g,b,a) = colorToSRGBA c
P.setStrokeAlpha a
P.strokeColor (Rgb r g b)
{-
Conversions between diagrams and HPDF types
-}
pdfLineJoin :: LineJoin -> P.JoinStyle
pdfLineJoin LineJoinMiter = MiterJoin
pdfLineJoin LineJoinRound = RoundJoin
pdfLineJoin LineJoinBevel = BevelJoin
pdfLineCap :: LineCap -> P.CapStyle
pdfLineCap LineCapButt = ButtCap
pdfLineCap LineCapRound = RoundCap
pdfLineCap LineCapSquare = SquareCap
pdfDashing :: Dashing -> DashPattern
pdfDashing (Dashing l a) = DashPattern (map convert l) (convert a)
where
convert x = defaultWidth * x / diagramDefaultUnit
{-
Opacity and clip attributes must be handled separately from the other
attributes
-}
withPdfOpacity :: Style v -> DrawS a -> DrawS a
withPdfOpacity s m = do
let mo = handle s getOpacity
case mo of
Nothing -> m
Just d -> do
withContext $ do
drawM (setStrokeAlpha d >> setFillAlpha d)
m
where handle :: AttributeClass a => Style v -> (a -> b) -> Maybe b
handle st f = f `fmap` getAttr st
withClip :: Style v -> DrawS () -> DrawS ()
withClip s m = do
let d = handle s m clip
case d of
Just r -> r
Nothing -> m
where handle :: AttributeClass a => Style v -> DrawS () -> (DrawS () -> a -> b) -> Maybe b
handle st dm f = f dm `fmap` getAttr st
clip dm = clipPath dm . getClip
addPathToClip p = do
renderC p
f <- getFillState
case f of
Winding -> drawM (setAsClipPath)
EvenOdd -> drawM (setAsClipPathEO)
clipPath dm p = do
withContext $ do
mapM_ addPathToClip p
dm
pdfMiscStyle :: Style v -> DrawS ()
pdfMiscStyle s = do
sequence_ . catMaybes $ [ handle fSlant
, handle fWeight
, handle fSize
, handle fColor
, handle lColor
, handle lFillRule
, handle checklWidth
]
where handle :: AttributeClass a => (a -> DrawS ()) -> Maybe (DrawS ())
handle f = f `fmap` getAttr s
fSize = setFontSize . getFontSize
--fFace = const (return ())
fSlant = setFontSlant . getFontSlant
fWeight = setFontWeight . getFontWeight
lColor c = pdfStrokeColor . toAlphaColour . getLineColor $ c
fColor c = pdfFillColor . toAlphaColour . getFillColor $ c
lFillRule = setFillRule . getFillRule
checklWidth w = do
let d = getLineWidth w
setTrokeState d
pdfFrozenStyle :: Style v -> DrawS ()
pdfFrozenStyle s = sequence_ -- foldr (>>) (return ())
. catMaybes $ [ handle lWidth
, handle lJoin
, handle lCap
, handle lDashing
]
where handle :: (AttributeClass a) => (a -> DrawS ()) -> Maybe (DrawS ())
handle f = f `fmap` getAttr s
lWidth w = do
let d = getLineWidth w
drawM . setWidth $ (defaultWidth * d / diagramDefaultUnit)
setTrokeState d
lCap = drawM . setLineCap . pdfLineCap . getLineCap
lJoin = drawM . setLineJoin . pdfLineJoin . getLineJoin
lDashing = drawM . setDash . pdfDashing . getDashing
unR :: R2 -> Complex Double
unR r = let (x,y) = unr2 r
in (x :+ y)
unP :: P2 -> Complex Double
unP r = let (x,y) = unp2 r
in (x :+ y)
pdfTransf :: Transformation R2 -> DrawS ()
pdfTransf t = drawM $ applyMatrix (Matrix a1 a2 b1 b2 c1 c2)
where (a1,a2) = unr2 $ apply t unitX
(b1,b2) = unr2 $ apply t unitY
(c1,c2) = unr2 $ transl t
instance Renderable (Segment Closed R2) Pdf where
render _ (Linear (OffsetClosed (unR -> v))) = D $ relativeLine v
render _ (Cubic (unR -> po1)
(unR -> po2)
(OffsetClosed (unR -> po3)))
= D $ relativeCurveTo po1 po2 po3
instance Renderable (Trail R2) Pdf where
render _ t = D . flip withLine t $ renderT . lineSegments
where
renderT segs =
do
mapM_ renderC segs
when (isLoop t) (drawM closePath)
setLoop (isLoop t)
instance Renderable (Path R2) Pdf where
render _ (Path t) = D $ do
F.mapM_ renderTrail t
where renderTrail (viewLoc -> (unP -> p, tr)) = do
moveToAndSave p
renderC tr
instance Renderable Text Pdf where
render _ (Text tr al str) =
D $ withContext $ do
StateStack f _ <- S.get
let theFont = mkFont f
tw = textWidth theFont (toPDFString str)
descent = getDescent theFont
fontHeight = getHeight theFont
(x,y) = case al of
BoxAlignedText xt yt -> (xt,yt)
BaselineText -> (0,0)
x' = - tw * x
y' = - (fontHeight - descent) * y
pdfTransf tr
withContext . drawM $ do
P.applyMatrix (P.scale (1.0 / defaultFontSize) (1.0 / defaultFontSize))
P.applyMatrix (P.translate (x' :+ y'))
P.drawText $ P.text theFont 0 0 (toPDFString str)