diff --git a/diagrams-postscript.cabal b/diagrams-postscript.cabal --- a/diagrams-postscript.cabal +++ b/diagrams-postscript.cabal @@ -1,5 +1,5 @@ Name: diagrams-postscript -Version: 1.0.2.4 +Version: 1.1 Synopsis: Postscript backend for diagrams drawing EDSL Description: This package provides a modular backend for rendering diagrams created with the diagrams EDSL using Postscript. @@ -32,19 +32,19 @@ Graphics.Rendering.Postscript Hs-source-dirs: src Build-depends: base >= 4.2 && < 4.8, - mtl >= 2.0 && < 2.2, + mtl >= 2.0 && < 2.3, filepath, dlist >= 0.5 && < 0.8, vector-space >= 0.7.7 && < 0.9, - diagrams-core >= 1.0 && < 1.2, - diagrams-lib >= 1.0.1 && < 1.2, + diagrams-core >= 1.0 && < 1.3, + diagrams-lib >= 1.0.1 && < 1.3, data-default-class < 0.1, split >= 0.1.2 && < 0.3, monoid-extras >= 0.3 && < 0.4, - semigroups >= 0.3.4 && < 0.14, - lens >= 3.8 && < 4.2, + semigroups >= 0.3.4 && < 0.16, + lens >= 3.8 && < 4.3, + containers >= 0.3 && < 0.6, hashable >= 1.1 && < 1.3 if impl(ghc < 7.6) build-depends: ghc-prim default-language: Haskell2010 - diff --git a/src/Diagrams/Backend/Postscript.hs b/src/Diagrams/Backend/Postscript.hs --- a/src/Diagrams/Backend/Postscript.hs +++ b/src/Diagrams/Backend/Postscript.hs @@ -44,13 +44,15 @@ -- * Postscript-supported output formats , OutputFormat(..) - ) where + , renderDias + ) where +import Diagrams.Core.Compile import qualified Graphics.Rendering.Postscript as C import Diagrams.Backend.Postscript.CMYK -import Diagrams.Prelude hiding (view) +import Diagrams.Prelude hiding (view, fillColor) import Diagrams.TwoD.Adjust (adjustDia2D) import Diagrams.TwoD.Path (Clip (Clip), getFillRule) @@ -64,7 +66,7 @@ import qualified Data.Foldable as F import Data.Hashable (Hashable (..)) import qualified Data.List.NonEmpty as N -import Data.Monoid.Split +import Data.Tree import Data.Typeable import GHC.Generics (Generic) @@ -96,29 +98,29 @@ } deriving (Show) - withStyle _ s t (C r) = C $ do - C.save - postscriptMiscStyle s - r - postscriptTransf t - postscriptStyle s - C.stroke - C.restore - - doRender _ (PostscriptOptions file size out) (C r) = + renderRTree _ opts t = let surfaceF surface = C.renderWith surface r - -- Everything except Dims is arbitrary. The backend - -- should have first run 'adjustDia' to update the - -- final size of the diagram with explicit dimensions, - -- so normally we would only expect to get Dims anyway. - (w,h) = sizeFromSpec size + (w,h) = sizeFromSpec (opts^.psSizeSpec) + r = runC . toRender $ t + in case opts^.psOutputFormat of + EPS -> C.withEPSSurface (opts^.psfileName) (round w) (round h) surfaceF - in case out of - EPS -> C.withEPSSurface file (round w) (round h) surfaceF + adjustDia c opts d = adjustDia2D psSizeSpec c opts d - adjustDia c opts d = adjustDia2D _psSizeSpec setPsSize c opts d - where setPsSize sz o = o { _psSizeSpec = sz } +runC :: Render Postscript R2 -> C.Render () +runC (C r) = r +toRender :: RTree Postscript R2 a -> Render Postscript R2 +toRender (Node (RPrim p) _) = render Postscript p +toRender (Node (RStyle sty) rs) = C $ do + C.save + postscriptMiscStyle sty + runC $ F.foldMap toRender rs + postscriptStyle sty + C.stroke + C.restore +toRender (Node _ rs) = F.foldMap toRender rs + instance Hashable (Options Postscript R2) where hashWithSalt s (PostscriptOptions fn sz out) = s `hashWithSalt` fn @@ -144,28 +146,28 @@ psOutputFormat = lens (\(PostscriptOptions {_psOutputFormat = t}) -> t) (\o t -> o {_psOutputFormat = t}) -instance MultiBackend Postscript R2 where - renderDias b opts ds = doRenderPages b (combineSizes (map fst rs)) (map snd rs) >> return () - where - mkMax (x,y) = (Max x, Max y) - fromMaxPair (Max x, Max y) = (x,y) +renderDias :: (Semigroup m, Monoid m) => + Options Postscript R2 -> [QDiagram Postscript R2 m] -> IO [()] +renderDias opts ds = case opts^.psOutputFormat of + EPS -> C.withEPSSurface (opts^.psfileName) (round w) (round h) surfaceF + where + surfaceF surface = C.renderPagesWith surface (map (\(C r) -> r) rs) + (w,h) = sizeFromSpec (cSize^.psSizeSpec) - rs = map mkRender ds - mkRender d = (opts', mconcat . map renderOne . prims $ d') - where - (opts', d') = adjustDia b opts d - renderOne (p, (M t, s)) = withStyle b s mempty (render b (transform t p)) - renderOne (p, (t1 :| t2, s)) = withStyle b s t1 (render b (transform (t1 <> t2) p)) + dropMid (x, _, z) = (x,z) - combineSizes [] = PostscriptOptions "" (Dims 100 100) EPS -- arbitrary - combineSizes (o:os) = o { _psSizeSpec = uncurry Dims . fromMaxPair . sconcat $ f o N.:| fmap f os } - where f = mkMax . sizeFromSpec . _psSizeSpec + optsdss = map (dropMid . adjustDia Postscript opts) ds + cSize = (combineSizes $ map fst optsdss) + g2o = scaling (sqrt (w * h)) + rs = map (toRender . toRTree g2o . snd) optsdss - doRenderPages _ (PostscriptOptions file size out) pages = - let surfaceF surface = C.renderPagesWith surface (map (\(C r) -> r) pages) - (w,h) = sizeFromSpec size - in case out of - EPS -> C.withEPSSurface file (round w) (round h) surfaceF + combineSizes [] = PostscriptOptions "" (Dims 100 100) EPS + combineSizes (o:os) = + o { _psSizeSpec = uncurry Dims . fromMaxPair . sconcat $ f o N.:| fmap f os } + where + f = mkMax . sizeFromSpec . _psSizeSpec + fromMaxPair (Max x, Max y) = (x,y) + mkMax (x,y) = (Max x, Max y) renderC :: (Renderable a Postscript, V a ~ R2) => a -> C.Render () renderC a = case render Postscript a of C r -> r @@ -180,6 +182,7 @@ , handle fSlant , handle fWeight , handle fSize + , handle fLocal , handle fColor , handle fColorCMYK , handle lFillRule @@ -188,11 +191,12 @@ handle :: AttributeClass a => (a -> C.Render ()) -> Maybe (C.Render ()) handle f = f `fmap` getAttr s clip = mapM_ (\p -> renderC p >> C.clip) . op Clip - fSize = assign (C.drawState . C.font . C.size) <$> getFontSize + fSize = assign (C.drawState . C.font . C.size) <$> (fromOutput . getFontSize) + fLocal = assign (C.drawState . C.font . C.isLocal) <$> getFontSizeIsLocal fFace = assign (C.drawState . C.font . C.face) <$> getFont fSlant = assign (C.drawState . C.font . C.slant) .fromFontSlant <$> getFontSlant fWeight = assign (C.drawState . C.font . C.weight) . fromFontWeight <$> getFontWeight - fColor c = C.fillColor (getFillColor c) + fColor = C.fillColor . getFillTexture fColorCMYK c = C.fillColorCMYK (getFillColorCMYK c) lFillRule = assign (C.drawState . C.fillRule) . getFillRule @@ -219,16 +223,16 @@ ] where handle :: (AttributeClass a) => (a -> C.Render ()) -> Maybe (C.Render ()) handle f = f `fmap` getAttr s - lColor = C.strokeColor . getLineColor + lColor = C.strokeColor . getLineTexture lColorCMYK = C.strokeColorCMYK . getLineColorCMYK - fColor c = C.fillColor (getFillColor c) >> C.fillPreserve + fColor c = C.fillColor (getFillTexture c) >> C.fillPreserve fColorCMYK c = C.fillColorCMYK (getFillColorCMYK c) >> C.fillPreserve - lWidth = C.lineWidth . getLineWidth + lWidth = C.lineWidth . fromOutput . getLineWidth lCap = C.lineCap . getLineCap lJoin = C.lineJoin . getLineJoin lMiter = C.miterLimit . getLineMiterLimit lDashing (getDashing -> Dashing ds offs) = - C.setDash ds offs + C.setDash (map fromOutput ds) (fromOutput offs) postscriptTransf :: Transformation R2 -> C.Render () postscriptTransf t = C.transform a1 a2 b1 b2 c1 c2 @@ -264,7 +268,9 @@ renderC tr instance Renderable Text Postscript where - render _ (Text tr al str) = C $ do + render _ (Text tt tn al str) = C $ do + isLocal <- use (C.drawState . C.font . C.isLocal) + let tr = if isLocal then tt else tn C.save postscriptTransf tr case al of diff --git a/src/Diagrams/Backend/Postscript/CmdLine.hs b/src/Diagrams/Backend/Postscript/CmdLine.hs --- a/src/Diagrams/Backend/Postscript/CmdLine.hs +++ b/src/Diagrams/Backend/Postscript/CmdLine.hs @@ -48,11 +48,11 @@ -- -- For a tutorial on command-line diagram creation see -- . --- +-- ----------------------------------------------------------------------------- module Diagrams.Backend.Postscript.CmdLine - ( + ( -- * General form of @main@ -- $mainwith @@ -156,7 +156,7 @@ chooseRender opts renderer = case splitOn "." (opts^.output) of [""] -> putStrLn "No output file given." - ps | last ps `elem` ["eps"] + ps | last ps `elem` ["eps"] || last ps `elem` ["ps"] -> do let outfmt = case last ps of _ -> EPS @@ -169,13 +169,13 @@ renderer (PostscriptOptions (opts^.output) sizeSpec outfmt) | otherwise -> putStrLn $ "Unknown file type: " ++ last ps - + renderDias' :: [Diagram Postscript R2] -> Options Postscript R2 -> IO () -renderDias' ds o = renderDias Postscript o ds >> return () +renderDias' ds o = renderDias o ds >> return () renderDia' :: Diagram Postscript R2 -> Options Postscript R2 -> IO () renderDia' d o = renderDia Postscript o d >> return () - + -- | @multiMain@ is like 'defaultMain', except instead of a single -- diagram it takes a list of diagrams paired with names as input. diff --git a/src/Graphics/Rendering/Postscript.hs b/src/Graphics/Rendering/Postscript.hs --- a/src/Graphics/Rendering/Postscript.hs +++ b/src/Graphics/Rendering/Postscript.hs @@ -65,14 +65,15 @@ , FontSlant(..) , FontWeight(..) - , face, slant, weight, size + , face, slant, weight, size, isLocal , fillRule, ignoreFill, font , CMYK(..), cyan, magenta, yellow, blacK ) where -import Diagrams.Attributes(Color(..),LineCap(..),LineJoin(..),colorToSRGBA) +import Diagrams.Attributes(Color(..),LineCap(..),LineJoin(..),colorToSRGBA,SomeColor(..)) +import Diagrams.TwoD.Attributes (Texture(..)) import Diagrams.TwoD.Path hiding (stroke, fillRule) import Control.Applicative import Control.Monad.Writer @@ -109,12 +110,13 @@ , _slant :: FontSlant , _weight :: FontWeight , _size :: Double + , _isLocal :: Bool } deriving (Eq, Show) makeLenses '' PostscriptFont defaultFont :: PostscriptFont -defaultFont = PostscriptFont "Helvetica" FontSlantNormal FontWeightNormal 1 +defaultFont = PostscriptFont "Helvetica" FontSlantNormal FontWeightNormal 1 True -- Here we want to mirror the state of side-effecting calls -- that we have emitted into the postscript file (at least @@ -358,13 +360,15 @@ colorPS c = [ r, g, b ] where (r,g,b,_) = colorToSRGBA c --- | Set the color of the stroke. -strokeColor :: (Color c) => c -> Render () -strokeColor c = mkPSCall "setrgbcolor" (colorPS c) +-- | Set the color of the stroke. Ignore gradients. +strokeColor :: Texture -> Render () +strokeColor (SC (SomeColor c)) = mkPSCall "setrgbcolor" (colorPS c) +strokeColor _ = return () --- | Set the color of the fill. -fillColor :: (Color c) => c -> Render () -fillColor c = mkPSCall "setrgbcolor" (colorPS c) +-- | Set the color of the fill. Ignore gradients. +fillColor :: Texture -> Render () +fillColor (SC (SomeColor c)) = mkPSCall "setrgbcolor" (colorPS c) +fillColor _ = return () -- CMYK colors colorCMYK :: CMYK -> [Double]