HPDF 1.6.2 → 1.7

raw patch · 21 files changed

+1352/−453 lines, 21 filesdep ~arrayPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: array

API changes (from Hackage documentation)

Files

• Graphics/PDF.hs +35/−26
• Graphics/PDF/Action.hs +19/−20
• Graphics/PDF/Annotation.hs +17/−18
• Graphics/PDF/Colors.hs +49/−48
• Graphics/PDF/Coordinates.hs +1/−1
• Graphics/PDF/Document.hs +24/−10
• Graphics/PDF/Draw.hs +479/−120
• Graphics/PDF/Expression.hs +281/−0
• Graphics/PDF/Fonts/StandardFont.hs +5/−5
• Graphics/PDF/Fonts/Type1.hs +19/−20
• Graphics/PDF/Image.hs +35/−36
• Graphics/PDF/LowLevel/Types.hs +9/−2
• Graphics/PDF/Pattern.hs +55/−57
• Graphics/PDF/Resources.hs +6/−9
• Graphics/PDF/Shading.hs +62/−12
• Graphics/PDF/Shapes.hs +26/−26
• Graphics/PDF/Text.hs +26/−26
• Graphics/PDF/Transparency.hs +84/−0
• HPDF.cabal +4/−1
• Test/test.hs +114/−11
• changelog.md +2/−5

@@ -54,6 +54,19 @@   , module Graphics.PDF.Pattern   -- ** Shading   , module Graphics.PDF.Shading+  -- ** Transparency+  , module Graphics.PDF.Transparency+  , ColorSpace(..)+  , calculator1+  , calculator2+  , ColorFunction1(..)+  , ColorFunction2(..)+  , Function1(..)+  , Function2(..)+  , Global+  , Local+  , linearStitched+  , FunctionObject   -- ** Fonts   , module Graphics.PDF.Fonts.Font    , module Graphics.PDF.Fonts.StandardFont@@ -69,12 +82,12 @@ #endif   import Graphics.PDF.Typesetting+import Graphics.PDF.Transparency import Graphics.PDF.Shading import Graphics.PDF.Pattern import Graphics.PDF.Navigation import Graphics.PDF.Text import qualified Data.IntMap as IM-import qualified Data.Map.Strict as M import qualified Data.ByteString.Lazy as B import Data.Int import Text.Printf(printf)@@ -86,14 +99,15 @@ import Graphics.PDF.Shapes import Graphics.PDF.Coordinates import Graphics.PDF.Pages-import Graphics.PDF.Document+import Graphics.PDF.Document hiding (createPDFXFormExtra) import Codec.Compression.Zlib import Graphics.PDF.Action import Graphics.PDF.Image import Graphics.PDF.Resources(emptyResource) import Data.Binary.Builder(Builder,fromLazyByteString, toLazyByteString) import Graphics.PDF.LowLevel.Serializer-import Data.List(unfoldr)+import Data.List(mapAccumL)+import Data.Maybe(fromMaybe) import qualified Data.Text as T import Graphics.PDF.Fonts.Font  import Graphics.PDF.Fonts.StandardFont@@ -143,7 +157,7 @@          case p of              -- Not linked to a page              Nothing -> do                  -                  return $ (otherRsrcs state') `pdfDictUnion` (PDFDictionary . M.fromList  $ [(PDFName "Resources",AnyPdfObject rsrcRef)])+                  return $ (otherRsrcs state') `pdfDictUnion` (dictFromList  $ [entry "Resources" rsrcRef])              -- Linked to a page              Just pageRef -> do                   setPageAnnotations (annots state') pageRef@@ -157,12 +171,12 @@        then do          let w''' = compress . toLazyByteString $ w'              w'' = fromLazyByteString w'''-         updateObject (PDFReference k :: PDFReference PDFStream) (PDFStream w'' True ref resources)-         updateObject ref (UnknownLength)+         updateObject (PDFReference k :: PDFReference PDFStream) (PDFStream w'' True (Left ref) resources)+         updateObject ref UnknownLength          --updateObject ref (PDFLength (B.length w'''))        else do-         updateObject (PDFReference k :: PDFReference PDFStream) (PDFStream w' False ref resources)-         updateObject ref (UnknownLength)+         updateObject (PDFReference k :: PDFReference PDFStream) (PDFStream w' False (Left ref) resources)+         updateObject ref UnknownLength          --updateObject ref (PDFLength (B.length . toLazyByteString $ w'))  -- | Save all the pages and streams in the main object dictionary@@ -192,15 +206,15 @@ #endif      instance PdfObject PDFTrailer where-   toPDF (PDFTrailer size root infos) = toPDF $ PDFDictionary. M.fromList $ -     [ (PDFName "Size",AnyPdfObject . PDFInteger $ size)-     , (PDFName "Root",AnyPdfObject root)-     , (PDFName "Info",AnyPdfObject . PDFDictionary . M.fromList $ allInfos)+   toPDF (PDFTrailer size root infos) = toPDF $ dictFromList $+     [ entry "Size" (PDFInteger $ size)+     , entry "Root" root+     , entry "Info" (dictFromList $ allInfos)      ]      where-      allInfos = [ (PDFName "Author",AnyPdfObject . toPDFString . author $ infos)-                 , (PDFName "Subject",AnyPdfObject . toPDFString . subject $ infos)-                 , (PDFName "Producer",AnyPdfObject $ toPDFString (T.pack "HPDF - The Haskell PDF Library" ))+      allInfos = [ entry "Author" (toPDFString . author $ infos)+                 , entry "Subject" (toPDFString . subject $ infos)+                 , entry "Producer" (toPDFString (T.pack "HPDF - The Haskell PDF Library" ))                  ]  instance PdfLengthInfo PDFTrailer where@@ -264,19 +278,14 @@           objectEncoding (x,a) = toPDF . PDFReferencedObject (fromIntegral $! x) $ a           (root,s) = flip runState pdfState  . unPDF $ createPDF >> m >> saveObjects           objs = objects s-          encodeAnObject (_,[]) = Nothing -          encodeAnObject (im,k:t) = +          encodeAnObject im k =             let Just o = IM.lookup k im-                result = do -                    (l,PDFReference ref) <- pdfLengthInfo o -                    let im' = IM.insert ref (AnyPdfObject (KnownLength (PDFLength l))) im-                    return im'-            in-            case result of -              Nothing -> Just (objectEncoding (k,o),(im,t)) -              Just im' ->  Just (objectEncoding (k,o),(im',t)) +                mim = do+                    (l, PDFReference ref) <- pdfLengthInfo o+                    return $ IM.insert ref (AnyPdfObject (KnownLength l)) im+            in (fromMaybe im mim, objectEncoding (k,o)) -          encodedObjects = unfoldr encodeAnObject (objs,IM.keys objs)+          encodedObjects = snd $ mapAccumL encodeAnObject objs (IM.keys objs)           objectContents = header : encodedObjects           (_nb, _len, _toc) = writeObjectsAndCreateToc objectContents       in

@@ -19,7 +19,6 @@  ) where       import Graphics.PDF.LowLevel.Types-import qualified Data.Map.Strict as M import Network.URI   @@ -37,17 +36,17 @@  --data Rendition = Rendition --instance PdfObject Rendition where---  toPDF a = toPDF . PDFDictionary . M.fromList $---                    [ (PDFName "Type",AnyPdfObject . PDFName $ "Rendition")---                    , (PDFName "S",AnyPdfObject . PDFName $ "MR")---                    , (PDFName "C",AnyPdfObject movie)+--  toPDF a = toPDF . dictFromList $+--                    [ entry "Type" (PDFName $ "Rendition")+--                    , entry "S" (PDFName $ "MR")+--                    , entry "C" movie --                    ] --    where---        movie = PDFDictionary . M.fromList $---               [ (PDFName "Type",AnyPdfObject . PDFName $ "MediaClip")---               , (PDFName "S",AnyPdfObject . PDFName $ "MCD")---               , (PDFName "CT",AnyPdfObject . toPDFString $ "video/3gpp")---               , (PDFName "D",AnyPdfObject (toPDFString "17.3gp"))+--        movie = dictFromList $+--               [ entry "Type" (PDFName $ "MediaClip")+--               , entry "S" (PDFName $ "MCD")+--               , entry "CT" (toPDFString $ "video/3gpp")+--               , entry "D" (toPDFString "17.3gp") --               ]  --  Action to control a media@@ -61,10 +60,10 @@   instance PdfObject GoToURL where-    toPDF (GoToURL s) = toPDF . PDFDictionary . M.fromList $-                         [ (PDFName "Type",AnyPdfObject . PDFName $ "Action")-                         , (PDFName "S",AnyPdfObject (PDFName "URI"))-                         , (PDFName "URI",AnyPdfObject (urlToPdfString s))+    toPDF (GoToURL s) = toPDF . dictFromList $+                         [ entry "Type" (PDFName $ "Action")+                         , entry "S" (PDFName "URI")+                         , entry "URI" (urlToPdfString s)                          ] instance Action GoToURL @@ -72,12 +71,12 @@   --instance PdfObject ControlMedia where---    toPDF (ControlMedia operation relatedScreenAnnotation rendition) = toPDF . PDFDictionary . M.fromList $---                         [ (PDFName "Type",AnyPdfObject . PDFName $ "Action")---                         , (PDFName "S",AnyPdfObject (PDFName "Rendition"))---                         , (PDFName "R",AnyPdfObject rendition)---                         , (PDFName "OP",AnyPdfObject . PDFInteger $ (fromEnum operation))---                         , (PDFName "AN",AnyPdfObject $ (PDFReference relatedScreenAnnotation :: PDFReference AnyPdfObject))+--    toPDF (ControlMedia operation relatedScreenAnnotation rendition) = toPDF . dictFromList $+--                         [ entry "Type" (PDFName $ "Action")+--                         , entry "S" (PDFName "Rendition")+--                         , entry "R" rendition+--                         , entry "OP" (PDFInteger $ fromEnum operation)+--                         , entry "AN" ((PDFReference relatedScreenAnnotation :: PDFReference AnyPdfObject)) --                         ] --                          --instance Action ControlMedia

@@ -24,7 +24,6 @@  import Graphics.PDF.LowLevel.Types import Graphics.PDF.Draw-import qualified Data.Map.Strict as M import Graphics.PDF.Action import Graphics.PDF.Pages import Control.Monad.State(gets)@@ -94,19 +93,19 @@ getBorder True = [0,0,1]  standardAnnotationDict :: AnnotationObject a => a -> [(PDFName,AnyPdfObject)]-standardAnnotationDict a = [(PDFName "Type",AnyPdfObject . PDFName $ "Annot")-                         , (PDFName "Subtype",AnyPdfObject $ annotationType a)-                         , (PDFName "Rect",AnyPdfObject . map AnyPdfObject $ annotationRect a)-                         , (PDFName "Contents",AnyPdfObject $ annotationContent a)+standardAnnotationDict a = [entry "Type" (PDFName $ "Annot")+                         , entry "Subtype" (annotationType a)+                         , entry "Rect" (annotationRect a)+                         , entry "Contents" (annotationContent a)                          ]  --instance PdfObject Screen where---   toPDF a@(Screen _ _ _ p play stop) = toPDF . PDFDictionary . M.fromList $ ---        standardAnnotationDict a ++ [(PDFName "P",AnyPdfObject p)]---                                    ++ (maybe [] (\x -> [(PDFName "A",AnyPdfObject x)]) play)---                                    ++ (maybe [] (\x -> [(PDFName "AA",AnyPdfObject $ otherActions x)]) stop)+--   toPDF a@(Screen _ _ _ p play stop) = toPDF . dictFromList $+--        standardAnnotationDict a ++ [entry "P" p]+--                                    ++ (maybe [] (\x -> [entry "A" x]) play)+--                                    ++ (maybe [] (\x -> [entry "AA" (otherActions x)]) stop) --         where---             otherActions x = PDFDictionary . M.fromList $ [(PDFName "D",AnyPdfObject x)]+--             otherActions x = dictFromList $ [entry "D" x] -- --instance AnnotationObject Screen where --  addAnnotation (Screen video s rect p _ _) = do@@ -120,8 +119,8 @@ --  annotationRect (Screen _ _ r _ _ _) = r                               instance PdfObject TextAnnotation where-      toPDF a@(TextAnnotation _ _ i) = toPDF . PDFDictionary . M.fromList $ -           standardAnnotationDict a ++ [(PDFName "Name",AnyPdfObject . PDFName $ show i)]+      toPDF a@(TextAnnotation _ _ i) = toPDF . dictFromList $+           standardAnnotationDict a ++ [entry "Name" (PDFName $ show i)]  instance PdfLengthInfo TextAnnotation where @@ -135,10 +134,10 @@         return $ TextAnnotation a gr b      instance PdfObject URLLink where-    toPDF a@(URLLink _ _ url border) = toPDF . PDFDictionary . M.fromList $ +    toPDF a@(URLLink _ _ url border) = toPDF . dictFromList $            standardAnnotationDict a ++ -            [ (PDFName "A",AnyPdfObject (GoToURL url))-            , (PDFName "Border",AnyPdfObject . map AnyPdfObject $ (getBorder border))+            [ entry "A" (GoToURL url)+            , entry "Border" (getBorder border)             ]  instance PdfLengthInfo URLLink where@@ -153,10 +152,10 @@         return $ URLLink a gr b c          instance PdfObject PDFLink where-    toPDF a@(PDFLink _ _ page x y border) = toPDF . PDFDictionary . M.fromList $ +    toPDF a@(PDFLink _ _ page x y border) = toPDF . dictFromList $                standardAnnotationDict a ++ -                [(PDFName "Dest",AnyPdfObject dest)-                ,(PDFName "Border",AnyPdfObject . map AnyPdfObject $ (getBorder border))]+                [entry "Dest" dest+                ,entry "Border" (getBorder border)]      where          dest =  [ AnyPdfObject page                  , AnyPdfObject (PDFName "XYZ")

@@ -30,7 +30,6 @@       import Graphics.PDF.Draw import Graphics.PDF.LowLevel.Types-import Control.Monad.State(gets) import Graphics.PDF.Resources import Control.Monad.Writer import Graphics.PDF.LowLevel.Serializer@@ -55,24 +54,26 @@ -- | Set alpha value for transparency setStrokeAlpha :: Double -> Draw () setStrokeAlpha alpha = do-    alphaMap <- gets strokeAlphas-    (newName,newMap) <- setResource "ExtGState" (StrokeAlpha alpha) alphaMap-    modifyStrict $ \s -> s { strokeAlphas = newMap }-    tell . mconcat $ [ serialize "\n/" -                     , serialize newName-                     , serialize " gs"-                     ]-        +    newName <-+        registerResource "ExtGState"+            strokeAlphas (\newMap s -> s { strokeAlphas = newMap })+            (StrokeAlpha alpha)+    tell . mconcat $[ serialize "\n/" +                    , serialize newName+                    , serialize " gs"+                    ]+ -- | Set alpha value for transparency setFillAlpha :: Double -> Draw () setFillAlpha alpha = do-    alphaMap <- gets fillAlphas-    (newName,newMap) <- setResource "ExtGState" (FillAlpha alpha) alphaMap-    modifyStrict $ \s -> s { fillAlphas = newMap }-    tell . mconcat $ [ serialize "\n/" -                     , serialize newName-                     , serialize " gs"-                     ]+    newName <-+        registerResource "ExtGState"+            fillAlphas (\newMap s -> s { fillAlphas = newMap })+            (FillAlpha alpha)+    tell . mconcat $[ serialize "\n/" +                    , serialize newName+                    , serialize " gs"+                    ]      -- | Init the PDF color space to RGB. setRGBColorSpace :: Draw ()@@ -84,46 +85,46 @@ fillColor :: MonadPath m => Color -- ^ Filling color           -> m () fillColor (Rgb r g b) = do-    tell . mconcat $ [ serialize "\n"-                     , toPDF r-                     , serialize ' '-                     , toPDF g-                     , serialize ' '-                     , toPDF b-                     , serialize " rg" -                     ]+    tell . mconcat $[ serialize "\n"+                    , toPDF r+                    , serialize ' '+                    , toPDF g+                    , serialize ' '+                    , toPDF b+                    , serialize " rg" +                    ]                      fillColor (Hsv h s v) = do         let (r,g,b) = hsvToRgb (h,s,v)-        tell . mconcat $ [ serialize "\n"-                         , toPDF r-                         , serialize ' '-                         , toPDF g-                         , serialize ' '-                         , toPDF b-                         , serialize " rg" -                         ]+        tell . mconcat $[ serialize "\n"+                        , toPDF r+                        , serialize ' '+                        , toPDF g+                        , serialize ' '+                        , toPDF b+                        , serialize " rg" +                        ]  -- | Select the drawing color strokeColor :: MonadPath m => Color -- ^ Drawing color             -> m () strokeColor (Rgb r g b) = do-    tell . mconcat $ [ serialize "\n"-                     , toPDF r-                     , serialize ' '-                     , toPDF g-                     , serialize ' '-                     , toPDF b-                     , serialize " RG" -                     ]+    tell . mconcat $[ serialize "\n"+                    , toPDF r+                    , serialize ' '+                    , toPDF g+                    , serialize ' '+                    , toPDF b+                    , serialize " RG" +                    ] strokeColor (Hsv h s v) = do     let (r,g,b) = hsvToRgb (h,s,v)-    tell . mconcat $ [ serialize "\n"-                     , toPDF r-                     , serialize ' '-                     , toPDF g-                     , serialize ' '-                     , toPDF b-                     , serialize " RG" -                     ]+    tell . mconcat $[ serialize "\n"+                    , toPDF r+                    , serialize ' '+                    , toPDF g+                    , serialize ' '+                    , toPDF b+                    , serialize " RG" +                    ] 

@@ -71,7 +71,7 @@         data Matrix    = Matrix !PDFFloat !PDFFloat !PDFFloat !PDFFloat !PDFFloat !PDFFloat-   deriving (Eq, Show)+   deriving (Eq, Ord, Show)  instance Num Matrix where     --  Matrix addition

@@ -19,6 +19,7 @@  , addPageWithTransition  , drawWithPage  , createPDFXForm+ , createPDFXFormExtra  -- ** Page transitions  , PDFTransition(..)  , PDFTransStyle(..)@@ -49,10 +50,11 @@ import Graphics.PDF.LowLevel.Types import Graphics.PDF.Draw import Graphics.PDF.Pages+import Graphics.PDF.Shapes (Rectangle(Rectangle)) import Control.Monad.State import qualified Data.IntMap as IM-import qualified Data.Map.Strict as M import qualified Data.Text as T+import Data.Complex (Complex((:+)))  -- | No information for the document   standardDocInfo :: PDFDocumentInfo          @@ -65,15 +67,27 @@               -> PDFFloat -- ^ Top               -> Draw a -- ^ Drawing commands               -> PDF (PDFReference PDFXForm)-createPDFXForm xa ya xb yb d = let a' = do modifyStrict $ \s -> s  {otherRsrcs = PDFDictionary. M.fromList $ -                                                                       [ (PDFName "Type",AnyPdfObject . PDFName $ "XObject")-                                                                       , (PDFName "Subtype",AnyPdfObject . PDFName $ "Form")-                                                                       , (PDFName "FormType",AnyPdfObject . PDFInteger $ 1)-                                                                       , (PDFName "Matrix",AnyPdfObject . (map (AnyPdfObject . PDFInteger)) $ [1,0,0,1,0,0])-                                                                       , (PDFName "BBox",AnyPdfObject . (map AnyPdfObject) $ [xa,ya,xb,yb])-                                                                       ]-                                                                  }-                                           d+createPDFXForm xa ya xb yb d =+    createPDFXFormExtra (Rectangle (xa:+ya) (xb:+yb)) d emptyDictionary++-- | Create a PDF XObject+createPDFXFormExtra ::+                 Rectangle -- ^ Bounding Box+              -> Draw a -- ^ Drawing commands+              -> PDFDictionary+              -> PDF (PDFReference PDFXForm)+createPDFXFormExtra (Rectangle (xa:+ya) (xb:+yb)) d dict =+ let a' = do+            modifyStrict $ \s -> s {+                otherRsrcs = pdfDictUnion dict $ dictFromList $+                    [ entry "Type" (PDFName $ "XObject")+                    , entry "Subtype" (PDFName $ "Form")+                    , entry "FormType" (PDFInteger $ 1)+                    , entry "Matrix" (map PDFInteger $ [1,0,0,1,0,0])+                    , entry "BBox" (map AnyPdfObject $ [xa,ya,xb,yb])+                    ]+              }+            d  in do      PDFReference s <- createContent a' Nothing        recordBound s (xb-xa) (yb-ya)

@@ -1,10 +1,12 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-} --------------------------------------------------------- -- | -- Copyright   : (c) 2006-2016, alpheccar.org@@ -34,6 +36,7 @@ -- , writeCmd  , runDrawing  , setResource+ , registerResource  , emptyEnvironment  , PDFXForm  , PDFXObject(..)@@ -72,6 +75,26 @@  , AnyAnnotation(..)  , AnnotationStyle(..)  , PDFShading(..)+ , ColorSpace(..)+ , colorSpaceName+ , calculator1+ , calculator2+ , ColorFunction1(..)+ , ColorFunction2(..)+ , Function1(..)+ , Function2(..)+ , Global+ , Local+ , linearStitched+ , FunctionObject(FunctionObject, FunctionStream)+ , rsrcFromCalculator+ , rsrcFromInterpolated+ , rsrcFromSampled+ , rsrcFromStitched+ , ColorTuple+ , domain1Dict+ , domain2Dict+ , SoftMask(..)  , getRgbColor  , emptyDrawState  , Matrix(..)@@ -81,8 +104,7 @@  , multiplyCurrentMatrixWith  , PDFGlobals(..)  ) where- -import Data.Maybe+ #if !MIN_VERSION_base(4,8,0) import Data.Monoid #endif@@ -91,6 +113,9 @@ import qualified Data.IntMap as IM import qualified Data.Binary.Builder as BU import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Lazy.Char8 as C+import qualified Data.Array as Array+import Data.Array (Array)  import Control.Monad.ST import Data.STRef@@ -99,6 +124,8 @@ import Control.Monad.Reader.Class import Control.Monad.State +import qualified Graphics.PDF.Expression as Expr+import Graphics.PDF.Expression (PDFExpression) import Graphics.PDF.Coordinates import Graphics.PDF.LowLevel.Types import Graphics.PDF.LowLevel.Serializer@@ -107,6 +134,8 @@ import qualified Data.Text as T import Graphics.PDF.Fonts.Font(PDFFont(..)) +import Text.Printf (printf)+ data AnnotationStyle = AnnotationStyle !(Maybe Color)  class AnnotationObject a where@@ -149,6 +178,7 @@                 ,  patterns :: M.Map (PDFReference AnyPdfPattern) String                 ,  colorSpaces :: M.Map PDFColorSpace String                 ,  shadings :: M.Map PDFShading String+                ,  softMasks :: M.Map SoftMask String                 ,  matrix :: [Matrix]                 } data DrawEnvironment = DrawEnvironment {@@ -184,6 +214,7 @@     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)@@ -221,8 +252,13 @@ modifyDrawST f g = Draw $ \env -> modifySTRef (f env) g  -- | A PDF stream object-data PDFStream = PDFStream !BU.Builder !Bool !(PDFReference MaybeLength) !PDFDictionary-                                   +data PDFStream =+    PDFStream+        !BU.Builder+        !Bool+        !(Either (PDFReference MaybeLength) PDFLength)+        !PDFDictionary+ instance PdfObject PDFStream where   toPDF (PDFStream s c l d) =        mconcat   $ [ toPDF dict@@ -233,13 +269,17 @@                   , 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+      compressedStream True = if not (pdfDictMember (PDFName "Filter") d) then [entry "Filter" [PDFName $ "FlateDecode"]] else []+      lenDict = dictFromList $ [either (entry "Length") (entry "Length") l] ++ compressedStream c       dict = pdfDictUnion lenDict d  instance PdfLengthInfo PDFStream where -  pdfLengthInfo (PDFStream s _ l _) = Just (B.length . BU.toLazyByteString $ s,l)-    +  pdfLengthInfo (PDFStream s _ el _) =+      either+        (\ref -> Just (PDFLength . B.length . BU.toLazyByteString $ s, ref))+        (const Nothing)+        el+ -- | An empty drawing emptyDrawing :: Draw () emptyDrawing = return ()@@ -258,7 +298,7 @@ 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]+    DrawState names emptyRsrc M.empty M.empty M.empty M.empty emptyDictionary []  M.empty 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)@@ -317,6 +357,20 @@              return (newName,M.insert values newName oldCache)         Just n -> return (n,oldCache) +-- ToDo: setter and getter could be replaced by an Accessor or a Lens+registerResource ::+    (Ord a, PdfResourceObject a) =>+    String ->+    (DrawState -> M.Map a String) ->+    (M.Map a String -> DrawState -> DrawState) ->+    a -> Draw String+registerResource dict getMap setMap resource = do+    oldMap <- gets getMap+    (newName,newMap) <- setResource dict resource oldMap+    modifyStrict $ setMap newMap+    return newName++ instance PDFGlobals Draw where     bounds (PDFReference r) = getBoundInDraw r     @@ -329,9 +383,10 @@          privateDrawXObject :: PDFReference a -> Draw ()     privateDrawXObject (PDFReference r) = do-        xobjectMap <- gets xobjects-        (newName,newMap) <- setResource "XObject" (PDFReference r) xobjectMap-        modifyStrict $ \s -> s { xobjects = newMap }+        newName <-+            registerResource "XObject"+                xobjects (\newMap s -> s { xobjects = newMap })+                (PDFReference r)         tell . mconcat  $ [ serialize "\n/"                            , serialize newName                           , serialize " Do"@@ -519,10 +574,10 @@ 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)+ toPDF (PDFOutline first lasto) = toPDF $ dictFromList $ [+    entry "Type" (PDFName $ "Outlines")+  , entry "First" first+  , entry "Last" lasto   ]  instance PdfLengthInfo PDFOutline where@@ -561,14 +616,14 @@ 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)+  toPDF (PDFViewerPreferences ht hm hwui fw cw ddt nfspm ) = toPDF $ dictFromList $+   [ entry "HideToolbar" ht+   , entry "HideMenubar" hm+   , entry "HideWindowUI" hwui+   , entry "FitWindow" fw+   , entry "CenterWindow" cw+   , entry "DisplayDocTitle" ddt+   , entry "NonFullScreenPageMode" (PDFName . show $ nfspm)    ]  instance PdfLengthInfo PDFViewerPreferences where@@ -583,20 +638,20 @@    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)+ toPDF (PDFTransition d t) = toPDF $ dictFromList $+   [ entry "Type" (PDFName "Trans")+   , entry "S" (PDFName (show t))+   , entry "D" 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 (Split a _) = [ entry "Dm" (PDFName (show a))]+    optionalDm (Blinds a) = [ entry "Dm" (PDFName (show a))]     optionalDm _ = []-    optionalM (Split _ a) = [ (PDFName "M",AnyPdfObject (PDFName (show a)))]-    optionalM (Box a) = [ (PDFName "M",AnyPdfObject (PDFName (show a)))]+    optionalM (Split _ a) = [ entry "M" (PDFName (show a))]+    optionalM (Box a) = [ entry "M" (PDFName (show a))]     optionalM _ = []    -    optionalDi (Wipe a) = [ (PDFName "Di",AnyPdfObject (floatDirection a))]-    optionalDi (Glitter a)  = [ (PDFName "Di",AnyPdfObject (floatDirection a))]+    optionalDi (Wipe a) = [ entry "Di" (floatDirection a)]+    optionalDi (Glitter a)  = [ entry "Di" (floatDirection a)]     optionalDi _ = []    instance PdfLengthInfo PDFTransition where@@ -604,35 +659,33 @@ -- 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)-  ] + toPDF (PDFPages c Nothing l) = toPDF $ dictFromList $+  [ entry "Type" (PDFName "Pages")+  , entry "Kids" l+  , entry "Count" (PDFInteger $ c)+  ]+ toPDF (PDFPages c (Just theParent) l) = toPDF $ dictFromList $+  [ entry "Type" (PDFName "Pages")+  , entry "Parent" theParent+  , entry "Kids" l+  , entry "Count" (PDFInteger $ c)+  ]  instance PdfLengthInfo PDFPages where   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 (Just theParent) box content theRsrc d t theAnnots) = toPDF $ dictFromList $+  [ entry "Type" (PDFName "Page")+  , entry "Parent" theParent+  , entry "MediaBox" box+  , entry "Contents" content+  , case theRsrc of+      Just res -> entry "Resources" res+      Nothing -> entry "Resources" emptyDictionary+  ] ++ (maybe [] (\x -> [entry "Dur" x]) d)+  ++ (maybe [] (\x -> [entry "Trans" x]) t)+  ++ ((\x -> if null x then [] else [entry "Annots" x]) theAnnots)  toPDF (PDFPage Nothing _ _ _ _ _ _) = noPdfObject  instance PdfLengthInfo PDFPage where@@ -640,13 +693,13 @@ -- 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)+ toPDF (PDFCatalog outlines lPages pgMode pgLayout viewerPrefs) = toPDF $ dictFromList $+   [ entry "Type" (PDFName "Catalog")+   , entry "Pages" lPages+   , entry "PageMode" (PDFName . show $ pgMode)+   , entry "PageLayout" (PDFName . show $ pgLayout)+   , entry "ViewerPreferences" viewerPrefs+   ] ++ (maybe [] (\x -> [entry "Outlines" x]) outlines)  instance PdfLengthInfo PDFCatalog where @@ -659,23 +712,23 @@  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)+     toPDF $ dictFromList $ [+        entry "Title" title+        , entry "Parent" theParent         ]       ++-      maybe [] (\x -> [(PDFName "Prev",AnyPdfObject x)]) prev+      maybe [] (\x -> [entry "Prev" x]) prev       ++-      maybe [] (\x -> [(PDFName "Next",AnyPdfObject x)]) next+      maybe [] (\x -> [entry "Next" x]) next       ++-      maybe [] (\x -> [(PDFName "First",AnyPdfObject x)]) first+      maybe [] (\x -> [entry "First" x]) first       ++-      maybe [] (\x -> [(PDFName "Last",AnyPdfObject x)]) theLast+      maybe [] (\x -> [entry "Last" x]) theLast       ++-      [ (PDFName "Count",AnyPdfObject (PDFInteger count))-      , (PDFName "Dest",AnyPdfObject dest)-      , (PDFName "C",AnyPdfObject color)-      , (PDFName "F",AnyPdfObject style)+      [ entry "Count" (PDFInteger count)+      , entry "Dest" dest+      , entry "C" color+      , entry "F" style       ]  instance PdfLengthInfo PDFOutlineEntry where@@ -690,9 +743,9 @@                                                 instance PdfObject Color where-   toPDF (Rgb r g b) = toPDF . map AnyPdfObject $ [r,g,b]  +   toPDF (Rgb r g b) = toPDF [r,g,b]    toPDF (Hsv h s v) = let (r,g,b) = hsvToRgb (h,s,v)-    in toPDF . map AnyPdfObject $ [r,g,b]+    in toPDF [r,g,b]  instance PdfLengthInfo Color where @@ -725,57 +778,363 @@ 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)   +type FloatRGB  = (PDFFloat, PDFFloat, PDFFloat)+type FloatCMYK = (PDFFloat, PDFFloat, PDFFloat, PDFFloat)++class ColorTuple a where+    rgbHex :: a -> String+    colorComponents :: a -> [PDFFloat]+    colorDimensions :: f a e -> Int++instance ColorTuple PDFFloat where+    rgbHex c = printf "%02X" (byteFromFloat c)+    colorComponents c = [c]+    colorDimensions _ = 1++instance (a ~ PDFFloat, b ~ PDFFloat, c ~ PDFFloat) => ColorTuple (a,b,c) where+    rgbHex (r,g,b) =+        printf "%02X%02X%02X"+            (byteFromFloat r) (byteFromFloat g) (byteFromFloat b)+    colorComponents (r,g,b) = [r,g,b]+    colorDimensions _ = 3++instance+    (a ~ PDFFloat, b ~ PDFFloat, c ~ PDFFloat, d ~ PDFFloat) =>+        ColorTuple (a,b,c,d) where+    rgbHex (c,m,y,k) =+        printf "%02X%02X%02X%02X"+            (byteFromFloat c) (byteFromFloat m)+            (byteFromFloat y) (byteFromFloat k)+    colorComponents (c,m,y,k) = [c,m,y,k]+    colorDimensions _ = 4++byteFromFloat :: PDFFloat -> Int+byteFromFloat x = round $ min 255 $ max 0 $ x*255++pdfStreamFromLazyByteString :: C.ByteString -> PDFDictionary -> PDFStream+pdfStreamFromLazyByteString stream dict =+    PDFStream+        (BU.fromLazyByteString stream)+        False+        (Right . PDFLength . B.length $ stream)+        dict++data FunctionObject a e =+      FunctionObject (PDFReference PDFDictionary)+    | FunctionStream (PDFReference PDFStream)+    deriving (Eq, Ord)++rsrcFromSampled ::+    (ColorTuple a) =>+    PDFDictionary ->+    ((i, i) -> [Int]) -> Array i a -> PDFStream+rsrcFromSampled domain computeSizes arr =+    pdfStreamFromLazyByteString+        ((C.pack $ concatMap rgbHex $ Array.elems arr)+            <>+            C.pack " >")+        (pdfDictUnion domain . dictFromList $+           [entry "FunctionType" (PDFInteger 0),+            entry "Size" (computeSizes $ Array.bounds arr),+            entry "BitsPerSample" (PDFInteger 8),+            entry "Filter" (PDFName "ASCIIHexDecode")+            ])+ -- | 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)+rsrcFromInterpolated ::+    (ColorTuple a) =>+    PDFDictionary -> PDFFloat -> a -> a -> PDFDictionary+rsrcFromInterpolated domain n a b =+    pdfDictUnion domain . dictFromList $+                            [ entry "FunctionType" (PDFInteger 2)+                            , entry "C0" (colorComponents a)+                            , entry "C1" (colorComponents b)+                            , entry "N" n                             ] --- | A shading                             -data PDFShading = AxialShading PDFFloat PDFFloat PDFFloat PDFFloat Color Color-                | RadialShading PDFFloat PDFFloat PDFFloat PDFFloat PDFFloat PDFFloat Color Color+rsrcFromStitched ::+    (ColorTuple a, Expr.Result e) =>+    PDFDictionary ->+    Function1 Local a e -> [(PDFFloat, Function1 Local a e)] -> PDFDictionary+rsrcFromStitched domain part parts =+    let funcs = part : map snd parts in+    pdfDictUnion domain . dictFromList $+        [ entry "FunctionType" (PDFInteger 3)+        , entry "Bounds" (map fst parts)+        , entry "Encode" (concatMap (const [0,1::Int]) funcs)+        , entry "Functions" (map toRsrc funcs)+        ]++rsrcFromCalculator ::+    (Expr.Function f) => PDFDictionary -> f -> PDFStream+rsrcFromCalculator domain f =+    pdfStreamFromLazyByteString+        (C.cons '{' $ C.snoc (Expr.serialize f) '}')+        (pdfDictUnion domain . dictFromList $+            [entry "FunctionType" (PDFInteger 4)])+++type ExprFloat = PDFExpression PDFFloat+type ExprRGB = (ExprFloat, ExprFloat, ExprFloat)+type ExprCMYK = (ExprFloat, ExprFloat, ExprFloat, ExprFloat)+++data ColorSpace a e where+    GraySpace :: ColorSpace PDFFloat ExprFloat+    RGBSpace :: ColorSpace FloatRGB ExprRGB+    CMYKSpace :: ColorSpace FloatCMYK ExprCMYK++deriving instance Eq (ColorSpace a e)+deriving instance Ord (ColorSpace a e)++colorSpaceName :: ColorSpace a e -> PDFName+colorSpaceName space =+    case space of+        GraySpace -> PDFName "DeviceGray"+        RGBSpace -> PDFName "DeviceRGB"+        CMYKSpace -> PDFName "DeviceCMYK"++colorSpaceEntry :: ColorSpace a e -> (PDFName, AnyPdfObject)+colorSpaceEntry space = entry "ColorSpace" $ colorSpaceName space++rangeEntry :: (ColorTuple a) => f a e -> (PDFName, AnyPdfObject)+rangeEntry func =+    entry "Range" $ concat $ replicate (colorDimensions func) [0,1::Int]+++data ColorFunction1 =+    forall a e.+    (ColorTuple a, Expr.Result e) =>+    ColorFunction1 (ColorSpace a e) (Function1 Local a e)++instance Eq ColorFunction1 where+    ColorFunction1 spaceA funcA == ColorFunction1 spaceB funcB  =+        case (spaceA, spaceB) of+            (GraySpace, GraySpace) -> funcA == funcB+            (RGBSpace, RGBSpace) -> funcA == funcB+            (CMYKSpace, CMYKSpace) -> funcA == funcB+            _ -> False++instance Ord ColorFunction1 where+    compare (ColorFunction1 spaceA funcA) (ColorFunction1 spaceB funcB) =+        case (spaceA, spaceB) of+            (GraySpace, GraySpace) -> compare funcA funcB+            (RGBSpace, RGBSpace) -> compare funcA funcB+            (CMYKSpace, CMYKSpace) -> compare funcA funcB+            (GraySpace, _) -> LT; (_, GraySpace) -> GT+            (RGBSpace,  _) -> LT; (_, RGBSpace)  -> GT+++data ColorFunction2 =+    forall a e.+    (ColorTuple a, Expr.Result e) =>+    ColorFunction2 (ColorSpace a e) (Function2 Local a e)++instance Eq ColorFunction2 where+    ColorFunction2 spaceA funcA == ColorFunction2 spaceB funcB  =+        case (spaceA, spaceB) of+            (GraySpace, GraySpace) -> funcA == funcB+            (RGBSpace, RGBSpace) -> funcA == funcB+            (CMYKSpace, CMYKSpace) -> funcA == funcB+            _ -> False++instance Ord ColorFunction2 where+    compare (ColorFunction2 spaceA funcA) (ColorFunction2 spaceB funcB) =+        case (spaceA, spaceB) of+            (GraySpace, GraySpace) -> compare funcA funcB+            (RGBSpace, RGBSpace) -> compare funcA funcB+            (CMYKSpace, CMYKSpace) -> compare funcA funcB+            (GraySpace, _) -> LT; (_, GraySpace) -> GT+            (RGBSpace,  _) -> LT; (_, RGBSpace)  -> GT+++data Global+data Local++data Function1 scope a e where+    GlobalFunction1 ::+        FunctionObject (PDFFloat -> a) (ExprFloat -> e) ->+        Function1 Local a e+    Sampled1 :: Array Int a -> Function1 Global a e+    Interpolated1 :: PDFFloat -> a -> a -> Function1 scope a e+    Stitched1 ::+        Function1 Local a e -> [(PDFFloat, Function1 Local a e)] ->+        Function1 scope a e+    Calculator1 :: (ExprFloat -> e) -> Function1 Global a e++instance+    (Local ~ scope, ColorTuple a, Eq a, Expr.Result e) =>+        Eq (Function1 scope a e) where+    a==b =+        case (a,b) of+            (GlobalFunction1 fa, GlobalFunction1 fb) -> fa == fb+            (Interpolated1 na xa ya, Interpolated1 nb xb yb) ->+                (na, xa, ya) == (nb, xb, yb)+            (Stitched1 partA partsA, Stitched1 partB partsB) ->+                (partA, partsA) == (partB, partsB)+            _ -> False++instance+    (Local ~ scope, ColorTuple a, Ord a, Expr.Result e) =>+        Ord (Function1 scope a e) where+    compare a b =+        case (a,b) of+            (GlobalFunction1 fa, GlobalFunction1 fb) -> compare fa fb+            (Interpolated1 na xa ya, Interpolated1 nb xb yb) ->+                compare (na, xa, ya) (nb, xb, yb)+            (Stitched1 partA partsA, Stitched1 partB partsB) ->+                compare (partA, partsA) (partB, partsB)+            (GlobalFunction1 _, _) -> LT+            (_, GlobalFunction1 _) -> GT+            (Interpolated1 _ _ _, _) -> LT+            (_, Interpolated1 _ _ _) -> GT+++-- ToDo: would be more type-safe with non-empty: NonEmpty (NonEmpty [])+mapAdjacent :: (a -> a -> b) -> [a] -> [b]+mapAdjacent f xs = zipWith f xs (tail xs)++linearStitched ::+    (ColorTuple a) => a -> [(PDFFloat, a)] -> a -> Function1 Local a e+linearStitched firstY nodes lastY =+    case mapAdjacent (Interpolated1 1)+            (firstY : map snd nodes ++ lastY : []) of+        [] -> error "list should be non-empty by construction"+        part:parts -> Stitched1 part (zip (map fst nodes) parts)++calculator1 :: (ExprFloat -> e) -> Function1 Global a e+calculator1 = Calculator1++domain1Dict :: (ColorTuple a) => f a e -> PDFDictionary+domain1Dict func =+    dictFromList [+        entry "Domain" [0,1::Int],+        rangeEntry func+    ]++instance+    (Local ~ scope, ColorTuple a, Expr.Result e) =>+        PdfResourceObject (Function1 scope a e) where+    toRsrc func =+        let domain = domain1Dict func in+        case func of+            GlobalFunction1 (FunctionObject obj) -> AnyPdfObject obj+            GlobalFunction1 (FunctionStream obj) -> AnyPdfObject obj+            Interpolated1 n x y ->+                AnyPdfObject $ rsrcFromInterpolated domain n x y+            Stitched1 part parts ->+                AnyPdfObject $ rsrcFromStitched domain part parts+++data Function2 scope a e where+    GlobalFunction2 ::+        FunctionObject+            (PDFFloat -> PDFFloat -> a) (ExprFloat -> ExprFloat -> e) ->+        Function2 Local a e+    Sampled2 :: (Array (Int,Int) a) -> Function2 Global a e+    Calculator2 :: (ExprFloat -> ExprFloat -> e) -> Function2 Global a e++instance+    (Local ~ scope, ColorTuple a, Eq a, Expr.Result e) =>+        Eq (Function2 scope a e) where+    a==b =+        case (a,b) of+            (GlobalFunction2 fa, GlobalFunction2 fb) -> fa == fb++instance+    (Local ~ scope, ColorTuple a, Ord a, Expr.Result e) =>+        Ord (Function2 scope a e) where+    compare a b =+        case (a,b) of+            (GlobalFunction2 fa, GlobalFunction2 fb) -> compare fa fb++calculator2 :: (ExprFloat -> ExprFloat -> e) -> Function2 Global a e+calculator2 = Calculator2++domain2Dict :: (ColorTuple a) => f a e -> PDFDictionary+domain2Dict func =+    dictFromList [+        entry "Domain" [0,1, 0,1::Int],+        rangeEntry func+    ]++instance+    (Local ~ scope, ColorTuple a, Expr.Result e) =>+        PdfResourceObject (Function2 scope a e) where+    toRsrc func =+        case func of+            GlobalFunction2 (FunctionObject obj) -> AnyPdfObject obj+            GlobalFunction2 (FunctionStream obj) -> AnyPdfObject obj+++-- | A shading+data PDFShading =+      FunctionalShading Matrix ColorFunction2+    | AxialShading PDFFloat PDFFloat PDFFloat PDFFloat ColorFunction1+    | RadialShading PDFFloat PDFFloat PDFFloat PDFFloat PDFFloat PDFFloat ColorFunction1                 deriving(Eq,Ord) +matrixCoefficients :: Matrix -> [PDFFloat]+matrixCoefficients (Matrix a b c d e f) = [a,b,c,d,e,f]+ 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])+      toRsrc (FunctionalShading mat (ColorFunction2 cs func)) =+          AnyPdfObject . dictFromList $+                                 [ entry "ShadingType" (PDFInteger $ 1)+                                 , entry "Matrix" (matrixCoefficients $ mat)+                                 , colorSpaceEntry cs+                                 , entry "Function" (toRsrc func)                                  ]-        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+      toRsrc (AxialShading x0 y0 x1 y1 (ColorFunction1 cs func)) =+          AnyPdfObject . dictFromList $+                                 [ entry "ShadingType" (PDFInteger $ 2)+                                 , entry "Coords" [x0,y0,x1,y1]+                                 , entry "Extend" [True, True]+                                 , colorSpaceEntry cs+                                 , entry "Function" (toRsrc func)+                                 ]+      toRsrc (RadialShading x0 y0 r0 x1 y1 r1 (ColorFunction1 cs func)) =+          AnyPdfObject . dictFromList $+                                 [ entry "ShadingType" (PDFInteger $ 3)+                                 , entry "Coords" [x0,y0,r0,x1,y1,r1]+                                 , entry "Extend" [True, True]+                                 , colorSpaceEntry cs+                                 , entry "Function" (toRsrc func)+                                 ]  +newtype SoftMask = SoftMask (PDFReference PDFXForm)+    deriving (Eq, Ord)++instance PdfResourceObject SoftMask where+    toRsrc (SoftMask ref) =+        AnyPdfObject $+        dictFromList $+            entry "Type" (PDFName "ExtGState") :+            entry "SMask"+                (dictFromList $+                    entry "Type" (PDFName "Mask") :+                    entry "S" (PDFName "Luminosity") :+                    entry "G" ref :+                    []) :+            []++ -- | 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"-                     ]+    tell . mconcat $[ serialize '\n'+                    , toPDF a+                    , serialize ' '+                    , toPDF b+                    , serialize ' '+                    , toPDF c+                    , serialize ' '+                    , toPDF d+                    , serialize ' '+                    , toPDF e+                    , serialize ' '+                    , toPDF f+                    , serialize " cm"+                    ]

@@ -0,0 +1,281 @@+---------------------------------------------------------+-- |+-- Copyright   : (c) 2023, Henning Thielemann+-- License     : BSD-style+--+-- Maintainer  : haskell@henning-thielemann.de+-- Stability   : experimental+-- Portability : portable+--+-- PDF expressions and functions+---------------------------------------------------------+module Graphics.PDF.Expression (+    PDFExpression (..),+    Function,+    Result,+    Argument,+    serialize,++    (==%), (/=%),+    (<%), (>=%), (>%), (<=%),+    min, max,+    true, false,+    (&&*), (||*), not,+    ifThenElse,++    sqrt,+    sinDeg, cosDeg, log, log10,+    pow, atan2Deg,++    floor, ceiling, round, truncate,+    ) where+     +import qualified Data.ByteString.Lazy.Char8 as CL+import qualified Data.ByteString.Char8 as C+import qualified Data.Ratio as Ratio++import qualified Control.Monad.Trans as MT+import qualified Control.Monad.RWS as MRWS+import qualified Control.Monad.Writer as MW+import qualified Control.Monad.State as MS+import Control.Monad (when)+import Control.Applicative (pure, liftA2, liftA3, (<*>))++import Prelude hiding+        (not, min, max, log, sqrt, floor, ceiling, round, truncate)+++data Token = Token C.ByteString | Index Int+    deriving (Show)++type ExprMonad = MRWS.RWS () [Token] Int++newtype PDFExpression a = PDFExpression (ExprMonad ())+++serialize :: (Function f) => f -> CL.ByteString+serialize f =+    CL.unwords $+    (\(n,_,stream) ->+        map (\token ->+                case token of+                    Token str -> CL.fromStrict str+                    Index k -> CL.pack $ show $ n-1+k) stream) $+    MRWS.runRWS+        (do+            n <- MS.execStateT (serializeFunction f) 0+            tokens $ replicate n "pop"+            return n)+        ()+        0+++class Function f where+    serializeFunction :: f -> MS.StateT Int ExprMonad ()++instance (Argument a, Function f) => Function (a -> f) where+    serializeFunction f = do+        arg <- argumentExpression+        serializeFunction $ f arg++instance Function (PDFExpression a) where+    serializeFunction = serializeResult++instance (Result a, Result b) => Function (a,b) where+    serializeFunction = serializeResult++instance (Result a, Result b, Result c) => Function (a,b,c) where+    serializeFunction = serializeResult++instance+    (Result a, Result b, Result c, Result d) =>+        Function (a,b,c,d) where+    serializeFunction = serializeResult+++{-+Extra class is needed in order+to forbid nested functions like (a -> (a, a->a))+-}+class (Function a) => Result a where+    serializeResult :: a -> MS.StateT Int ExprMonad ()++instance Result (PDFExpression a) where+    serializeResult (PDFExpression a) = do+        n <- MS.get+        MT.lift $ do+            a+            when (n>0) (tokens [show (n+1), "1", "roll"])+            MS.modify pred+            depth <- MS.get+            when (depth/=0) $ error "stack must be empty after evaluation"++instance (Result a, Result b) => Result (a,b) where+    serializeResult (a,b) =+        serializeResult a >> serializeResult b++instance (Result a, Result b, Result c) => Result (a,b,c) where+    serializeResult (a,b,c) =+        serializeResult a >> serializeResult b >> serializeResult c++instance+    (Result a, Result b, Result c, Result d) =>+        Result (a,b,c,d) where+    serializeResult (a,b,c,d) =+        serializeResult a >> serializeResult b >>+        serializeResult c >> serializeResult d++++class Argument a where+    argumentExpression :: (Monad m) => MS.StateT Int m a++instance Argument (PDFExpression a) where+    argumentExpression = MS.StateT $ \n -> pure (argument n, n+1)++instance (Argument a, Argument b) => Argument (a,b) where+    argumentExpression =+        liftA2 (,) argumentExpression argumentExpression++instance (Argument a, Argument b, Argument c) => Argument (a,b,c) where+    argumentExpression =+        liftA3 (,,) argumentExpression argumentExpression argumentExpression++instance+    (Argument a, Argument b, Argument c, Argument d) =>+        Argument (a,b,c,d) where+    argumentExpression =+        pure (,,,)+            <*> argumentExpression+            <*> argumentExpression+            <*> argumentExpression+            <*> argumentExpression+++tokens :: [String] -> ExprMonad ()+tokens = MW.tell . map (Token . C.pack)+++argument :: Int -> PDFExpression a+argument k = PDFExpression $ do+    depth <- MS.get+    MW.tell [Index (depth-k), Token $ C.pack "index"]+    MS.modify succ+++constant :: [String] -> PDFExpression b+constant ts =+    PDFExpression $ tokens ts >> MS.modify succ++function1 :: String -> PDFExpression a -> PDFExpression b+function1 name (PDFExpression a) =+    PDFExpression $ a >> tokens [name]++function2 :: String -> PDFExpression a -> PDFExpression b -> PDFExpression c+function2 name (PDFExpression a) (PDFExpression b) =+    PDFExpression $ a >> b >> tokens [name] >> MS.modify pred+++infix 4 ==%, /=%, <%, <=%, >%, >=%++(==%), (/=%) ::+   (Eq a) => PDFExpression a -> PDFExpression a -> PDFExpression Bool+(==%) = function2 "eq"+(/=%) = function2 "ne"++(<%), (>=%), (>%), (<=%) ::+   (Ord a) => PDFExpression a -> PDFExpression a -> PDFExpression Bool+(<%)  = function2 "lt"+(>=%) = function2 "ge"+(>%)  = function2 "gt"+(<=%) = function2 "le"+++minMax ::+    (Ord a) => String -> PDFExpression a -> PDFExpression a -> PDFExpression a+minMax cmp (PDFExpression a) (PDFExpression b) =+    PDFExpression $ do+        a+        b+        tokens ["2", "copy", cmp, "{1 pop}", "{exch 1 pop}", "ifelse"]+        MS.modify pred++min, max :: (Ord a) => PDFExpression a -> PDFExpression a -> PDFExpression a+min = minMax "lt"+max = minMax "gt"+++true, false :: PDFExpression Bool+true  = constant ["true"]+false = constant ["false"]++infixr 3 &&*+(&&*) :: PDFExpression Bool -> PDFExpression Bool -> PDFExpression Bool+(&&*) = function2 "and"++infixr 2 ||*+(||*) :: PDFExpression Bool -> PDFExpression Bool -> PDFExpression Bool+(||*) = function2 "or"++not :: PDFExpression Bool -> PDFExpression Bool+not = function1 "not"++++ifThenElse ::+    (Ord a) =>+    PDFExpression Bool -> PDFExpression a -> PDFExpression a -> PDFExpression a+ifThenElse (PDFExpression cond) (PDFExpression a) (PDFExpression b) =+    PDFExpression $ do+        cond+        tokens ["{"] >> a >> tokens ["}"]+        tokens ["{"] >> b >> tokens ["}"]+        tokens ["ifelse"]+        MS.modify pred+        MS.modify pred+++++instance (Num a) => Num (PDFExpression a) where+    fromInteger k = constant [show k]+    negate = function1 "negate"+    abs = function1 "abs"+    (+) = function2 "add"+    (-) = function2 "sub"+    (*) = function2 "mul"+    signum (PDFExpression a) =+        PDFExpression $ do+            a+            tokens ["dup", "0", "gt"]+            tokens   ["{", "pop", "1", "}"]+            tokens   ["{", "0", "lt", "{-1}", "{0}", "ifelse", "}"]+            tokens ["ifelse"]++instance (Fractional a) => Fractional (PDFExpression a) where+    fromRational r =+        constant [show (Ratio.numerator r), show (Ratio.denominator r), "div"]+    (/) = function2 "div"+++sqrt, sinDeg, cosDeg, log, log10 ::+    (Floating a) => PDFExpression a -> PDFExpression a+sqrt = function1 "sqrt"+sinDeg = function1 "sin"+cosDeg = function1 "cos"+log = function1 "ln"+log10 = function1 "log"++pow, atan2Deg ::+    (Floating a) => PDFExpression a -> PDFExpression a -> PDFExpression a+pow = function2 "exp"+atan2Deg = function2 "atan"++++floor, ceiling, round, truncate ::+    (RealFrac a) => PDFExpression a -> PDFExpression Int+floor    = function1 "floor"+ceiling  = function1 "ceiling"+round    = function1 "round"+truncate = function1 "truncate"

@@ -86,14 +86,14 @@ data StdFont = StdFont FontStructure deriving Show  instance PdfResourceObject StdFont where-   toRsrc (StdFont f) =  AnyPdfObject . PDFDictionary . M.fromList $-                           [(PDFName "Type",AnyPdfObject . PDFName $ "Font")-                           , (PDFName "Subtype",AnyPdfObject . PDFName $ "Type1")-                           , (PDFName "BaseFont",AnyPdfObject . PDFName $ baseFont f)+   toRsrc (StdFont f) =  AnyPdfObject . dictFromList $+                           [entry "Type" (PDFName $ "Font")+                           , entry "Subtype" (PDFName $ "Type1")+                           , entry "BaseFont" (PDFName $ baseFont f)                            ] ++ encoding'           where encoding' | baseFont f == show Symbol = []                            | baseFont f == show ZapfDingbats = []-                          | otherwise = [(PDFName "Encoding",AnyPdfObject . PDFName $ "MacRomanEncoding")]+                          | otherwise = [entry "Encoding" (PDFName $ "MacRomanEncoding")]  instance IsFont StdFont where    getDescent (StdFont fs) s = trueSize s $ descent fs 

@@ -67,14 +67,14 @@  instance PdfResourceObject Type1Font where    toRsrc (Type1Font f ref) =  -                AnyPdfObject . PDFDictionary . M.fromList $-                           [(PDFName "Type",AnyPdfObject . PDFName $ "Font")-                           , (PDFName "Subtype",AnyPdfObject . PDFName $ "Type1")-                           , (PDFName "BaseFont",AnyPdfObject . PDFName $ baseFont f)-                           , (PDFName "FirstChar",AnyPdfObject . PDFInteger $ (fromIntegral firstChar))-                           , (PDFName "LastChar",AnyPdfObject . PDFInteger $ (fromIntegral lastChar))-                           , (PDFName "Widths",AnyPdfObject  $ widths)-                           , (PDFName "FontDescriptor", AnyPdfObject descriptor)+                AnyPdfObject . dictFromList $+                           [entry "Type" (PDFName $ "Font")+                           , entry "Subtype" (PDFName $ "Type1")+                           , entry "BaseFont" (PDFName $ baseFont f)+                           , entry "FirstChar" (PDFInteger $ fromIntegral firstChar)+                           , entry "LastChar" (PDFInteger $ fromIntegral lastChar)+                           , entry "Widths" widths+                           , entry "FontDescriptor" descriptor                            ]            where              codes = map fst . M.toList $ widthData f@@ -82,16 +82,15 @@             lastChar = head . reverse . sort $ codes             findWidth c = PDFInteger . fromIntegral $ M.findWithDefault 0 c (widthData f)             widths = map findWidth [firstChar .. lastChar] -            bbox = map AnyPdfObject .fontBBox $ f -            descriptor = PDFDictionary . M.fromList $ -              [ (PDFName "Type",AnyPdfObject . PDFName $ "Font")-              , (PDFName "Subtype",AnyPdfObject . PDFName $ "Type1")-              , (PDFName "BaseFont",AnyPdfObject . PDFName $ baseFont f)-              , (PDFName "FontFile", AnyPdfObject ref)-              , (PDFName "Flags",AnyPdfObject . PDFInteger . fromIntegral . mkFlags $ f)-              , (PDFName "FontBBox",AnyPdfObject  $ bbox)-              , (PDFName "ItalicAngle",AnyPdfObject $ italicAngle f)-              , (PDFName "Ascent",AnyPdfObject . PDFInteger . fromIntegral $ ascent f)-              , (PDFName "Descent",AnyPdfObject . PDFInteger . fromIntegral $ descent f)-              , (PDFName "CapHeight",AnyPdfObject . PDFInteger . fromIntegral $ capHeight f)+            descriptor = dictFromList $+              [ entry "Type" (PDFName $ "Font")+              , entry "Subtype" (PDFName $ "Type1")+              , entry "BaseFont" (PDFName $ baseFont f)+              , entry "FontFile" ref+              , entry "Flags" (PDFInteger . fromIntegral . mkFlags $ f)+              , entry "FontBBox" (fontBBox f)+              , entry "ItalicAngle" (italicAngle f)+              , entry "Ascent" (PDFInteger . fromIntegral $ ascent f)+              , entry "Descent" (PDFInteger . fromIntegral $ descent f)+              , entry "CapHeight" (PDFInteger . fromIntegral $ capHeight f)                   ]

@@ -32,7 +32,6 @@  ) where       import Graphics.PDF.LowLevel.Types-import qualified Data.Map.Strict as M import Graphics.PDF.Draw import Graphics.PDF.Resources import Graphics.PDF.Pages@@ -331,21 +330,21 @@         return (PDFReference s)      where        color c = case c of-           1 -> [(PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceGray")]-           3 -> [(PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceRGB")]-           4 -> [(PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceCMYK")-                ,(PDFName "Decode",AnyPdfObject . map (AnyPdfObject . PDFInteger) $ [1,0,1,0,1,0,1,0])+           1 -> [entry "ColorSpace" (PDFName "DeviceGray")]+           3 -> [entry "ColorSpace" (PDFName "DeviceRGB")]+           4 -> [entry "ColorSpace" (PDFName "DeviceCMYK")+                ,entry "Decode" (map PDFInteger $ [1,0,1,0,1,0,1,0])                 ]            _ -> error "Jpeg color space not supported"        a' = -                 do modifyStrict $ \s -> s  {otherRsrcs = PDFDictionary. M.fromList $ -                                                   [ (PDFName "Type",AnyPdfObject . PDFName $ "XObject")-                                                   , (PDFName "Subtype",AnyPdfObject . PDFName $ "Image")-                                                   , (PDFName "Width",AnyPdfObject . PDFInteger $ width)-                                                   , (PDFName "Height",AnyPdfObject . PDFInteger $ height)-                                                   , (PDFName "BitsPerComponent",AnyPdfObject . PDFInteger $ bits_per_component)-                                                   , (PDFName "Interpolate", AnyPdfObject True)-                                                   , (PDFName "Filter",AnyPdfObject . PDFName $ "DCTDecode")+                 do modifyStrict $ \s -> s  {otherRsrcs = dictFromList $+                                                   [ entry "Type" (PDFName $ "XObject")+                                                   , entry "Subtype" (PDFName $ "Image")+                                                   , entry "Width" (PDFInteger $ width)+                                                   , entry "Height" (PDFInteger $ height)+                                                   , entry "BitsPerComponent" (PDFInteger $ bits_per_component)+                                                   , entry "Interpolate" True+                                                   , entry "Filter" (PDFName $ "DCTDecode")                                                    ] ++ color color_space                                              }                     tell img        @@ -363,23 +362,23 @@     where              getFilter = case pdfFilter of                      NoFilter -> []-                    ASCIIHexDecode -> [(PDFName "Filter",AnyPdfObject . PDFName $ "ASCIIHexDecode")]-                    ASCII85Decode -> [(PDFName "Filter",AnyPdfObject . PDFName $ "ASCII85Decode")]-                    LZWDecode -> [(PDFName "Filter",AnyPdfObject . PDFName $ "LZWDecode")]-                    FlateDecode -> [(PDFName "Filter",AnyPdfObject . PDFName $ "FlateDecode")]-                    RunLengthDecode -> [(PDFName "Filter",AnyPdfObject . PDFName $ "RunLengthDecode")]-                    CCITTFaxDecode -> [(PDFName "Filter",AnyPdfObject . PDFName $ "CCITTFaxDecode")]-                    DCTDecode -> [(PDFName "Filter",AnyPdfObject . PDFName $ "DCTDecode")]+                    ASCIIHexDecode -> [entry "Filter" (PDFName $ "ASCIIHexDecode")]+                    ASCII85Decode -> [entry "Filter" (PDFName $ "ASCII85Decode")]+                    LZWDecode -> [entry "Filter" (PDFName $ "LZWDecode")]+                    FlateDecode -> [entry "Filter" (PDFName $ "FlateDecode")]+                    RunLengthDecode -> [entry "Filter" (PDFName $ "RunLengthDecode")]+                    CCITTFaxDecode -> [entry "Filter" (PDFName $ "CCITTFaxDecode")]+                    DCTDecode -> [entry "Filter" (PDFName $ "DCTDecode")]          a' =  do -                modifyStrict $ \s -> s  {otherRsrcs = PDFDictionary. M.fromList $ -                                                   [ (PDFName "Type",AnyPdfObject . PDFName $ "XObject")-                                                   , (PDFName "Subtype",AnyPdfObject . PDFName $ "Image")-                                                   , (PDFName "Width",AnyPdfObject . PDFInteger $ width)-                                                   , (PDFName "Height",AnyPdfObject . PDFInteger $ height)-                                                   , (PDFName "BitsPerComponent",AnyPdfObject . PDFInteger $ 8)-                                                   , (PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceRGB")-                                                   , (PDFName "Interpolate", AnyPdfObject interpolate)+                modifyStrict $ \s -> s  {otherRsrcs = dictFromList $+                                                   [ entry "Type" (PDFName $ "XObject")+                                                   , entry "Subtype" (PDFName $ "Image")+                                                   , entry "Width" (PDFInteger $ width)+                                                   , entry "Height" (PDFInteger $ height)+                                                   , entry "BitsPerComponent" (PDFInteger $ 8)+                                                   , entry "ColorSpace" (PDFName "DeviceRGB")+                                                   , entry "Interpolate" interpolate                                                    ] ++ getFilter                                              }                 tell . fromLazyByteString $ stream@@ -403,14 +402,14 @@         addPixel [] = []                                  a' =  do -                modifyStrict $ \s -> s  {otherRsrcs = PDFDictionary. M.fromList $ -                                                   [ (PDFName "Type",AnyPdfObject . PDFName $ "XObject")-                                                   , (PDFName "Subtype",AnyPdfObject . PDFName $ "Image")-                                                   , (PDFName "Width",AnyPdfObject . PDFInteger $  width)-                                                   , (PDFName "Height",AnyPdfObject . PDFInteger $  height)-                                                   , (PDFName "BitsPerComponent",AnyPdfObject . PDFInteger $ 8)-                                                   , (PDFName "ColorSpace",AnyPdfObject $ PDFName "DeviceRGB")-                                                   , (PDFName "Interpolate", AnyPdfObject interpolate)+                modifyStrict $ \s -> s  {otherRsrcs = dictFromList $+                                                   [ entry "Type" (PDFName $ "XObject")+                                                   , entry "Subtype" (PDFName $ "Image")+                                                   , entry "Width" (PDFInteger $  width)+                                                   , entry "Height" (PDFInteger $  height)+                                                   , entry "BitsPerComponent" (PDFInteger $ 8)+                                                   , entry "ColorSpace" (PDFName "DeviceRGB")+                                                   , entry "Interpolate" interpolate                                                    ]                                              }                 tell . fromLazyByteString . B.pack . addPixel . U.toList $ stream  

@@ -21,7 +21,7 @@  import qualified Data.Map.Strict as M import Data.List(intersperse)-import Data.Int+import Data.Int(Int64) import Control.Monad.State import Control.Monad.Writer import Data.Binary.Builder(Builder,fromByteString)@@ -57,7 +57,7 @@   toPDF :: a -> Builder  class PdfLengthInfo a where -  pdfLengthInfo :: a -> Maybe (Int64 , PDFReference MaybeLength)+  pdfLengthInfo :: a -> Maybe (PDFLength , PDFReference MaybeLength)   pdfLengthInfo _ = Nothing  -- | Anonymous PDF object@@ -286,6 +286,10 @@  newtype PDFDictionary = PDFDictionary (M.Map PDFName AnyPdfObject) +entry ::+    (PdfObject a, PdfLengthInfo a) => String -> a -> (PDFName, AnyPdfObject)+entry name obj = (PDFName name, AnyPdfObject obj)+ instance PdfObject PDFDictionary where   toPDF (PDFDictionary a) = mconcat $ [blt,blt,newline]                                        ++ [convertLevel a]@@ -315,6 +319,9 @@  pdfDictUnion :: PDFDictionary -> PDFDictionary -> PDFDictionary pdfDictUnion (PDFDictionary a) (PDFDictionary b) = PDFDictionary $ M.union a b++dictFromList :: [(PDFName, AnyPdfObject)] -> PDFDictionary+dictFromList = PDFDictionary . M.fromList     -- | A PDF rectangle

@@ -26,7 +26,6 @@ import Graphics.PDF.LowLevel.Types import Graphics.PDF.Draw import Graphics.PDF.Resources-import qualified Data.Map.Strict as M import Graphics.PDF.Pages(recordBound,createContent) import Control.Monad.State import Control.Monad.Writer@@ -78,15 +77,15 @@                     -> Draw a -- ^ Drawing commands                     -> PDF Int createTilingPattern xa ya xb yb hstep vstep pt tt d = -    let a' = do modifyStrict $ \s -> s  {otherRsrcs = PDFDictionary. M.fromList $ -                                             [ (PDFName "Type",AnyPdfObject . PDFName $ "Pattern")-                                             , (PDFName "PatternType",AnyPdfObject . PDFInteger $ 1)-                                             , (PDFName "PaintType",AnyPdfObject . PDFInteger $ (fromEnum pt) + 1)-                                             , (PDFName "TilingType",AnyPdfObject . PDFInteger $ (fromEnum tt) + 1)-                                             , (PDFName "Matrix",AnyPdfObject . (map (AnyPdfObject . PDFInteger)) $ [1,0,0,1,0,0])-                                             , (PDFName "BBox",AnyPdfObject . map AnyPdfObject  $ [xa,ya,xb,yb])-                                             , (PDFName "XStep",AnyPdfObject hstep)-                                             , (PDFName "YStep",AnyPdfObject vstep)+    let a' = do modifyStrict $ \s -> s  {otherRsrcs = dictFromList $+                                             [ entry "Type" (PDFName $ "Pattern")+                                             , entry "PatternType" (PDFInteger $ 1)+                                             , entry "PaintType" (PDFInteger $ (fromEnum pt) + 1)+                                             , entry "TilingType" (PDFInteger $ (fromEnum tt) + 1)+                                             , entry "Matrix" (map PDFInteger $ [1,0,0,1,0,0])+                                             , entry "BBox" [xa,ya,xb,yb]+                                             , entry "XStep" hstep+                                             , entry "YStep" vstep                                              ]                                          }                 d@@ -94,72 +93,71 @@        PDFReference s <- createContent a' Nothing          recordBound s (xb-xa) (yb-ya)        return s-      -       +++registerPattern :: PDFReference s -> Draw String+registerPattern (PDFReference a) =+    registerResource "Pattern"+        patterns (\newMap s -> s { patterns = newMap })+        (PDFReference a)+ -- | Set the fill pattern setColoredFillPattern :: PDFReference PDFColoredPattern -> Draw ()-setColoredFillPattern (PDFReference a) = do-     patternMap <- gets patterns-     (newName,newMap) <- setResource "Pattern" (PDFReference a) patternMap-     modifyStrict $ \s -> s { patterns = newMap }-     tell . serialize $ ("\n/Pattern cs")-     tell . mconcat $ [ serialize "\n/" -                      , serialize newName-                      , serialize " scn"-                      ]+setColoredFillPattern ref = do+    newName <- registerPattern ref+    tell . serialize $ ("\n/Pattern cs")+    tell . mconcat $ [ serialize "\n/"+                     , serialize newName+                     , serialize " scn"+                     ]       -- | Set the stroke pattern setColoredStrokePattern :: PDFReference PDFColoredPattern -> Draw ()-setColoredStrokePattern (PDFReference a) = do-  patternMap <- gets patterns-  (newName,newMap) <- setResource "Pattern" (PDFReference a) patternMap-  modifyStrict $ \s -> s { patterns = newMap }-  tell . serialize $ ("\n/Pattern CS")-  tell . mconcat $ [ serialize "\n/" -                   , serialize newName-                   , serialize " SCN"-                   ]+setColoredStrokePattern ref = do+    newName <- registerPattern ref+    tell . serialize $ ("\n/Pattern CS")+    tell . mconcat $+                  [ serialize "\n/"+                  , serialize newName+                  , serialize " SCN"+                  ]        -- | Set the fill pattern setUncoloredFillPattern :: PDFReference PDFUncoloredPattern -> Color -> Draw ()-setUncoloredFillPattern (PDFReference a) col = do+setUncoloredFillPattern ref col = do        let (r,g,b) = getRgbColor col        colorMap <- gets colorSpaces        (newColorName,_) <- setResource "ColorSpace" PatternRGB colorMap-       patternMap <- gets patterns-       (newName,newMap) <- setResource "Pattern" (PDFReference a) patternMap-       modifyStrict $ \s -> s { patterns = newMap }-       tell . mconcat $ [ serialize "\n/" -                        , serialize newColorName-                        , serialize " cs"-                        ]-       tell . mconcat $ [ serialize '\n'-                        , toPDF r-                        , serialize ' '-                        , toPDF g-                        , serialize ' '-                        , toPDF b-                        , serialize ' '-                        , serialize " /"-                        , serialize newName-                        , serialize " scn"-                        ]+       newName <- registerPattern ref+       tell . mconcat $[ serialize "\n/"+                       , serialize newColorName+                       , serialize " cs"+                       ]+       tell . mconcat $[ serialize '\n'+                       , toPDF r+                       , serialize ' '+                       , toPDF g+                       , serialize ' '+                       , toPDF b+                       , serialize ' '+                       , serialize " /"+                       , serialize newName+                       , serialize " scn"+                       ]  -- | Set the stroke pattern setUncoloredStrokePattern :: PDFReference PDFUncoloredPattern -> Color -> Draw ()-setUncoloredStrokePattern (PDFReference a) col = do+setUncoloredStrokePattern ref col = do     let (r,g,b) = getRgbColor col     colorMap <- gets colorSpaces     (newColorName,_) <- setResource "ColorSpace" PatternRGB colorMap-    patternMap <- gets patterns-    (newName,newMap) <- setResource "Pattern" (PDFReference a) patternMap-    modifyStrict $ \s -> s { patterns = newMap }-    tell . mconcat $ [ serialize "\n/" -                     , serialize newColorName-                     , serialize " CS"-                     ]+    newName <- registerPattern ref+    tell . mconcat $[ serialize "\n/" +                    , serialize newColorName+                    , serialize " CS"+                    ]     tell . mconcat $   [ serialize '\n'                        , toPDF r                        , serialize ' '

@@ -35,11 +35,11 @@        newtype StrokeAlpha = StrokeAlpha Double deriving(Eq,Ord)   instance PdfResourceObject StrokeAlpha where-  toRsrc (StrokeAlpha a) = AnyPdfObject . PDFDictionary . M.fromList $ [(PDFName "CA",AnyPdfObject a)]+  toRsrc (StrokeAlpha a) = AnyPdfObject . dictFromList $ [entry "CA" a]    newtype FillAlpha = FillAlpha Double deriving(Eq,Ord)   instance PdfResourceObject FillAlpha where-  toRsrc (FillAlpha a) = AnyPdfObject . PDFDictionary . M.fromList $ [(PDFName "ca",AnyPdfObject a)]+  toRsrc (FillAlpha a) = AnyPdfObject . dictFromList $ [entry "ca" a]    class PdfResourceObject a where       toRsrc :: a -> AnyPdfObject@@ -56,9 +56,6 @@ --emptyRsrc = PDFResource [AnyPdfObject . PDFName $ "PDF"] (M.empty) emptyRsrc = PDFResource [] (M.empty)         -getResources :: M.Map PDFName PDFDictionary -> [(PDFName,AnyPdfObject)]-getResources = M.toList . M.map AnyPdfObject- instance PdfObject PDFResource where  toPDF r = toPDF . resourceToDict $ r      @@ -74,12 +71,12 @@                                        addValue (Nothing) = Just . PDFDictionary $ M.insert name newValue M.empty  in   r {resources = M.alter addValue dict (resources r)}-    + -- | Convert the resource to a PDf dictionary resourceToDict :: PDFResource -> PDFDictionary-resourceToDict r = PDFDictionary . M.fromList  $-    --[(PDFName "ProcSet",AnyPdfObject (procSet r))] ++-    getResources (resources r)+resourceToDict r = PDFDictionary $+    -- M.insert (PDFName "ProcSet") (AnyPdfObject (procSet r)) $+    M.map AnyPdfObject $ resources r      emptyResource :: PDFResource -> Bool emptyResource (PDFResource a b) = null a && M.null b 

@@ -1,3 +1,4 @@+{-# LANGUAGE GADTs #-} --------------------------------------------------------- -- | -- Copyright   : (c) 2006-2016, alpheccar.org@@ -15,25 +16,74 @@     PDFShading(..)   , paintWithShading   , applyShading+  , createFunction1Object+  , createFunction2Object  ) where-     -import Graphics.PDF.Draw-import Graphics.PDF.LowLevel.Types-import Control.Monad.State(gets)++import qualified Graphics.PDF.Expression as Expr+import Graphics.PDF.Draw as Draw+import Graphics.PDF.Pages(addObject) import Graphics.PDF.Shapes(setAsClipPath)+import Graphics.PDF.Expression(PDFExpression)+import Graphics.PDF.LowLevel.Serializer(serialize)+import Graphics.PDF.LowLevel.Types(PDFFloat)++import qualified Data.Array as Array+ import Control.Monad.Writer-import Graphics.PDF.LowLevel.Serializer ++type ExprFloat = PDFExpression PDFFloat++createFunction1Object ::+    (ColorTuple a, Expr.Result e) =>+    Function1 Global a e ->+    PDF (FunctionObject (PDFFloat -> a) (ExprFloat -> e))+createFunction1Object func =+    let domain = domain1Dict func in+    case func of+        Calculator1 f ->+            fmap FunctionStream $ addObject $+            Draw.rsrcFromCalculator domain f+        Interpolated1 n x y ->+            fmap FunctionObject $ addObject $+            Draw.rsrcFromInterpolated domain n x y+        Stitched1 part parts ->+            fmap FunctionObject $ addObject $+            Draw.rsrcFromStitched domain part parts+        Sampled1 arr ->+            fmap FunctionStream $ addObject $+            Draw.rsrcFromSampled domain (\bnds -> [Array.rangeSize bnds]) arr++createFunction2Object ::+    (ColorTuple a, Expr.Result e) =>+    Function2 Global a e ->+    PDF (FunctionObject+            (PDFFloat -> PDFFloat -> a) (ExprFloat -> ExprFloat -> e))+createFunction2Object func =+    let domain = domain2Dict func in+    fmap FunctionStream $ addObject $+    case func of+        Calculator2 f -> rsrcFromCalculator domain f+        Sampled2 arr ->+            rsrcFromSampled+                domain+                (\((lx,ly), (ux,uy)) ->+                    [Array.rangeSize (lx,ux), Array.rangeSize (ly,uy)])+                arr++ -- | Fill clipping region with a shading applyShading :: PDFShading -> Draw () applyShading shade = do-    shadingMap <- gets shadings-    (newName,newMap) <- setResource "Shading" shade shadingMap-    modifyStrict $ \s -> s { shadings = newMap }-    tell . mconcat $ [ serialize "\n/" -                     , serialize newName-                     , serialize " sh"-                     ]+    newName <-+        registerResource "Shading"+            shadings (\newMap s -> s { shadings = newMap })+            shade+    tell . mconcat $[ serialize "\n/" +                    , serialize newName+                    , serialize " sh"+                    ]      paintWithShading :: PDFShading -- ^ Shading                  -> Draw a -- ^ Shape to paint

@@ -151,17 +151,17 @@  -- | Set pen width setWidth :: MonadPath m => PDFFloat -> m ()-setWidth w = tell . mconcat $ [ serialize "\n" -                              , toPDF w-                              , serialize " w"-                              ]+setWidth w = tell . mconcat $[ serialize "\n" +                             , toPDF w+                             , serialize " w"+                             ]  -- | Set pen width setMiterLimit :: MonadPath m => PDFFloat -> m ()-setMiterLimit w = tell . mconcat $ [ serialize "\n" -                                   , toPDF w-                                   , serialize " M"-                                   ]+setMiterLimit w = tell . mconcat $[ serialize "\n" +                                  , toPDF w+                                  , serialize " M"+                                  ]  -- | Line cap styles data CapStyle = ButtCap@@ -177,29 +177,29 @@                              -- | Set line cap setLineCap :: MonadPath m => CapStyle -> m ()-setLineCap w = tell . mconcat $ [ serialize "\n " -                                , toPDF (fromEnum  w)-                                , serialize " J"-                                ]+setLineCap w = tell . mconcat $[ serialize "\n " +                               , toPDF (fromEnum  w)+                               , serialize " J"+                               ]  -- | Set line join setLineJoin :: MonadPath m => JoinStyle -> m ()-setLineJoin w = tell . mconcat $ [ serialize "\n " -                                 , toPDF (fromEnum  w)-                                 , serialize " j"-                                 ]+setLineJoin w = tell . mconcat $[ serialize "\n " +                                , toPDF (fromEnum  w)+                                , serialize " j"+                                ]  data DashPattern = DashPattern ![PDFFloat] PDFFloat deriving(Eq)  -- | Set the dash pattern setDash :: MonadPath m => DashPattern -> m() setDash (DashPattern a p) = -    tell . mconcat $ [ serialize "\n " -                     , toPDF a-                     , serialize ' '-                     , toPDF p-                     , serialize " d"-                     ]+    tell . mconcat$ [ serialize "\n " +                    , toPDF a+                    , serialize ' '+                    , toPDF p+                    , serialize " d"+                    ]  -- | No dash pattern setNoDash :: MonadPath m => m ()@@ -247,10 +247,10 @@ lineto :: Point         -> Draw ()  lineto a = do-    tell . mconcat $ [ serialize "\n" -                     , toPDF a-                     , serialize " l"-                     ]+    tell . mconcat $[ serialize "\n" +                    , toPDF a+                    , serialize " l"+                    ]     writeDrawST penPosition a  curveto :: Point -> Point -> Point -> Draw ()

@@ -118,12 +118,12 @@ setFont :: PDFFont -> PDFText () setFont f@(PDFFont n size) = PDFText $ do     lift (modifyStrict $ \s -> s {fontState = Set.insert n (fontState s), currentFont = Just f})-    tell . mconcat $ [ serialize "\n/" -                     , serialize (name n)-                     , serialize ' '-                     , toPDF size-                     , serialize " Tf"-                     ]+    tell . mconcat$ [ serialize "\n/" +                    , serialize (name n)+                    , serialize ' '+                    , toPDF size+                    , serialize " Tf"+                    ]                         -- | Draw a text in the draw monad@@ -144,12 +144,12 @@ textStart :: PDFFloat           -> PDFFloat           -> PDFText ()-textStart x y = tell . mconcat $ [ serialize '\n'-                                 , toPDF x-                                 , serialize ' '-                                 , toPDF y-                                 , serialize " Td"-                                 ]+textStart x y = tell . mconcat  $ [ serialize '\n'+                                  , toPDF x+                                  , serialize ' '+                                  , toPDF y+                                  , serialize " Td"+                                  ]  --writeCmd $ "\n" ++ (show x) ++ " " ++ (show y) ++ " Td"           @@ -251,20 +251,20 @@ -- | Set the text transformation matrix setTextMatrix :: Matrix -> PDFText() setTextMatrix (Matrix a b c d e f) = -    tell . mconcat $ [ serialize '\n'-                     , toPDF a-                     , serialize ' '-                     , toPDF b-                     , serialize ' '-                     , toPDF c-                     , serialize ' '-                     , toPDF d-                     , serialize ' '-                     , toPDF e-                     , serialize ' '-                     , toPDF f-                     , serialize " Tm"-                     ]+    tell . mconcat $[ serialize '\n'+                    , toPDF a+                    , serialize ' '+                    , toPDF b+                    , serialize ' '+                    , toPDF c+                    , serialize ' '+                    , toPDF d+                    , serialize ' '+                    , toPDF e+                    , serialize ' '+                    , toPDF f+                    , serialize " Tm"+                    ]      -- | Utility function to quickly display one line of text text :: PDFFont

@@ -0,0 +1,84 @@+---------------------------------------------------------+-- |+-- Copyright   : (c) 2023, haskell@henning-thielemann.de+-- License     : BSD-style+--+-- Maintainer  : haskell@henning-thielemann.de+-- Stability   : experimental+-- Portability : portable+--+-- PDF transparency+---------------------------------------------------------+module Graphics.PDF.Transparency(+  -- * Transparency+  SoftMask,+  createSoftMask,+  createTransparencyGroup,+  paintWithTransparency,+  ) where++import qualified Graphics.PDF.Draw as Draw+import Graphics.PDF.Document (createPDFXFormExtra)+import Graphics.PDF.Draw (PDF, Draw, SoftMask(SoftMask))+import Graphics.PDF.Shapes (Rectangle)+import Graphics.PDF.LowLevel.Serializer (serialize)+import Graphics.PDF.LowLevel.Types++import Control.Monad.Writer (tell)+import Control.Monad (void)++++createSoftMask ::+       Rectangle -- ^ Bounding box+    -> Draw a -- ^ Content of the soft mask+    -> PDF SoftMask+createSoftMask bbox =+    fmap SoftMask .+    createTransparencyGroup Draw.GraySpace bbox++createTransparencyGroup ::+       Draw.ColorSpace a e+    -> Rectangle -- ^ Bounding box+    -> Draw b -- ^ Painting+    -> PDF (PDFReference Draw.PDFXForm)+createTransparencyGroup space bbox img =+    createPDFXFormExtra bbox img $+        dictFromList $+            entry "Group" (dictFromList $+                entry "Type" (PDFName "Group") :+                entry "S" (PDFName "Transparency") :+                entry "I" True :+                entry "CS" (Draw.colorSpaceName space) :+                []) :+            []++{- |+If the Draw Monad paints overlapping geometric primitives or text,+the result will certainly not be what you want.+Text ignores soft masks.+Each primitive other than text is painted with the soft mask+over the previous geometric objects.+It is very likely, that in this case you want+to generate a transparency group for your drawing.+-}+paintWithTransparency ::+       SoftMask -- ^ Soft mask+    -> Draw a -- ^ Shape to paint+    -> Draw ()+paintWithTransparency softMask d =+    Draw.withNewContext $ do+        newName <-+            Draw.registerResource "ExtGState"+                Draw.softMasks (\newMap s -> s { Draw.softMasks = newMap })+                softMask+        tell . mconcat $+            [ serialize "\n/"+            , serialize newName+            , serialize " gs"+            ]+        void d++{-+https://github.com/pdf-association/pdf20examples/issues/9+-}

@@ -1,5 +1,5 @@ Name: HPDF-Version: 1.6.2+Version: 1.7 cabal-version: >=1.10 License: BSD3 License-file:LICENSE@@ -61,6 +61,7 @@                      text >= 1.2.0,                      network-uri >= 2.6.0.3,                      vector >=0.10,+                     array,                      filepath >= 1.4.0    Default-language:  Haskell2010@@ -108,6 +109,8 @@      Graphics.PDF.Annotation      Graphics.PDF.Pattern      Graphics.PDF.Shading+     Graphics.PDF.Transparency+     Graphics.PDF.Expression      Graphics.PDF.Typesetting      Graphics.PDF.Documentation   Other-Modules:

@@ -17,11 +17,13 @@ module Main where  +import qualified Graphics.PDF.Expression as Expr import Graphics.PDF import Penrose import System.Random import qualified Data.Vector.Unboxed as U import qualified Data.Text as T+import Data.Array (listArray) import Network.URI  import Data.Maybe(fromJust) import System.FilePath @@ -60,12 +62,85 @@             geometryTest                          -shadingTest :: Draw ()-shadingTest  = do-     paintWithShading (RadialShading 0 0 50 0 0 600 (Rgb 1 0 0) (Rgb 0 0 1)) (addShape $ Rectangle 0 (300 :+ 300))-     paintWithShading (AxialShading 300 300 600 400 (Rgb 1 0 0) (Rgb 0 0 1)) (addShape $ Ellipse 300 300 600 400)-     -                     +shadingTest :: PDFReference PDFPage -> PDF ()+shadingTest page = do+    funcObj <-+        createFunction1Object $+        Sampled1 $ listArray (0,3) [(1,0,0), (1,0,1), (0,0,1), (0,1,1)]+    drawWithPage page $ do+        paintWithShading+            (RadialShading 0 0 50 0 0 350+                (ColorFunction1 RGBSpace $ GlobalFunction1 funcObj))+            (addShape $ Rectangle 0 (300 :+ 300))+        paintWithShading+            (AxialShading 300 300 600 400+                (ColorFunction1 GraySpace $ Interpolated1 1  0.8 0.02))+            (addShape $ Ellipse 300 300 600 400)++functionalShadingTest :: PDFReference PDFPage -> PDF ()+functionalShadingTest page = do+    funcObj <-+        createFunction2Object $ calculator2 $ \x y ->+            (1-x,+             0.5 * (1 + Expr.sinDeg ((360*5) * Expr.sqrt (x*x+y*y))),+             1-y)+    drawWithPage page $+        paintWithShading+            (FunctionalShading+                (Matrix 300 0 0 300 150 50)+                (ColorFunction2 RGBSpace $ GlobalFunction2 funcObj))+            (addShape $ Rectangle (150:+50) (450 :+ 350))++transparencyTest :: Rectangle -> SoftMask -> Draw ()+transparencyTest rectB softMask = do+    let rectA = Rectangle (100:+00) (400 :+ 300)+    fillColor $ Rgb 1 0 0+    fill rectA++    paintWithTransparency softMask $ do+        fillColor $ Rgb 1 1 0+        fill rectB++    setFillAlpha 0.5+    let rectC = Rectangle (200:+100) (500 :+ 400)+    fillColor $ Rgb 0 1 0+    fill rectC++trafficSign :: AnyFont -> Draw ()+trafficSign helvetica = do+    let font = PDFFont helvetica 180+    let str = "P"+    strokeColor black+    drawText $ text font (-0.5 * textWidth font str) (-70) str+    setWidth 30+    strokeColor red+    stroke $ Circle 0 0 100+    let r = 100 * sqrt 0.5+    stroke $ Line (-r) (-r) r r++transparencyGroupTest ::+    AnyFont -> Rectangle -> SoftMask -> PDFReference PDFXForm -> Draw ()+transparencyGroupTest helvectica rectB softMask trafficSignObj = do+    applyMatrix $ scale 0.5 0.5+    applyMatrix $ translate $ 150:+150+    withNewContext $ trafficSign helvectica+    withNewContext $ do+        applyMatrix $ translate $ 300:+0+        -- alpha channel reveals internal structure of sign - not intended+        setStrokeAlpha 0.5+        setFillAlpha 0.5+        trafficSign helvectica+    withNewContext $ do+        applyMatrix $ translate $ 600:+0+        -- soft mask has no effect on text ... and additional graphics?+        paintWithTransparency softMask $+            trafficSign helvectica+    withNewContext $ do+        applyMatrix $ translate $ 900:+0+        paintWithTransparency softMask $+            drawXObject trafficSignObj++ patternTest :: PDFReference PDFPage -> PDF () patternTest page = do      p <- createUncoloredTiling 0 0 100 50 100 50 ConstantSpacing pattern@@ -324,7 +399,7 @@                         textStart 0 0                         setFont (PDFFont theFont fontSize)                         displayGlyphs (glyph c)-                    paintWithShading (AxialShading 0 (- getDescent theFont fontSize) w' (getHeight theFont fontSize - getDescent theFont fontSize) (Rgb 1 0 0) (Rgb 0 0 1)) (addShape charRect)+                    paintWithShading (AxialShading 0 (- getDescent theFont fontSize) w' (getHeight theFont fontSize - getDescent theFont fontSize) (ColorFunction1 RGBSpace $ Interpolated1 1 (1,0,0) (0,0,1))) (addShape charRect)         in         (BluePara theFont w', c':l)     @@ -654,10 +729,38 @@         patternTest page7               page8 <- addPage Nothing-     newSection "Shading" Nothing Nothing $ do-        drawWithPage page8 $ do-          shadingTest-          +     newSection "Shading" Nothing Nothing $+        shadingTest page8++     page8a <- addPage Nothing+     newSection "FunctionalShading" Nothing Nothing $+        functionalShadingTest page8a++     page8b <- addPage Nothing+     newSection "Transparency" Nothing Nothing $ do+        do  let rectB = Rectangle (150:+50) (450 :+ 350)+            softMask <-+                createSoftMask rectB+                    (paintWithShading+                        (AxialShading 300 300 600 400+                            (ColorFunction1 GraySpace $+                             Interpolated1 1  0.8 0.02))+                        (addShape rectB))+            drawWithPage page8b $+                transparencyTest rectB softMask++        page8c <- addPage Nothing+        do  let bbox = Rectangle (-(150:+150)) (150:+150)+            softMask <-+                createSoftMask bbox $ do+                    fillColor $ Rgb 0.5 0.5 0.5+                    fill bbox+            transpGroup <-+                createTransparencyGroup RGBSpace bbox $+                trafficSign helveticaBold+            drawWithPage page8c $+                transparencyGroupTest helveticaBold bbox softMask transpGroup+     page9 <- addPage Nothing     newSection "Media" Nothing Nothing $ do       newSection "image" Nothing Nothing $ do   

@@ -1,11 +1,8 @@ # Changelog for [`HPDF` package](http://hackage.haskell.org/package/HPDF) -## 1.6.2--   * Removed use of cbits for float/int to string conversions for correctness-     (see https://github.com/hsyl20/HPDF/issues/14)+## 1.7 -   * Fix build warnings due to -Woperator-whitespace-ext-conflict+   * Add transparency support and more function types (#16)  ## 1.6.1