diff --git a/diagrams-pdf.cabal b/diagrams-pdf.cabal --- a/diagrams-pdf.cabal +++ b/diagrams-pdf.cabal @@ -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 diff --git a/src/Diagrams/Backend/Pdf.hs b/src/Diagrams/Backend/Pdf.hs --- a/src/Diagrams/Backend/Pdf.hs +++ b/src/Diagrams/Backend/Pdf.hs @@ -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 diff --git a/test/Makefile b/test/Makefile --- a/test/Makefile +++ b/test/Makefile @@ -8,4 +8,4 @@ rm -f *.pdf run: - ./mytest --compressed -o circle.pdf + ./mytest diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -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 --