diagrams-pdf 0.2.0 → 0.3

raw patch · 6 files changed

+870/−137 lines, 6 filesbinary-addedPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• diagrams-pdf.cabal +5/−2
• src/Diagrams/Backend/Pdf.hs +378/−135
• src/Diagrams/Backend/Pdf/Specific.hs +168/−0
• test/Makefile +11/−0
• test/logo.jpg binary
• test/test.hs +308/−0

@@ -1,5 +1,5 @@ name:                diagrams-pdf-version:             0.2.0+version:             0.3 synopsis:            PDF backend for diagrams drawing EDSL homepage:            http://www.alpheccar.org license:             BSD3@@ -32,14 +32,17 @@                      .                      Additional documentation can be found in the                      README file distributed with the source tarball+extra-source-files: test/test.hs, test/Makefile, test/logo.jpg+ Source-repository head   type:     git   location: http://github.com/alpheccar/diagrams-pdf + library   Exposed-modules:     Diagrams.Backend.Pdf                        Diagrams.Backend.Pdf.CmdLine     -  -- other-modules:       +  other-modules:       Diagrams.Backend.Pdf.Specific   build-depends:       base >= 4.6 && < 4.8,                        mtl >= 2.1 && < 2.2 ,                        monoid-extras >= 0.3 && < 0.4,

@@ -8,7 +8,8 @@ {-# LANGUAGE TypeSynonymInstances      #-} {-# LANGUAGE ViewPatterns              #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module      :  Diagrams.Backend.Pdf@@ -29,13 +30,36 @@ -- -- This IO action will write the specified file. --+-- / Specific HPDF primitives /+-- +-- For details about the use of the HPDF specific primitives, the file+-- test.hs in this package can be used. You'll have to unpack the archive+-- for this package. ----------------------------------------------------------------------------- module Diagrams.Backend.Pdf -  ( -- * Backend token+  ( -- * PDF Backend +    -- ** Backend token     Pdf(..)+    -- ** Backend options   , Options(..)   , sizeFromSpec+  -- * HPDF Specific primitives +  -- ** Text+  , LabelStyle(..)+  , TextOrigin(..)+  , LabelSize+  , pdfLabelWithSuggestedSize+  , pdfTextWithSuggestedSize+  , pdfLabelWithSize+  , pdfTextWithSize+  -- ** Image+  , pdfImage+  -- ** URL+  , pdfURL+  -- ** Shading+  , pdfAxialShading+  , pdfRadialShading   ) where  @@ -51,90 +75,23 @@  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)+import Diagrams.Backend.Pdf.Specific+import           Data.Typeable+import qualified Diagrams.TwoD.Shapes as Sh+import Data.Maybe(isJust) +--import Debug.Trace as T++--debug a = T.trace (show a) a + -- | 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@@ -153,6 +110,7 @@                                  , _mustFill :: Bool                                  , _mustStroke :: Bool                                  , _isloop :: Bool+                                 , _shading :: Maybe PDFShading                                }  -- | The stack of drawing state@@ -171,7 +129,7 @@  -- | Initial drawing state initState :: StateStack-initState = StateStack (DrawingState FontSlantNormal FontWeightNormal 1 Winding (0 :+ 0) False True False) []+initState = StateStack (DrawingState FontSlantNormal FontWeightNormal 1 Winding (0 :+ 0) False True True Nothing) []   -- | The drawing monad with state@@ -192,55 +150,55 @@  -- | 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+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+  StateStack (DrawingState fsl fw _ wr p f st ilp shade) l <- S.get +  S.put $! StateStack (DrawingState fsl fw s wr p f st ilp shade) 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+  StateStack (DrawingState fsl _ fs wr p f st ilp shade) l <- S.get +  S.put $! StateStack (DrawingState fsl w fs wr p f st ilp shade) 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+  StateStack (DrawingState _ fw fs wr p f st ilp shade) l <- S.get +  S.put $! StateStack (DrawingState sl fw fs wr p f st ilp shade) 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+  StateStack (DrawingState sl fw fs _ p f st ilp shade) l <- S.get +  S.put $! StateStack (DrawingState sl fw fs wr p f st ilp shade) 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+  StateStack (DrawingState sl fw fs wr _ f st ilp shade) l <- S.get +  S.put $! StateStack (DrawingState sl fw fs wr p f st ilp shade) l  currentPoint :: DrawS P.Point  currentPoint = do -  StateStack (DrawingState _ _ _ _ p _ _ _) _ <- S.get +  StateStack (DrawingState _ _ _ _ p _ _ _ _) _ <- S.get    return p   getFillState :: DrawS FillRule  getFillState = do -  StateStack (DrawingState _ _ _ w _ _ _ _) _ <- S.get +  StateStack (DrawingState _ _ _ w _ _ _ _ _) _ <- S.get    return w  mustFill :: DrawS Bool  mustFill = do-  StateStack (DrawingState _ _ _ _ _ b _ _) _ <- S.get +  StateStack (DrawingState _ _ _ _ _ b _ _ _) _ <- S.get    return b  -- | From the alpha value of a fill color, we check if the filling must be disabled@@ -248,12 +206,12 @@ 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+    StateStack (DrawingState fsl w fs wr p _ st ilp shade) l <- S.get +    S.put $! StateStack (DrawingState fsl w fs wr p b st ilp shade) l  mustStroke :: DrawS Bool mustStroke = do -  StateStack (DrawingState _ _ _ _ _ _ b _) _ <- S.get +  StateStack (DrawingState _ _ _ _ _ _ b _ _) _ <- S.get    return b  -- | From the linew width we check if stroke must be disabled@@ -261,14 +219,19 @@ 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+  StateStack (DrawingState fsl fw fs wr p b _ ilp shade) l <- S.get +  S.put $! StateStack (DrawingState fsl fw fs wr p b st ilp shade) l  isALoop :: DrawS Bool  isALoop = do    StateStack s _ <- S.get   return $ _isloop s +getShading :: DrawS (Maybe PDFShading) +getShading = do +  StateStack s _ <- S.get+  return $ _shading $  s+ setLoop :: Bool -> DrawS ()  setLoop b = do    StateStack s l <- S.get@@ -282,33 +245,43 @@      P.setWidth defaultWidth      d -strokeOrFill :: DrawS () -strokeOrFill = do +withShading :: Transformation R2 -> Bool -> Maybe PDFShading -> DrawS () -> DrawS () -> DrawS () +withShading td evenodd (Just shade) diag _ = do +    withContext $ do +      diag+      drawM $ do+         if evenodd +         then P.setAsClipPathEO+         else P.setAsClipPath+         P.applyShading (unTrans $ transform td (TransSh shade))+withShading _ _ _ diag paint = do +  diag +  paint++strokeOrFill :: Transformation R2 -> DrawS () -> DrawS () +strokeOrFill td r = do    mf <- mustFill   ms <- mustStroke    fs <- getFillState   isloop <- isALoop+  sh <- getShading   -- 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 ()+       (True,True,Winding,True) -> withShading td False sh r $ drawM (P.fillAndStrokePath)+       (True,True,EvenOdd,True) -> withShading td True sh r $ drawM (P.fillAndStrokePathEO)+       (False,True,Winding,True) -> withShading td False sh r $ drawM (P.fillPath)+       (False,True,EvenOdd,True) -> withShading td True sh r $ drawM (P.fillPathEO)+       (True,_,_,_) -> r >> drawM (P.strokePath) +       (_,_,_,_) -> r >> 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+-- | Perform a rendering operation with a local style.+withStyle'     :: Style R2    -- ^ Style to use+               -> Transformation R2  -- ^ Transformation to be applied to the style+               -> Transformation R2 -- ^ Transformation that was applied to the diagram+               -> Render Pdf R2 -- ^ Rendering operation to run+               -> Render Pdf R2 -- ^ Rendering operation using the style locally+withStyle' s t td (D r) = D $ do     withContext $ do        pdfMiscStyle s        mf <- mustFill@@ -321,38 +294,50 @@           pdfFrozenStyle s           when (mf || ms) $ do              withPdfOpacity s $ do-               r-               strokeOrFill+               strokeOrFill (td) r +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) = withStyle' s t mempty (D r)+   doRender _ _ (D r) = setTranform (runDS r)    renderDia Pdf opts d =-    centerAndScale opts d . doRender Pdf opts' . mconcat . map renderOne . prims $ d'+    centerAndScale 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))+              = withStyle' s mempty t (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+              = withStyle' s t1 t2 (render Pdf (transform t2 p))+            centerAndScale 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+                                    --ps = max (abs (xb - xa)) (abs (yb - ya))+                                    sx = w / (abs (xb - xa))+                                    sy = h / abs (yb - ya)+                                    s = min sx sy                                     pageCenter = (w / 2.0) P.:+ (h/2.0)                                 in                                 do                                   P.applyMatrix (P.translate pageCenter) -                                  P.applyMatrix (P.scale sx sy)+                                  P.applyMatrix (P.scale s s)                                   P.applyMatrix (P.translate $ (-vx) P.:+ (-vy))                     rescaledD Nothing = return ()                 rescaledD (getCorners bd)@@ -431,11 +416,34 @@   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)+pdfStrokeColor c = do+  drawM $ do+     let (r,g,b,a) = colorToSRGBA c+     P.setStrokeAlpha a+     P.strokeColor (Rgb r g b) +setShadingData :: Maybe PDFShading -> DrawS () +setShadingData sh = do +  StateStack s l <- S.get+  S.put $! StateStack (s {_shading = sh, _mustFill = _mustFill s || isJust sh}) l++setShading :: PdfShadingData -> DrawS ()+setShading (PdfAxialShadingData pa pb ca cb) = do +  let (ra,ga,ba,_) = colorToSRGBA ca+      (rb,gb,bb,_) = colorToSRGBA cb +      colora = Rgb ra ga ba +      colorb = Rgb rb gb bb+      (xa,ya) = unp2 pa +      (xb,yb) = unp2 pb +  setShadingData $ Just (AxialShading xa ya xb yb colora colorb)+setShading (PdfRadialShadingData pa radiusa pb radiusb ca cb) = do +  let (ra,ga,ba,_) = colorToSRGBA ca+      (rb,gb,bb,_) = colorToSRGBA cb +      colora = Rgb ra ga ba +      colorb = Rgb rb gb bb+      (xa,ya) = unp2 pa +      (xb,yb) = unp2 pb +  setShadingData $ Just $ RadialShading xa ya radiusa xb yb radiusb colora colorb {-  Conversions between diagrams and HPDF types@@ -508,6 +516,7 @@                           , handle lColor                           , handle lFillRule                           , handle checklWidth+                          , handle shading                           ]   where handle :: AttributeClass a => (a -> DrawS ()) -> Maybe (DrawS ())         handle f = f `fmap` getAttr s@@ -518,6 +527,7 @@         lColor c = pdfStrokeColor . toAlphaColour . getLineColor $ c         fColor c = pdfFillColor . toAlphaColour . getFillColor $ c         lFillRule = setFillRule . getFillRule+        shading = setShading . getShadingData         checklWidth w = do            let d = getLineWidth w           setTrokeState d@@ -547,7 +557,16 @@ unP r = let (x,y) = unp2 r  in (x :+ y) +--showTrans :: Transformation R2 -> String +--showTrans t = show a1 ++ " " ++ show b1 ++ " " ++ show c1 ++ "\n" +++--              show a2 ++ " " ++ show b2 ++ " " ++ show c2 ++ "\n"+--   where (a1,a2) = unr2 $ apply t unitX+--         (b1,b2) = unr2 $ apply t unitY+--         (c1,c2) = unr2 $ transl t +--instance Show (Transformation R2) where +--  show = showTrans+ pdfTransf :: Transformation R2 -> DrawS () pdfTransf t = drawM $ applyMatrix (Matrix a1 a2 b1 b2 c1 c2)   where (a1,a2) = unr2 $ apply t unitX@@ -596,4 +615,228 @@               P.applyMatrix (P.translate (x' :+ y'))               P.drawText $ P.text theFont 0 0 (toPDFString str)             +{- +Rendering of specific HPDF primitives++-}++instance Renderable PdfTextBox Pdf where+  render _ (PdfTextBox t w h para) = D $ do+    withContext $ do+       pdfTransf t+       drawM (drawStringLabel w h para)++-- | Typeset a text with a given style in a suggested box.+-- The function is returning a diagram for the typeset text+-- and a diagram for the bounding box which may be smaller+-- than the suggested size : smaller width when the algorithm+-- has done some line justification. +-- The text may also be bigger than the suggested width in case+-- of overflow (similar to the way TeX is doing thing. There are+-- settings in HPDF to control the elegance of the line cuts but+-- those settings are not accessible from this simple API).+-- The text will not be longer than the suggested height. In that+-- case the additional text is not displayed.+genericPdfText :: (Renderable PdfTextBox Pdf,Renderable (Path R2) Pdf) +               => Bool -- ^ Suggested size +               -> TextOrigin+               -> Double -- ^ Suggested width+               -> Double -- ^ Suggested height+               -> AnyFormattedParagraph+               -> (Diagram Pdf R2,Diagram Pdf R2) -- ^ Text and bounding rect of the typeset text+genericPdfText suggested o w h formatted = +    let diag = mkQD (Prim (PdfTextBox mempty w h formatted))+                    (getEnvelope r)+                    (getTrace r)+                    mempty+                    (Query $ \p -> Any (isInsideEvenOdd p r))+        f v = (moveOriginTo v diag, moveOriginTo v textBounds)+    in+    case o of +            LeftSide -> f east +                  where +                    east = p2 (0,-hlinewrap / 2.0)+            RightSide -> f west +                  where +                    west = p2 (wlinewrap,-hlinewrap / 2.0)+            Center -> f theCenter+                  where +                    theCenter = p2 (wlinewrap / 2.0,-hlinewrap / 2.0)+            TopSide -> f topSide +                  where +                    topSide = p2 (wlinewrap / 2.0,0)+            BottomSide -> f bottomSide +                  where +                    bottomSide = p2 (wlinewrap / 2.0,-hlinewrap)+            TopLeftCorner -> f topLeft +                  where +                    topLeft = p2 (0,0)+            BottomLeftCorner -> f bottomLeft+                  where +                    bottomLeft = p2 (0,-hlinewrap )+            TopRightCorner -> f topRight+                  where +                    topRight = p2 (wlinewrap,0)+            BottomRightCorner -> f bottomRight+                  where +                    bottomRight = p2 (wlinewrap,-hlinewrap )+        +  where wlinewrap :: Double +        hlinewrap :: Double+        Rectangle (xa :+ ya) (xb :+ yb) | suggested = matchingContainerSize w h formatted+                                        | otherwise = Rectangle (0 :+ 0) (w :+ h)+        wlinewrap = xb - xa+        hlinewrap = yb - ya+   +        r :: Path R2+        r = rect wlinewrap hlinewrap # moveOriginTo (p2 (-wlinewrap / 2.0,hlinewrap / 2.0))+        textBounds :: Diagram Pdf R2+        textBounds = Sh.rect wlinewrap hlinewrap # moveOriginTo (p2 (-wlinewrap / 2.0,hlinewrap / 2.0))++-- | Typeset a text with a given style in a suggested box.+-- The function is returning a diagram for the text+-- and a diagram for the bounding box which may be smaller+-- than the suggested size : smaller width when the algorithm+-- has done some line justification. +-- The text may also be bigger than the suggested width in case+-- of overflow (similar to the way TeX is doing thing. There are+-- settings in HPDF to control the elegance of the line cuts but+-- those settings are not accessible from this simple API).+-- The text will not be longer than the suggested height. In that+-- case the additional text is not displayed except perhaps partially the last+-- line since no clipping is done.+pdfLabelWithSuggestedSize :: (Renderable PdfTextBox Pdf,Renderable (Path R2) Pdf) +                          => LabelStyle -- ^ Style of the label+                          -> String -- ^ String to display with this style+                          -> Double -- ^ Suggested width+                          -> Double -- ^ Suggested height+                          -> (Diagram Pdf R2,Diagram Pdf R2) -- ^ Text and bounding rect of the typeset text+pdfLabelWithSuggestedSize (LabelStyle fn fs j o fillc) s w h = +  let pdfColor (r,g,b,_) = P.Rgb r g b+      pdffc = pdfColor . colorToSRGBA . toAlphaColour $ fillc +  in+  genericPdfText True o w h $ (AFP NormalParagraph (P.Font (PDFFont fn fs) pdffc pdffc) $ do +    setJustification j+    paragraph $ do+        txt $ s)++-- | Similar to the @pdfLabelWithSuggestedSize@ but supporting the full features of HPDF+pdfTextWithSuggestedSize :: (ParagraphStyle ps s, P.Style s,Renderable PdfTextBox Pdf,Renderable (Path R2) Pdf) +                         => TextOrigin -- ^ Text origin+                         -> Double -- ^ Suggested width+                         -> Double -- ^ Suggested height+                         -> ps -- ^ Paragraph (vertical) style+                         -> s  -- ^ Horizontal style+                         -> TM ps s () -- ^ Text+                         -> (Diagram Pdf R2,Diagram Pdf R2) -- ^ Text and bounding rect of the typeset text+pdfTextWithSuggestedSize o w h ps hs tm = genericPdfText True o w h (AFP ps hs tm)++-- | Similar to the @pdfLabelWithSuggestedSize@ but here the size is forced and even+-- if the bounding box of the text is smaller it will not be taken into account+-- for the diagram envelope.+pdfLabelWithSize :: (Renderable PdfTextBox Pdf,Renderable (Path R2) Pdf) +                 => LabelStyle -- ^ Style of the label+                 -> String -- ^ String to display with this style+                 -> Double -- ^ Suggested width+                 -> Double -- ^ Suggested height+                 -> Diagram Pdf R2 -- ^ Text+pdfLabelWithSize (LabelStyle fn fs j o fillc) s w h = +  let pdfColor (r,g,b,_) = P.Rgb r g b+      pdffc = pdfColor . colorToSRGBA . toAlphaColour $ fillc +  in+  fst $ genericPdfText False o w h $ (AFP NormalParagraph (P.Font (PDFFont fn fs) pdffc pdffc) $ do +    setJustification j+    paragraph $ do+        txt $ s)++-- | Similar to @pdfTextWithSuggestedSize@ but the size if forced and not just suggested+pdfTextWithSize :: (ParagraphStyle ps s, P.Style s,Renderable PdfTextBox Pdf,Renderable (Path R2) Pdf) +                => TextOrigin -- ^ Text origin+                -> Double -- ^ Suggested width+                -> Double -- ^ Suggested height+                -> ps -- ^ Paragraph (vertical) style+                -> s  -- ^ Horizontal style+                -> TM ps s () -- ^ Text+                -> Diagram Pdf R2 -- ^ Text+pdfTextWithSize o w h ps hs tm = fst $ genericPdfText False o w h (AFP ps hs tm)++instance Renderable PdfImage Pdf where+  render _ (PdfImage t ref) = D $ do+    withContext $ do+       pdfTransf t+       drawM . drawXObject $ ref ++-- | Create an image diagram+pdfImage :: (Monad m, PDFGlobals m)+         => PDFReference PDFJpeg -- ^ Reference to the Jpeg image in the PDF resources+         -> m (Diagram Pdf R2)+pdfImage ref = do +    (w,h) <- P.bounds ref+    let r :: Path R2+        r = rect w h # moveOriginTo (p2 (-w/2, h/2.0))+        diag = mkQD (Prim (PdfImage mempty ref))+                    (getEnvelope r)+                    (getTrace r)+                    mempty+                    (Query $ \p -> Any (isInsideEvenOdd p r))+    return (diag # moveOriginTo (p2 (w/2.0,h/2.0)))++instance Renderable PdfURL Pdf where+  render _ (PdfURL t url w h) = D $ do+    withContext $ do+       pdfTransf t+       drawM $ do +        newAnnotation (URLLink (toPDFString "diagrams link") [0,0,w,h] url True)++-- | Create an URL diagram+pdfURL :: String -- ^ URL (in a next version it should be URI)+       -> Double -- ^ Width of active area+       -> Double -- ^ Height of active area+       -> Diagram Pdf R2 +pdfURL url w h = +  let r = rect w h # moveOriginTo (p2 (-w/2, h/2.0))+      diag = mkQD (Prim (PdfURL mempty url w h))+                    (getEnvelope r)+                    (getTrace r)+                    mempty+                    (Query $ \p -> Any (isInsideEvenOdd p r))+  in +  diag # moveOriginTo (p2 (w/2.0,h/2.0))+++-- To avoid an Orphan instance warning for Transformable PDFShading+newtype TransSh =TransSh {unTrans :: PDFShading}++type instance V TransSh = R2++instance Transformable TransSh where +    transform t (TransSh (AxialShading xa ya xb yb ca cb)) = TransSh $ AxialShading xa' ya' xb' yb' ca cb +      where +        (xa',ya') = unp2 . transform t $ p2 (xa,ya)+        (xb',yb') = unp2 . transform t $ p2 (xb,yb)+    transform t (TransSh (RadialShading xa ya ra xb yb rb ca cb)) = TransSh $ RadialShading xa' ya' ra xb' yb' rb ca cb +      where +        (xa',ya') = unp2 . transform t $ p2 (xa,ya)+        (xb',yb') = unp2 . transform t $ p2 (xb,yb)+       +{-++Paragraph shapes ++-}++{-    +data EnvelopedPara v = EnvelopedPara (Envelope R2) v++instance ComparableStyle v => ComparableStyle (EnvelopedPara v) where +  isSameStyleAs (EnvelopedPara _ va) (EnvelopedPara _ vb) = isSameStyleAs va vb ++instance (ComparableStyle v,P.Style s, ParagraphStyle v s) => ParagraphStyle (EnvelopedPara v) s where +   linePosition (EnvelopedPara _ v) = P.linePosition v+   lineWidth (EnvelopedPara _ v) = P.lineWidth v+   interline (EnvelopedPara _ v) = P.interline v+   paragraphChange (EnvelopedPara a v) i l = let (np,r) = P.paragraphChange v i l in (EnvelopedPara a np,r)+   paragraphStyle (EnvelopedPara _ v) = P.paragraphStyle v++-}

@@ -0,0 +1,168 @@+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+module Diagrams.Backend.Pdf.Specific(+      LabelStyle(..)+    , PdfTextBox(..)+    , drawStringLabel+    , getTextBoundingBox+    , TextOrigin(..)+    , LabelSize+    , PdfImage(..)+    , PdfURL(..)+    , PdfShadingData(..)+    , getShadingData+    , pdfAxialShading+    , pdfRadialShading+    , AnyFormattedParagraph(..)+    , CanBeFormatted(..)+    ) where ++import Graphics.PDF hiding(translate)+import qualified Graphics.PDF as P+import Diagrams.Prelude+import Data.Typeable++--import qualified Debug.Trace as T ++--debug a = T.trace (show a) a++data TextOrigin = Center +                | LeftSide +                | RightSide +                | TopSide +                | BottomSide +                | TopLeftCorner +                | TopRightCorner +                | BottomLeftCorner +                | BottomRightCorner +                deriving(Eq)++type LabelSize = Int++-- | Style for a label.+-- It is not considered as an attribute but as a different primitive+-- because internaly it is a complex text which can support several styles +-- in the same paragraph. +-- Label is just a convenience wrapper when the full features are not needed+data LabelStyle = LabelStyle FontName LabelSize Justification TextOrigin (Colour Double)++data PdfTextBox = PdfTextBox { _transform :: T2 +                             , _suggestedWidth :: Double +                             , _suggestedHeight :: Double +                             , _paragraph :: AnyFormattedParagraph+                             }++type instance V PdfTextBox = R2++instance Transformable PdfTextBox where+  transform t (PdfTextBox tt sw sh para) = PdfTextBox (t <> tt) sw sh para++instance IsPrim PdfTextBox++instance HasOrigin PdfTextBox where+  moveOriginTo p = translate (origin .-. p)++instance Renderable PdfTextBox NullBackend where+  render _ _ = mempty++data PdfImage = PdfImage T2 (PDFReference PDFJpeg)++type instance V PdfImage = R2++instance Transformable PdfImage where+  transform t (PdfImage tt ref) = PdfImage (t <> tt) ref++instance IsPrim PdfImage++instance HasOrigin PdfImage where+  moveOriginTo p = translate (origin .-. p)++instance Renderable PdfImage NullBackend where+  render _ _ = mempty++data PdfURL = PdfURL T2 String Double Double ++type instance V PdfURL = R2++instance Transformable PdfURL where+  transform t (PdfURL tt s w h) = PdfURL (t <> tt) s w h++instance IsPrim PdfURL++instance HasOrigin PdfURL where+  moveOriginTo p = translate (origin .-. p)++instance Renderable PdfURL NullBackend where+  render _ _ = mempty++drawStringLabel :: PDFFloat +                -> PDFFloat +                -> AnyFormattedParagraph+                -> Draw () +drawStringLabel w h para = typesetText w h para++data AnyFormattedParagraph = forall s ps. (ParagraphStyle ps s, P.Style s) => AFP ps s (TM ps s ())++class CanBeFormatted m where +  putIntoContainer :: Double -> Double -> m -> Draw ()+  matchingContainerSize :: Double -> Double -> m -> Rectangle++instance CanBeFormatted AnyFormattedParagraph where +  putIntoContainer w h (AFP ps p t) = +    let b = getBoxes ps p t+        sh = styleHeight p+        c = mkContainer 0 0 w h sh+        (d,_,_) = fillContainer (defaultVerState ps) c b+    in +    d+  matchingContainerSize w h (AFP ps p t) = +    let b = getBoxes ps p t+        sh = styleHeight p+        c = mkContainer 0 0 w h sh+        (_,c',_) = fillContainer (defaultVerState ps) c b+    in +    containerContentRectangle  c'++typesetText :: PDFFloat -- ^ width limit+            -> PDFFloat -- ^ height limit+            -> AnyFormattedParagraph+            -> P.Draw ()+typesetText w h para = putIntoContainer w h para++getTextBoundingBox :: PDFFloat -- ^ width limit+                   -> PDFFloat -- ^ height limit+                   -> AnyFormattedParagraph+                   -> Rectangle+getTextBoundingBox w h para  = matchingContainerSize w h para++data PdfShadingData = PdfAxialShadingData P2 P2 (Colour Double) (Colour Double) +                    | PdfRadialShadingData P2 Double P2 Double (Colour Double) (Colour Double) deriving (Show,Typeable)+newtype PdfShading = PdfShading (Last PdfShadingData) deriving (Typeable, Semigroup)++instance AttributeClass PdfShading++getShadingData :: PdfShading -> PdfShadingData+getShadingData (PdfShading (Last c)) = c++addshading :: (HasStyle a) => PdfShadingData -> a -> a+addshading s = applyAttr (PdfShading . Last $ s)+++-- | Define Axial shading for a diagram+pdfAxialShading :: HasStyle a => P2 -> P2 -> Colour Double -> Colour Double -> a -> a+pdfAxialShading pa pb ca cb = addshading (PdfAxialShadingData pa pb ca cb)++-- | Define Radial shading for a diagram+pdfRadialShading :: HasStyle a +                 => P2 -- ^ Center of inner circle+                 -> Double -- ^ Radius of inner circle+                 -> P2 -- ^ Center of outer circle+                 -> Double -- ^ Radius of outer circle+                 -> Colour Double -- ^ Inner colour+                 -> Colour Double -- ^ Outer colour+                 -> a -> a+pdfRadialShading pa ra pb rb ca cb = addshading (PdfRadialShadingData pa ra pb rb ca cb)

@@ -0,0 +1,11 @@+all:+	ghc -o mytest --make test.hs -package-db ../dist/package.conf.inplace ++clean:+	rm -f mytest +	rm -f *.o +	rm -f *.hi+	rm -f *.pdf++run:+	./mytest --compressed -o circle.pdf

binary file changed (absent → 2745 bytes)

@@ -0,0 +1,308 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+import Diagrams.Prelude+import Diagrams.Backend.Pdf+import Diagrams.Backend.Pdf.CmdLine+import Data.Colour (withOpacity)+import Graphics.PDF hiding(scale,red,green,blue,white,black,text,rotate,rect,stroke)+import qualified Diagrams.Backend.SVG.CmdLine as S+import qualified Diagrams.Example.Logo as L+import           Diagrams.Coordinates ((&))+import qualified Graphics.PDF.Typesetting as T+import qualified Graphics.PDF as P+import System.Random++pageWidth = 600 +pageHeight = 400 +titleH = 50++data MyParaStyles = Normal+                  | Bold+                  | Crazy+                  | SuperCrazy [Int] [PDFFloat]+                  | DebugStyle+                  | RedRectStyle+                  | BlueStyle+                  +instance ComparableStyle MyParaStyles where+  isSameStyleAs Normal Normal = True+  isSameStyleAs Bold Bold = True+  isSameStyleAs Crazy Crazy = True+  isSameStyleAs (SuperCrazy _ _) (SuperCrazy _ _) = True+  isSameStyleAs DebugStyle DebugStyle = True+  isSameStyleAs RedRectStyle RedRectStyle = True+  isSameStyleAs BlueStyle BlueStyle = True+  isSameStyleAs _ _ = False+  +                  +instance T.Style MyParaStyles where+    textStyle Normal = TextStyle (PDFFont Times_Roman 10) P.black P.black FillText 1.0 1.0 1.0 1.0+    textStyle Bold = TextStyle (PDFFont Times_Bold 12) P.black P.black FillText 1.0 1.0 1.0 1.0+    textStyle RedRectStyle = TextStyle (PDFFont Times_Roman 10) P.black P.black FillText 1.0 1.0 1.0 1.0+    textStyle DebugStyle = TextStyle (PDFFont Times_Roman 10) P.black P.black FillText 1.0 1.0 1.0 1.0+    textStyle Crazy = TextStyle (PDFFont Times_Roman 10) P.red P.red FillText 1.0 1.0 1.0 1.0+    textStyle (SuperCrazy _ _) = TextStyle (PDFFont Times_Roman 12) P.black P.black FillText 1.0 2.0 0.5 0.5+    textStyle BlueStyle = TextStyle (PDFFont Times_Roman 10) P.black P.black FillText 1.0 1.0 1.0 1.0+    +    sentenceStyle BlueStyle = Just $ \r d -> do+        P.fillColor $ Rgb 0.6 0.6 1+        P.strokeColor $ Rgb 0.6 0.6 1+        P.fillAndStroke r+        d+        return()+    +    sentenceStyle RedRectStyle = Just $ \r d -> do+        P.strokeColor P.red+        P.stroke r+        d+        return()+    sentenceStyle Crazy = Just $ \r d -> do+       d+       P.strokeColor P.blue+       P.stroke r+    sentenceStyle _ = Nothing+           +    wordStyle DebugStyle = Just $ \r m d ->+      case m of+          DrawWord -> d >> return ()+          DrawGlue -> d >> P.stroke r+    wordStyle Crazy = Just crazyWord+    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)+                            ]+            P.strokeColor P.red+            P.stroke p+            P.fillColor $ Rgb 0.8 1.0 0.8+            P.fill p+            withNewContext $ do+              --applyMatrix . rotate . Degree $ angle+              drawWord+            return ()++    wordStyle _ = Nothing+    +    updateStyle (SuperCrazy a b) = SuperCrazy (drop 8 a) (tail b)+    updateStyle a = a+    +    styleHeight r@(SuperCrazy _ _) = (getHeight . textFont . textStyle $ r) + 4.0+    styleHeight r = getHeight . textFont . textStyle $ r+    +    styleDescent r@(SuperCrazy _ _) = (getDescent . textFont . textStyle $ r) + 2+    styleDescent r = getDescent . textFont . textStyle $ r+    +crazyWord :: Rectangle -> StyleFunction -> Draw a -> Draw ()+crazyWord r@(Rectangle (xa :+ ya) (xb :+ yb)) DrawWord d = do+    P.fillColor $ Rgb 0.6 1 0.6 +    P.fill r+    d+    P.strokeColor $ Rgb 0 0 1+    let m = (ya+yb)/2.0+    P.stroke $ P.Line xa m xb m +crazyWord (Rectangle (xa :+ ya) (xb :+ yb)) DrawGlue _ = do+    P.fillColor $ Rgb 0 0 1+    P.fill (Circle ((xa+xb)/2.0) ((ya+yb)/2.0) ((xb-xa)/2.0))+    +   +    +superCrazy :: MyParaStyles+superCrazy = SuperCrazy (randomRs (0,32) (mkStdGen 0)) (randomRs (-10.0,10.0) (mkStdGen 10000))+    +data MyVertStyles = NormalPara+                  | CirclePara+                  | BluePara !PDFFloat++instance ComparableStyle MyVertStyles where+    isSameStyleAs NormalPara NormalPara = True+    isSameStyleAs CirclePara CirclePara = True+    isSameStyleAs (BluePara _) (BluePara _) = True+    isSameStyleAs _ _ = False+++instance ParagraphStyle MyVertStyles MyParaStyles  where+    lineWidth (BluePara a) w nb = (if nb > 3 then w else w-a) - 20.0+    lineWidth CirclePara _ 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))+    lineWidth _ w _ = w+           +    linePosition (BluePara a) _ nb = (if nb > 3 then 0.0 else a) + 10.0+    linePosition a@(CirclePara) w nb = max 0 ((w - P.lineWidth a w nb) / 2.0)+    linePosition _ _ _ = 0.0+    +    interline (BluePara _) = Just $ \r -> do+        P.fillColor $ Rgb 0.6 0.6 1+        P.strokeColor $ Rgb 0.6 0.6 1+        P.fillAndStroke r+    interline _ = Nothing+        +    paragraphChange (BluePara _) _ (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 $ P.translate ((-w') :+ (getDescent f - getHeight f + styleHeight st - styleDescent st))+                    P.fillColor $ Rgb 0.6 0.6 1+                    P.strokeColor $ Rgb 0.6 0.6 1+                    P.fillAndStroke $ charRect+                    P.fillColor P.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)+    +    paragraphChange s _ l = (s,l)+    +    paragraphStyle (BluePara _) = Just $ \(Rectangle (xa :+ ya) (xb :+ yb)) b -> do+        let f = Rectangle ((xa-3) :+ (ya-3)) ((xb+3) :+ (yb+3))+        P.fillColor $ Rgb 0.6 0.6 1+        P.fill f+        b+        P.strokeColor P.red+        P.stroke f+        return ()+    paragraphStyle _ = Nothing+ +standardStyleTest :: TM MyVertStyles MyParaStyles ()+standardStyleTest = do+    paragraph $ do+        txt $ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut "+        txt $ "labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris "+        setStyle Crazy+        txt $ "nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate "+        txt $ "velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non "+        txt $ "proident, sunt in culpa qui officia deserunt mollit anim id est laborum."+ ++complexText = +  centerXY (fst (pdfTextWithSuggestedSize Center 400 200 NormalPara Normal standardStyleTest) +    ===+    strutY 20 +    ===+    fst (pdfTextWithSuggestedSize Center 300 200 NormalPara Normal standardStyleTest) # rotate (20 :: Deg)+  )+  <> rect pageWidth (pageHeight - titleH)++t s x j = +    let (td, rd) = pdfLabelWithSuggestedSize (LabelStyle Times_Roman 12 j x blue) s 50 100 +    in +    td # showOrigin # lw 0.03  <> rd++tfs s x j = +    let td = pdfLabelWithSize (LabelStyle Times_Roman 12 j x blue) s 50 50 +    in +    td # showOrigin # lw 0.03 ++testpdfsuggestedtextsize = centerXY $ (centerXY squareText) <> rect pageWidth (pageHeight - titleH)+ where +  squareText = (t "Top Left" TopLeftCorner LeftJustification ||| t "Top" TopSide Centered ||| t "Top Right" TopRightCorner RightJustification)+               ===+               (t "Left" LeftSide LeftJustification ||| t "Center" Center Centered ||| t "Right" RightSide RightJustification)+               ===+               (t "Bottom Left" BottomLeftCorner LeftJustification ||| t "Bottom" BottomSide Centered ||| t "Bottom Right" BottomRightCorner RightJustification)+  +testpdftextsize = centerXY $ (centerXY squareText) <> rect pageWidth (pageHeight - titleH)+ where +  squareText = (tfs "Top Left" TopLeftCorner LeftJustification ||| tfs "Top" TopSide Centered ||| tfs "Top Right" TopRightCorner RightJustification)+               ===+               (tfs "Left" LeftSide LeftJustification ||| tfs "Center" Center Centered ||| tfs "Right" RightSide RightJustification)+               ===+               (tfs "Bottom Left" BottomLeftCorner LeftJustification ||| tfs "Bottom" BottomSide Centered ||| tfs "Bottom Right" BottomRightCorner RightJustification)+  ++ +testShading = +   let loopyStar = fc red+                 . mconcat . map (cubicSpline True)+                 . pathVertices+                 . star (StarSkip 3)+                 $ regPoly 7 1+       f z d = +        let s = 20+        in+        loopyStar # scale s # fillRule z # pdfAxialShading (p2 (-1,-1)) (p2 (1,1)) red green # rotate (d :: Deg)+   in   centerXY (hcat (map (f Winding) [0,20,40,60,80,100,120,140,160]))+        === centerXY (hcat (map (f EvenOdd) [0,20,40,60,80,100,120,140,160]))+        === square 40 # pdfRadialShading (p2 (0,0)) 5 (p2 (0,0)) 40 blue red++testImage img = +    let url = "http://www.alpheccar.org" +    in +       circle 100 +    <> mconcat (map (\r -> img # scale 0.5 # translateX 100 # rotate r) ([0,20..360] :: [Deg]))+    <> pdfURL url 100 20 +    <> fst (pdfLabelWithSuggestedSize (LabelStyle Times_Roman 12 Centered Center blue) url 150 40)++mkSection s sect = +    let (d,_) = pdfLabelWithSuggestedSize (LabelStyle Times_Roman 36 Centered Center blue) s pageWidth pageHeight +    in do+      page1 <- addPage Nothing+      drawWithPage page1 $ do+        renderDia Pdf (PdfOptions (Dims pageWidth pageHeight)) d+      sect++page s d = header s === content d + where +  header s = +    let (d,_) = pdfLabelWithSuggestedSize (LabelStyle Times_Roman 24 Centered Center black) s pageWidth titleH +    in +    d <> (rect pageWidth titleH # pdfAxialShading (p2 (-pageWidth/2,-titleH/2)) (p2 (pageWidth/2,titleH/2)) blue white)+  clipRect :: Path R2+  clipRect =  rect pageWidth (pageHeight - titleH) +  clipRectDiag :: Diagram Pdf R2 +  clipRectDiag = stroke clipRect+  content d = (clipRectDiag # lw 0 <> (centerXY d)) # clipBy clipRect # withEnvelope clipRectDiag+  ++mkPage :: String -> Diagram Pdf R2 -> PDF ()+mkPage s d = do +  page1 <- addPage Nothing+  drawWithPage page1 $ do+        renderDia Pdf (PdfOptions (Dims pageWidth pageHeight)) $ page s d++testShadeFroz = do+  page1 <- addPage Nothing+  drawWithPage page1 $ do+    renderDia Pdf (PdfOptions (Dims pageWidth pageHeight)) $ +        w +  where +    w :: Diagram Pdf R2 +    w = rect pageWidth (pageHeight - titleH) <> centerXY (+       square 100 # pdfAxialShading (p2 (-50,-50)) (p2 (50,50)) blue white+       ===+       square 100 # rotate (45 :: Deg) # freeze # pdfAxialShading (p2 (-50,-50)) (p2 (50,50)) blue white+    +        )++main = do+  Right jpgf <- readJpegFile "logo.jpg" +  let theDocRect = PDFRect 0 0 pageWidth pageHeight+  runPdf "demo.pdf" (standardDocInfo { author=toPDFString "alpheccar", compressed = False}) theDocRect $ do+      testShadeFroz+      --mkSection "HPDF Specific Primitives" $ do+      --     jpg <- createPDFJpeg jpgf+      --     image <- pdfImage jpg+      --     mkPage "Test JPEG and URL" (testImage image)+      --     mkPage "Test Shading" testShading+      --     mkPage "Test Suggested Text Container Size" testpdfsuggestedtextsize+      --     mkPage "Test Forced Text Container Size" testpdftextsize+      --     mkPage "Text Complex Text" complexText+--