diagrams-pdf 0.3 → 0.3.1
raw patch · 4 files changed
+138/−145 lines, 4 filesdep +lensPVP ok
version bump matches the API change (PVP)
Dependencies added: lens
API changes (from Hackage documentation)
+ Diagrams.Backend.Pdf: instance Eq FillingMode
+ Diagrams.Backend.Pdf: instance Show FillingMode
Files
- diagrams-pdf.cabal +4/−3
- src/Diagrams/Backend/Pdf.hs +109/−125
- test/Makefile +1/−1
- test/test.hs +24/−16
diagrams-pdf.cabal view
@@ -1,5 +1,5 @@ name: diagrams-pdf-version: 0.3+version: 0.3.1 synopsis: PDF backend for diagrams drawing EDSL homepage: http://www.alpheccar.org license: BSD3@@ -54,9 +54,10 @@ filepath >= 1.3 && < 1.4, split >= 0.2.2 && < 0.3, cmdargs >= 0.10 && < 0.11,- colour >= 2.3.3 && < 2.4+ colour >= 2.3.3 && < 2.4,+ lens >= 3.9 && < 3.10 Hs-source-dirs: src - Ghc-options: -Wall+ Ghc-options: -Wall -fno-warn-unused-binds Default-language: Haskell2010
src/Diagrams/Backend/Pdf.hs view
@@ -10,6 +10,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Backend.Pdf@@ -77,12 +78,13 @@ import Data.Monoid.Split import qualified Control.Monad.State.Strict as S import Control.Monad.Trans(lift)-import Diagrams.TwoD.Path+import Diagrams.TwoD.Path import Control.Monad(when) import Diagrams.Backend.Pdf.Specific import Data.Typeable import qualified Diagrams.TwoD.Shapes as Sh import Data.Maybe(isJust)+import Control.Lens hiding(transform,(#),para) --import Debug.Trace as T @@ -92,6 +94,8 @@ data Pdf = Pdf deriving (Eq,Ord,Read,Show,Typeable) +data FillingMode = NoFilling | Shading | ColorFilling deriving(Eq,Show)+ -- | The drawing state -- I should give a name to the different fields and use lens -- The first three parameters are for the font@@ -107,16 +111,20 @@ , _fontSize :: Int , _fillRule :: FillRule , _currentPoint :: P.Point - , _mustFill :: Bool+ , _fillingMode :: FillingMode , _mustStroke :: Bool , _isloop :: Bool , _shading :: Maybe PDFShading+ , _strokeOpacity :: Double + , _fillOpacity :: Double }+makeLenses ''DrawingState -- | The stack of drawing state data StateStack = StateStack { _current :: DrawingState , _last :: [DrawingState] }+makeLenses ''StateStack defaultFontSize :: Num a => a defaultFontSize = 1 @@ -129,7 +137,7 @@ -- | Initial drawing state initState :: StateStack-initState = StateStack (DrawingState FontSlantNormal FontWeightNormal 1 Winding (0 :+ 0) False True True Nothing) []+initState = StateStack (DrawingState FontSlantNormal FontWeightNormal 1 Winding (0 :+ 0) NoFilling True True Nothing 1.0 1.0) [] -- | The drawing monad with state@@ -149,93 +157,57 @@ runDS d = S.evalStateT (unDS d) initState -- | Generate an HPDF font-mkFont :: DrawingState -> PDFFont -mkFont (DrawingState FontSlantNormal FontWeightNormal s _ _ _ _ _ _) = PDFFont Times_Roman s-mkFont (DrawingState FontSlantNormal FontWeightBold s _ _ _ _ _ _) = PDFFont Times_Bold s-mkFont (DrawingState FontSlantItalic FontWeightNormal s _ _ _ _ _ _) = PDFFont Times_Italic s-mkFont (DrawingState FontSlantItalic FontWeightBold s _ _ _ _ _ _) = PDFFont Times_BoldItalic s-mkFont (DrawingState FontSlantOblique FontWeightNormal s _ _ _ _ _ _) = PDFFont Helvetica_Oblique s-mkFont (DrawingState FontSlantOblique FontWeightBold s _ _ _ _ _ _) = PDFFont Helvetica_BoldOblique s-+mkFont :: (FontSlant,FontWeight,Int) -> PDFFont +mkFont (FontSlantNormal, FontWeightNormal, s) = PDFFont Times_Roman s+mkFont (FontSlantNormal, FontWeightBold, s) = PDFFont Times_Bold s+mkFont (FontSlantItalic, FontWeightNormal, s) = PDFFont Times_Italic s+mkFont (FontSlantItalic, FontWeightBold, s) = PDFFont Times_BoldItalic s+mkFont (FontSlantOblique, FontWeightNormal, s) = PDFFont Helvetica_Oblique s+mkFont (FontSlantOblique, FontWeightBold, s) = PDFFont Helvetica_BoldOblique s +extractFont :: DrawingState -> (FontSlant,FontWeight,Int)+extractFont s = (s ^. fontSlant, s ^. fontWeight, s ^. fontSize) setFontSize :: Double -> DrawS () setFontSize fs = do let s = floor fs- StateStack (DrawingState fsl fw _ wr p f st ilp shade) l <- S.get - S.put $! StateStack (DrawingState fsl fw s wr p f st ilp shade) l+ current . fontSize .= s+ setFontWeight :: FontWeight -> DrawS ()-setFontWeight w = do - StateStack (DrawingState fsl _ fs wr p f st ilp shade) l <- S.get - S.put $! StateStack (DrawingState fsl w fs wr p f st ilp shade) l- +setFontWeight w = current . fontWeight .= w setFontSlant :: FontSlant -> DrawS ()-setFontSlant sl = do - StateStack (DrawingState _ fw fs wr p f st ilp shade) l <- S.get - S.put $! StateStack (DrawingState sl fw fs wr p f st ilp shade) l+setFontSlant sl = current . fontSlant .= sl setFillRule :: FillRule -> DrawS ()-setFillRule wr = do - StateStack (DrawingState sl fw fs _ p f st ilp shade) l <- S.get - S.put $! StateStack (DrawingState sl fw fs wr p f st ilp shade) l+setFillRule wr = current . fillRule .= wr savePoint :: P.Point -> DrawS () -savePoint p = do - StateStack (DrawingState sl fw fs wr _ f st ilp shade) l <- S.get - S.put $! StateStack (DrawingState sl fw fs wr p f st ilp shade) l--currentPoint :: DrawS P.Point -currentPoint = do - StateStack (DrawingState _ _ _ _ p _ _ _ _) _ <- S.get - return p --getFillState :: DrawS FillRule -getFillState = do - StateStack (DrawingState _ _ _ w _ _ _ _ _) _ <- S.get - return w--mustFill :: DrawS Bool -mustFill = do- StateStack (DrawingState _ _ _ _ _ b _ _ _) _ <- S.get - return b+savePoint p = current . currentPoint .= p -- | From the alpha value of a fill color, we check if the filling must be disabled-setFillingColor :: Double -> DrawS() -setFillingColor alpha = do - let b | alpha /= 0.0 = True - | otherwise = False- StateStack (DrawingState fsl w fs wr p _ st ilp shade) l <- S.get - S.put $! StateStack (DrawingState fsl w fs wr p b st ilp shade) l--mustStroke :: DrawS Bool-mustStroke = do - StateStack (DrawingState _ _ _ _ _ _ b _ _) _ <- S.get - return b+checkFillingNeeded :: Double -> DrawS() +checkFillingNeeded alpha = do + let b | alpha /= 0.0 = id + | otherwise = const NoFilling+ current . fillingMode %= b -- | From the linew width we check if stroke must be disabled setTrokeState :: Double -> DrawS () setTrokeState w = do let st | w == 0 = False | otherwise = True- StateStack (DrawingState fsl fw fs wr p b _ ilp shade) l <- S.get - S.put $! StateStack (DrawingState fsl fw fs wr p b st ilp shade) l-+ current . mustStroke .= st+ isALoop :: DrawS Bool -isALoop = do - StateStack s _ <- S.get- return $ _isloop s+isALoop = use (current . isloop) getShading :: DrawS (Maybe PDFShading) -getShading = do - StateStack s _ <- S.get- return $ _shading $ s+getShading = use (current . shading) setLoop :: Bool -> DrawS () -setLoop b = do - StateStack s l <- S.get- S.put $! StateStack (s {_isloop = b}) l+setLoop b = current . isloop .= b -- | Initial settings before rendering the diagram setTranform :: Draw () -> Draw ()@@ -245,35 +217,59 @@ P.setWidth defaultWidth d -withShading :: Transformation R2 -> Bool -> Maybe PDFShading -> DrawS () -> DrawS () -> DrawS () -withShading td evenodd (Just shade) diag _ = do +withShading :: Transformation R2 + -> FillRule + -> FillingMode + -> Bool -- ^ Must stroke+ -> Maybe PDFShading + -> DrawS () + -> DrawS ()+withShading td evenodd Shading strokedRequested (Just shade) drawCommands = do withContext $ do - diag+ drawCommands drawM $ do- if evenodd + if evenodd == EvenOdd then P.setAsClipPathEO else P.setAsClipPath P.applyShading (unTrans $ transform td (TransSh shade))-withShading _ _ _ diag paint = do - diag - paint+ when (strokedRequested) $ do + drawCommands + drawM (P.strokePath) +withShading _ _ Shading strokedRequested Nothing drawCommands = + when (strokedRequested) $ do + drawCommands + drawM (P.strokePath)+withShading _ Winding ColorFilling True _ drawCommands = do + drawCommands + drawM P.fillAndStrokePath+withShading _ EvenOdd ColorFilling True _ drawCommands = do + drawCommands + drawM P.fillAndStrokePathEO+withShading _ Winding ColorFilling False _ drawCommands = do + drawCommands + drawM P.fillPath+withShading _ EvenOdd ColorFilling False _ drawCommands = do + drawCommands + drawM P.fillPathEO+withShading _ _ NoFilling True _ drawCommands = do + drawCommands + drawM P.strokePath+withShading _ _ NoFilling False _ _ = return () strokeOrFill :: Transformation R2 -> DrawS () -> DrawS () -strokeOrFill td r = do - mf <- mustFill- ms <- mustStroke - fs <- getFillState- isloop <- isALoop+strokeOrFill td r = do+ let whenNoLoop m = do+ islooppath <- isALoop+ if islooppath+ then m+ else return NoFilling + fm <- whenNoLoop $ use (current . fillingMode)+ sm <- use (current . mustStroke) + fr <- use (current . fillRule) sh <- getShading- -- Set the diagram opacity in a new PDF context- case (ms,mf,fs,isloop) of - (True,True,Winding,True) -> withShading td False sh r $ drawM (P.fillAndStrokePath)- (True,True,EvenOdd,True) -> withShading td True sh r $ drawM (P.fillAndStrokePathEO)- (False,True,Winding,True) -> withShading td False sh r $ drawM (P.fillPath)- (False,True,EvenOdd,True) -> withShading td True sh r $ drawM (P.fillPathEO)- (True,_,_,_) -> r >> drawM (P.strokePath) - (_,_,_,_) -> r >> return ()+ withShading td fr fm sm sh r setLoop True+ return () -- | Perform a rendering operation with a local style. withStyle' :: Style R2 -- ^ Style to use@@ -284,17 +280,16 @@ withStyle' s t td (D r) = D $ do withContext $ do pdfMiscStyle s- mf <- mustFill- ms <- mustStroke -- Set the clip region into a new PDF context -- since it is the only way to restore the old clip region -- (by popping the PDF stack of contexts) pdfTransf t- withClip s $ do+ withClip t s $ do pdfFrozenStyle s- when (mf || ms) $ do - withPdfOpacity s $ do- strokeOrFill (td) r+ diagramOpacity <- getDiagramOpacity s+ use (current . strokeOpacity) >>= drawM . P.setStrokeAlpha . (* diagramOpacity)+ use (current . fillOpacity) >>= drawM . P.setFillAlpha . (* diagramOpacity)+ strokeOrFill (td) r instance Backend Pdf R2 where data Render Pdf R2 = D (DrawS ())@@ -358,7 +353,7 @@ -- | Relative lineto relativeLine :: P.Point -> DrawS () relativeLine p = do - c <- currentPoint + c <- use (current . currentPoint) let c' = p + c drawM (lineto c') savePoint c'@@ -366,7 +361,7 @@ -- | Relative curveto relativeCurveTo :: P.Point -> P.Point -> P.Point -> DrawS () relativeCurveTo x y z = do - c <- currentPoint + c <- use (current . currentPoint) let x' = x + c y' = y + c z' = z + c @@ -383,18 +378,6 @@ renderC :: (Renderable a Pdf, V a ~ R2) => a -> DrawS () renderC a = case render Pdf a of D r -> r -{--push :: DrawS()-push = do - StateStack c l <- S.get - S.put $! (StateStack c (c:l))--pop :: DrawS()-pop = do - StateStack _ l <- S.get - S.put $! (StateStack (head l) (tail l))--}- -- | With a new context do something -- It is a bit comlex because the withNewContext from the HPDF library -- must be used to push / pop a new PDF context@@ -413,19 +396,22 @@ drawM $ do P.setFillAlpha a P.fillColor (Rgb r g b)- setFillingColor a+ current . fillingMode .= ColorFilling+ checkFillingNeeded a+ current . fillOpacity .= a pdfStrokeColor :: (Real b, Floating b) => AlphaColour b -> DrawS () pdfStrokeColor c = do+ let (r,g,b,a) = colorToSRGBA c drawM $ do- let (r,g,b,a) = colorToSRGBA c P.setStrokeAlpha a P.strokeColor (Rgb r g b)+ current . strokeOpacity .= a setShadingData :: Maybe PDFShading -> DrawS () setShadingData sh = do - StateStack s l <- S.get- S.put $! StateStack (s {_shading = sh, _mustFill = _mustFill s || isJust sh}) l+ current . shading .= sh + current . fillingMode %= \x -> if isJust sh then Shading else x setShading :: PdfShadingData -> DrawS () setShading (PdfAxialShadingData pa pb ca cb) = do @@ -472,38 +458,36 @@ -} -withPdfOpacity :: Style v -> DrawS a -> DrawS a -withPdfOpacity s m = do +getDiagramOpacity :: Style v -> DrawS Double+getDiagramOpacity s = do let mo = handle s getOpacity case mo of - Nothing -> m - Just d -> do - withContext $ do - drawM (setStrokeAlpha d >> setFillAlpha d) - m+ Nothing -> return 1.0 + Just d -> return d where handle :: AttributeClass a => Style v -> (a -> b) -> Maybe b handle st f = f `fmap` getAttr st -withClip :: Style v -> DrawS () -> DrawS ()-withClip s m = do - let d = handle s m clip+withClip :: Transformation R2 -> Style v -> DrawS () -> DrawS ()+withClip t s m = do + let d = handle s m case d of Just r -> r Nothing -> m - where handle :: AttributeClass a => Style v -> DrawS () -> (DrawS () -> a -> b) -> Maybe b- handle st dm f = f dm `fmap` getAttr st- clip dm = clipPath dm . getClip+ where handle :: Style v -> DrawS () -> Maybe (DrawS ())+ handle st dm = (clipPath dm . getClip) `fmap` getAttr st addPathToClip p = do renderC p - f <- getFillState + f <- use (current . fillRule) case f of Winding -> drawM (setAsClipPath) EvenOdd -> drawM (setAsClipPathEO) clipPath dm p = do withContext $ do + pdfTransf ( inv t) mapM_ addPathToClip p + pdfTransf (t) dm @@ -516,7 +500,7 @@ , handle lColor , handle lFillRule , handle checklWidth- , handle shading+ , handle theShading ] where handle :: AttributeClass a => (a -> DrawS ()) -> Maybe (DrawS ()) handle f = f `fmap` getAttr s@@ -527,7 +511,7 @@ lColor c = pdfStrokeColor . toAlphaColour . getLineColor $ c fColor c = pdfFillColor . toAlphaColour . getFillColor $ c lFillRule = setFillRule . getFillRule- shading = setShading . getShadingData+ theShading = setShading . getShadingData checklWidth w = do let d = getLineWidth w setTrokeState d@@ -600,7 +584,7 @@ render _ (Text tr al str) = D $ withContext $ do StateStack f _ <- S.get - let theFont = mkFont f+ let theFont = mkFont . extractFont $ f tw = textWidth theFont (toPDFString str) descent = getDescent theFont fontHeight = getHeight theFont
test/Makefile view
@@ -8,4 +8,4 @@ rm -f *.pdf run:- ./mytest --compressed -o circle.pdf+ ./mytest
test/test.hs view
@@ -278,31 +278,39 @@ drawWithPage page1 $ do renderDia Pdf (PdfOptions (Dims pageWidth pageHeight)) $ page s d -testShadeFroz = do- page1 <- addPage Nothing- drawWithPage page1 $ do- renderDia Pdf (PdfOptions (Dims pageWidth pageHeight)) $ - w +testShadeFroz = w where w :: Diagram Pdf R2 w = rect pageWidth (pageHeight - titleH) <> centerXY (- square 100 # pdfAxialShading (p2 (-50,-50)) (p2 (50,50)) blue white+ square 100 # pdfAxialShading (p2 (-50,-50)) (p2 (50,50)) blue white # lw 1.0 ===- square 100 # rotate (45 :: Deg) # freeze # pdfAxialShading (p2 (-50,-50)) (p2 (50,50)) blue white+ square 50 # freeze # rotate (45 :: Deg) # scale 2 # pdfAxialShading (p2 (-40,-40)) (p2 (40,40)) blue yellow # lw 1.0 ) +testOpacity = do + page1 <- addPage Nothing+ drawWithPage page1 $ do+ renderDia Pdf (PdfOptions (Dims pageWidth pageHeight)) $ w+ where + w :: Diagram Pdf R2 + w = + let colors = map (blue `withOpacity`) [0.1, 0.2 .. 1.0]+ colorss = map (black `withOpacity`) [0.1, 0.2 .. 1.0]+ in hcat' with { catMethod = Distrib, sep = 1 }+ (zipWith3 (\cs cl c -> fcA cs $ c) colors colorss (repeat (circle 1)))+ main = do Right jpgf <- readJpegFile "logo.jpg" let theDocRect = PDFRect 0 0 pageWidth pageHeight runPdf "demo.pdf" (standardDocInfo { author=toPDFString "alpheccar", compressed = False}) theDocRect $ do- testShadeFroz- --mkSection "HPDF Specific Primitives" $ do- -- jpg <- createPDFJpeg jpgf- -- image <- pdfImage jpg- -- mkPage "Test JPEG and URL" (testImage image)- -- mkPage "Test Shading" testShading- -- mkPage "Test Suggested Text Container Size" testpdfsuggestedtextsize- -- mkPage "Test Forced Text Container Size" testpdftextsize- -- mkPage "Text Complex Text" complexText+ mkSection "HPDF Specific Primitives" $ do+ jpg <- createPDFJpeg jpgf+ image <- pdfImage jpg+ mkPage "Test JPEG and URL" (testImage image)+ mkPage "Test Shading" testShading+ mkPage "Test Suggested Text Container Size" testpdfsuggestedtextsize+ mkPage "Test Forced Text Container Size" testpdftextsize+ mkPage "Text Complex Text" complexText+ mkPage "Test shading with freeze" testShadeFroz --