diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,10 +1,13 @@ -Copyright 2011-2014: +Copyright 2011-2015: Ryan Yates Daniel Bergey Jan Bracker + Christopher Chalmers + Tim Docker Jeffrey Rosenbluth + Ryan Scott Michael Sloan Brent Yorgey diff --git a/diagrams-postscript.cabal b/diagrams-postscript.cabal --- a/diagrams-postscript.cabal +++ b/diagrams-postscript.cabal @@ -1,16 +1,19 @@ Name: diagrams-postscript -Version: 1.1.0.5 +Version: 1.3.0.0 Synopsis: Postscript backend for diagrams drawing EDSL Description: This package provides a modular backend for rendering diagrams created with the diagrams EDSL using Postscript. . * "Diagrams.Backend.Postscript.CmdLine" - Provides - the "defaultMain" interface to render a diagram + the "mainWith" interface to render a diagram based on command line options. . * "Diagrams.Backend.Postscript" - Provides the general API for rendering diagrams using the Postscript backend. + . + * "Diagrams.Backend.CMYK" - Special support for CMYK + color attributes. Homepage: http://projects.haskell.org/diagrams/ License: BSD3 License-file: LICENSE @@ -20,7 +23,7 @@ Category: Graphics Build-type: Simple Cabal-version: >=1.10 -Tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.1 +Tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1 Source-repository head type: git location: https://github.com/diagrams/diagrams-postscript.git @@ -31,16 +34,16 @@ Diagrams.Backend.Postscript.CmdLine Graphics.Rendering.Postscript Hs-source-dirs: src - Build-depends: base >= 4.2 && < 4.8, + Build-depends: base >= 4.2 && < 4.9, mtl >= 2.0 && < 2.3, filepath, dlist >= 0.5 && < 0.8, - vector-space >= 0.7.7 && < 0.11, - diagrams-core >= 1.0 && < 1.3, - diagrams-lib >= 1.2 && < 1.3, + diagrams-core >= 1.3 && < 1.4, + diagrams-lib >= 1.3 && < 1.4, data-default-class < 0.1, + statestack >= 0.2 && < 0.3, split >= 0.1.2 && < 0.3, - monoid-extras >= 0.3 && < 0.4, + monoid-extras >= 0.3 && < 0.5, semigroups >= 0.3.4 && < 0.17, lens >= 4.0 && < 4.10, containers >= 0.3 && < 0.6, 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 @@ -5,10 +5,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} - ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Backend.Postscript @@ -21,7 +21,7 @@ -- To build diagrams for Postscript rendering use the @Postscript@ -- type in the diagram type construction -- --- > d :: Diagram Postscript R2 +-- > d :: Diagram Postscript -- > d = ... -- -- and render giving the @Postscript@ token @@ -48,27 +48,27 @@ , renderDias ) where -import Diagrams.Core.Compile -import qualified Graphics.Rendering.Postscript as C import Diagrams.Backend.Postscript.CMYK +import Diagrams.Core.Compile +import qualified Graphics.Rendering.Postscript as C -import Diagrams.Prelude hiding (view, fillColor) +import Diagrams.Prelude hiding (fillColor, view) -import Diagrams.TwoD.Adjust (adjustDia2D) -import Diagrams.TwoD.Path (Clip (Clip), getFillRule) +import Diagrams.TwoD.Adjust (adjustDia2D) +import Diagrams.TwoD.Path (Clip (Clip), getFillRule) import Diagrams.TwoD.Text -import Diagrams.TwoD.Types -import Control.Lens hiding (transform) -import Control.Monad (when) -import Data.Maybe (catMaybes) +import Control.Lens hiding (transform) +import Control.Monad (when) +import qualified Control.Monad.StateStack as SS +import Control.Monad.Trans (lift) +import Data.Maybe (catMaybes, isJust) -import qualified Data.Foldable as F -import Data.Hashable (Hashable (..)) -import qualified Data.List.NonEmpty as N +import qualified Data.Foldable as F +import Data.Hashable (Hashable (..)) import Data.Tree import Data.Typeable -import GHC.Generics (Generic) +import GHC.Generics (Generic) -- | This data declaration is simply used as a token to distinguish this rendering engine. data Postscript = Postscript @@ -76,6 +76,9 @@ type B = Postscript +type instance V Postscript = V2 +type instance N Postscript = Double + -- | Postscript only supports EPS style output at the moment. Future formats would each -- have their own associated properties that affect the output. data OutputFormat = EPS -- ^ Encapsulated Postscript output. @@ -83,122 +86,142 @@ instance Hashable OutputFormat -instance Monoid (Render Postscript R2) where +data PostscriptState + = PostscriptState { _accumStyle :: Style V2 Double + -- ^ The current accumulated style. + , _ignoreFill :: Bool + -- ^ Whether or not we saw any lines in the most + -- recent path (as opposed to loops). If we did, + -- we should ignore any fill attribute. + -- diagrams-lib separates lines and loops into + -- separate path primitives so we don't have to + -- worry about seeing them together in the same + -- path. + } + +$(makeLenses ''PostscriptState) + +instance Default PostscriptState where + def = PostscriptState + { _accumStyle = mempty + , _ignoreFill = False + } + +type RenderM a = SS.StateStackT PostscriptState C.Render a + +liftC :: C.Render a -> RenderM a +liftC = lift + +runRenderM :: RenderM a -> C.Render a +runRenderM = flip SS.evalStateStackT def + +save :: RenderM () +save = SS.save >> liftC C.save + +restore :: RenderM () +restore = liftC C.restore >> SS.restore + +instance Monoid (Render Postscript V2 Double) where mempty = C $ return () (C x) `mappend` (C y) = C (x >> y) -instance Backend Postscript R2 where - data Render Postscript R2 = C (C.Render ()) - type Result Postscript R2 = IO () - data Options Postscript R2 = PostscriptOptions +instance Backend Postscript V2 Double where + data Render Postscript V2 Double = C (RenderM ()) + type Result Postscript V2 Double = IO () + data Options Postscript V2 Double = PostscriptOptions { _psfileName :: String -- ^ the name of the file you want generated - , _psSizeSpec :: SizeSpec2D -- ^ the requested size of the output + , _psSizeSpec :: SizeSpec V2 Double -- ^ the requested size of the output , _psOutputFormat :: OutputFormat -- ^ the output format and associated options } deriving (Show) renderRTree _ opts t = let surfaceF surface = C.renderWith surface r - (w,h) = sizeFromSpec (opts^.psSizeSpec) - r = runC . toRender $ t + V2 w h = specToSize 100 (opts^.psSizeSpec) + r = runRenderM . runC . toRender $ t in case opts^.psOutputFormat of EPS -> C.withEPSSurface (opts^.psfileName) (round w) (round h) surfaceF - adjustDia c opts d = adjustDia2D psSizeSpec c opts d + adjustDia = adjustDia2D psSizeSpec -runC :: Render Postscript R2 -> C.Render () +runC :: Render Postscript V2 Double -> RenderM () runC (C r) = r -toRender :: RTree Postscript R2 a -> Render Postscript R2 +-- | Get an accumulated style attribute from the render monad state. +getStyleAttrib :: AttributeClass a => (a -> b) -> RenderM (Maybe b) +getStyleAttrib f = (fmap f . getAttr) <$> use accumStyle + +toRender :: RTree Postscript V2 Double a -> Render Postscript V2 Double toRender (Node (RPrim p) _) = render Postscript p toRender (Node (RStyle sty) rs) = C $ do - C.save - postscriptMiscStyle sty - runC $ F.foldMap toRender rs + save postscriptStyle sty - C.stroke - C.restore + accumStyle %= (<> sty) + runC $ F.foldMap toRender rs + restore toRender (Node _ rs) = F.foldMap toRender rs -instance Hashable (Options Postscript R2) where +instance Hashable (Options Postscript V2 Double) where hashWithSalt s (PostscriptOptions fn sz out) = s `hashWithSalt` fn `hashWithSalt` sz `hashWithSalt` out -sizeFromSpec :: SizeSpec2D -> (Double, Double) -sizeFromSpec size = case size of - Width w' -> (w',w') - Height h' -> (h',h') - Dims w' h' -> (w',h') - Absolute -> (100,100) - -psfileName :: Lens' (Options Postscript R2) String +psfileName :: Lens' (Options Postscript V2 Double) String psfileName = lens (\(PostscriptOptions {_psfileName = f}) -> f) (\o f -> o {_psfileName = f}) -psSizeSpec :: Lens' (Options Postscript R2) SizeSpec2D +psSizeSpec :: Lens' (Options Postscript V2 Double) (SizeSpec V2 Double) psSizeSpec = lens (\(PostscriptOptions {_psSizeSpec = s}) -> s) (\o s -> o {_psSizeSpec = s}) -psOutputFormat :: Lens' (Options Postscript R2) OutputFormat +psOutputFormat :: Lens' (Options Postscript V2 Double) OutputFormat psOutputFormat = lens (\(PostscriptOptions {_psOutputFormat = t}) -> t) (\o t -> o {_psOutputFormat = t}) renderDias :: (Semigroup m, Monoid m) => - Options Postscript R2 -> [QDiagram Postscript R2 m] -> IO [()] + Options Postscript V2 Double -> [QDiagram Postscript V2 Double 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) - + surfaceF surface = C.renderPagesWith surface rs dropMid (x, _, z) = (x,z) - optsdss = map (dropMid . adjustDia Postscript opts) ds - cSize = (combineSizes $ map fst optsdss) - g2o = scaling (sqrt (w * h)) - rs = map (toRender . toRTree g2o . snd) optsdss - - 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) + g2o = scaling (sqrt (w * h)) + rs = map (runRenderM . runC . toRender . toRTree g2o . snd) optsdss + sizes = map (specToSize 1 . view psSizeSpec . fst) optsdss + V2 w h = foldBy (liftA2 max) zero sizes -renderC :: (Renderable a Postscript, V a ~ R2) => a -> C.Render () -renderC a = case render Postscript a of C r -> r +renderC :: (Renderable a Postscript, V a ~ V2, N a ~ Double) => a -> RenderM () +renderC = runC . render Postscript --- | Handle \"miscellaneous\" style attributes (clip, font stuff, fill --- color and fill rule). -postscriptMiscStyle :: Style v -> C.Render () -postscriptMiscStyle s = +-- | Handle those style attributes for which we can immediately emit +-- postscript instructions as we encounter them in the tree (clip, font +-- size, fill rule, line width, cap, join, and dashing). Other +-- attributes (font face, slant, weight; fill color, stroke color, +-- opacity) must be accumulated. +postscriptStyle :: Style v Double -> RenderM () +postscriptStyle s = sequence_ . catMaybes $ [ handle clip - , handle fFace - , handle fSlant - , handle fWeight - , handle fSize - , handle fLocal - , handle fColor - , handle fColorCMYK , handle lFillRule + , handle lWidth + , handle lJoin + , handle lMiter + , handle lCap + , handle lDashing ] where - handle :: AttributeClass a => (a -> C.Render ()) -> Maybe (C.Render ()) + handle :: AttributeClass a => (a -> RenderM ()) -> Maybe (RenderM ()) handle f = f `fmap` getAttr s - clip = mapM_ (\p -> renderC p >> C.clip) . op Clip - 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.fillColor . getFillTexture - fColorCMYK c = C.fillColorCMYK (getFillColorCMYK c) - lFillRule = assign (C.drawState . C.fillRule) . getFillRule + clip = mapM_ (\p -> postscriptPath p >> liftC C.clip) . op Clip + lFillRule = liftC . assign (C.drawState . C.fillRule) . getFillRule + lWidth = liftC . C.lineWidth . getLineWidth + lCap = liftC . C.lineCap . getLineCap + lJoin = liftC . C.lineJoin . getLineJoin + lMiter = liftC . C.miterLimit . getLineMiterLimit + lDashing (getDashing -> Dashing ds offs) = liftC $ C.setDash ds offs fromFontSlant :: FontSlant -> C.FontSlant fromFontSlant FontSlantNormal = C.FontSlantNormal @@ -209,74 +232,94 @@ fromFontWeight FontWeightNormal = C.FontWeightNormal fromFontWeight FontWeightBold = C.FontWeightBold -postscriptStyle :: Style v -> C.Render () -postscriptStyle s = sequence_ -- foldr (>>) (return ()) - . catMaybes $ [ handle fColor - , handle fColorCMYK - , handle lColor - , handle lColorCMYK - , handle lWidth - , handle lJoin - , handle lMiter - , handle lCap - , handle lDashing - ] - where handle :: (AttributeClass a) => (a -> C.Render ()) -> Maybe (C.Render ()) - handle f = f `fmap` getAttr s - lColor = C.strokeColor . getLineTexture - lColorCMYK = C.strokeColorCMYK . getLineColorCMYK - fColor c = C.fillColor (getFillTexture c) >> C.fillPreserve - fColorCMYK c = C.fillColorCMYK (getFillColorCMYK c) >> C.fillPreserve - lWidth = C.lineWidth . fromOutput . getLineWidth - lCap = C.lineCap . getLineCap - lJoin = C.lineJoin . getLineJoin - lMiter = C.miterLimit . getLineMiterLimit - lDashing (getDashing -> Dashing ds offs) = - C.setDash (map fromOutput ds) (fromOutput offs) - -postscriptTransf :: Transformation R2 -> C.Render () +postscriptTransf :: Transformation V2 Double -> C.Render () postscriptTransf t = C.transform a1 a2 b1 b2 c1 c2 - where (R2 a1 a2) = apply t unitX - (R2 b1 b2) = apply t unitY - (R2 c1 c2) = transl t + where (V2 a1 a2) = apply t unitX + (V2 b1 b2) = apply t unitY + (V2 c1 c2) = transl t -instance Renderable (Segment Closed R2) Postscript where - render _ (Linear (OffsetClosed (R2 x y))) = C $ C.relLineTo x y - render _ (Cubic (R2 x1 y1) - (R2 x2 y2) - (OffsetClosed (R2 x3 y3))) - = C $ C.relCurveTo x1 y1 x2 y2 x3 y3 +instance Renderable (Segment Closed V2 Double) Postscript where + render _ (Linear (OffsetClosed v)) = C . liftC $ uncurry C.relLineTo (unr2 v) + render _ (Cubic (unr2 -> (x1, y1)) + (unr2 -> (x2, y2)) + (OffsetClosed (unr2 -> (x3, y3)))) + = C . liftC $ C.relCurveTo x1 y1 x2 y2 x3 y3 -instance Renderable (Trail R2) Postscript where - render _ t = flip withLine t $ renderT . lineSegments +instance Renderable (Trail V2 Double) Postscript where + render _ = withTrail renderLine renderLoop where - renderT segs = - C $ do - mapM_ renderC segs - when (isLoop t) C.closePath + renderLine ln = C $ do + mapM_ renderC (lineSegments ln) - -- We need to ignore the fill if we see a line. - -- Ignore fill is part of the drawing state, so - -- it will be cleared by the `restore` after this - -- primitive. - when (isLine t) $ (C.drawState . C.ignoreFill) .= True + -- remember that we saw a Line, so we will ignore fill attribute + ignoreFill .= True -instance Renderable (Path R2) Postscript where - render _ p = C $ C.newPath >> F.mapM_ renderTrail (op Path p) + renderLoop lp = C $ do + case loopSegments lp of + -- let closePath handle the last segment if it is linear + (segs, Linear _) -> mapM_ renderC segs + + -- otherwise we have to draw it explicitly + _ -> mapM_ renderC (lineSegments . cutLoop $ lp) + + liftC C.closePath + +instance Renderable (Path V2 Double) Postscript where + render _ p = C $ do + postscriptPath p + f <- getStyleAttrib getFillTexture + s <- getStyleAttrib getLineTexture + fk <- getStyleAttrib getFillColorCMYK + sk <- getStyleAttrib getLineColorCMYK + ign <- use ignoreFill + setFillColor f fk + when ((isJust f || isJust fk) && not ign) $ liftC C.fillPreserve + setStrokeColor s sk + liftC C.stroke + +setFillColor :: Maybe (Texture Double) -> Maybe (CMYK) -> RenderM () +setFillColor c cmyk = do + liftC $ maybe (return ()) C.fillColor c + liftC $ maybe (return ()) C.fillColorCMYK cmyk + +setStrokeColor :: Maybe (Texture Double) -> Maybe (CMYK) -> RenderM () +setStrokeColor c cmyk = do + liftC $ maybe (return ()) C.strokeColor c + liftC $ maybe (return ()) C.strokeColorCMYK cmyk + +postscriptPath :: Path V2 Double -> RenderM () +postscriptPath (Path trs) = do + liftC C.newPath + ignoreFill .= False + F.mapM_ renderTrail trs where renderTrail (viewLoc -> (unp2 -> pt, tr)) = do - uncurry C.moveTo pt + liftC $ uncurry C.moveTo pt renderC tr -instance Renderable Text Postscript where - 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 +if' :: Monad m => (a -> m ()) -> Maybe a -> m () +if' = maybe (return ()) + +instance Renderable (Text Double) Postscript where + render _ (Text tr al str) = C $ do + ff <- getStyleAttrib getFont + fs <- getStyleAttrib (fromFontSlant . getFontSlant) + fw <- getStyleAttrib (fromFontWeight . getFontWeight) + size' <- getStyleAttrib getFontSize + f <- getStyleAttrib getFillTexture + fk <- getStyleAttrib getFillColorCMYK + save + setFillColor f fk + liftC $ do + if' (assign (C.drawState . C.font . C.size)) size' + if' (assign (C.drawState . C.font . C.face)) ff + if' (assign (C.drawState . C.font . C.slant)) fs + if' (assign (C.drawState . C.font . C.weight)) fw + when (isJust f || isJust fk) $ liftC C.fillPreserve + liftC $ postscriptTransf tr case al of - BoxAlignedText xt yt -> C.showTextAlign xt yt str - BaselineText -> C.moveTo 0 0 >> C.showText str - C.restore + BoxAlignedText xt yt -> liftC $ C.showTextAlign xt yt str + BaselineText -> liftC $ C.moveTo 0 0 >> C.showText str + restore -- $PostscriptOptions -- @@ -284,8 +327,8 @@ -- associated data families, so we must just provide it manually. -- This module defines -- --- > data family Options Postscript R2 = PostscriptOptions --- > { psfileName :: String -- ^ the name of the file you want generated --- > , psSizeSpec :: SizeSpec2D -- ^ the requested size of the output --- > , psOutputFormat :: OutputFormat -- ^ the output format and associated options +-- > data family Options Postscript V2 Double = PostscriptOptions +-- > { _psfileName :: String -- ^ the name of the file you want generated +-- > , _psSizeSpec :: SizeSpec V2 Double -- ^ the requested size of the output +-- > , _psOutputFormat :: OutputFormat -- ^ the output format and associated options -- > } diff --git a/src/Diagrams/Backend/Postscript/CMYK.hs b/src/Diagrams/Backend/Postscript/CMYK.hs --- a/src/Diagrams/Backend/Postscript/CMYK.hs +++ b/src/Diagrams/Backend/Postscript/CMYK.hs @@ -27,7 +27,7 @@ ) where -import Control.Lens (Setter', sets) +import Control.Lens (Setter', sets, (.~)) import Data.Default.Class import Data.Maybe (fromMaybe) import Data.Monoid.Recommend @@ -35,7 +35,6 @@ import Data.Typeable import Diagrams.Core -import Diagrams.Core.Style (setAttr) import Graphics.Rendering.Postscript(CMYK(..)) ------------------------------------------------------------ @@ -64,7 +63,10 @@ mkLineColorCMYK :: CMYK -> LineColorCMYK mkLineColorCMYK = LineColorCMYK . Last -styleLineColorCMYK :: Setter' (Style v) CMYK +setAttr :: AttributeClass a => a -> Style v n -> Style v n +setAttr a = atAttr .~ Just a + +styleLineColorCMYK :: Setter' (Style v Double ) CMYK styleLineColorCMYK = sets modifyLineColorCMYK where modifyLineColorCMYK f s @@ -102,7 +104,7 @@ mkFillColorCMYK :: CMYK -> FillColorCMYK mkFillColorCMYK = FillColorCMYK . Commit . Last -styleFillColorCMYK :: Setter' (Style v) CMYK +styleFillColorCMYK :: Setter' (Style v Double) CMYK styleFillColorCMYK = sets modifyFillColorCMYK where modifyFillColorCMYK f s @@ -128,5 +130,3 @@ -- | A synonym for 'fillColorCMYK' fcCMYK :: HasStyle a => CMYK -> a -> a fcCMYK = fillColorCMYK - - 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 @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -72,15 +72,12 @@ ) where -import Diagrams.Prelude hiding (width, height, interval, option, value, (<>)) -import Diagrams.Backend.Postscript -import Diagrams.Backend.CmdLine - -import Control.Lens - -import Prelude +import Diagrams.Backend.CmdLine +import Diagrams.Backend.Postscript +import Diagrams.Prelude hiding (height, interval, option, + output, value, width, (<>)) -import Data.List.Split +import Data.List.Split -- $mainwith -- The 'mainWith' method unifies all of the other forms of @main@ and is @@ -92,7 +89,7 @@ -- and color arguments. -- -- > ... definitions ... --- > f :: Int -> Colour Double -> Diagram Postscript R2 +-- > f :: Int -> Colour Double -> QDiagram Postscript V2 Double Any -- > f i c = ... -- > -- > main = mainWith f @@ -144,36 +141,30 @@ -- $ ./MyDiagram -o image.eps -w 400 -- @ -defaultMain :: Diagram Postscript R2 -> IO () +defaultMain :: QDiagram Postscript V2 Double Any -> IO () defaultMain = mainWith -instance Mainable (Diagram Postscript R2) where - type MainOpts (Diagram Postscript R2) = DiagramOpts +instance Mainable (QDiagram Postscript V2 Double Any) where + type MainOpts (QDiagram Postscript V2 Double Any) = DiagramOpts mainRender opts d = chooseRender opts (renderDia' d) -chooseRender :: DiagramOpts -> (Options Postscript R2 -> IO ()) -> IO () +chooseRender :: DiagramOpts -> (Options Postscript V2 Double -> IO ()) -> IO () chooseRender opts renderer = case splitOn "." (opts^.output) of [""] -> putStrLn "No output file given." ps | last ps `elem` ["eps"] || last ps `elem` ["ps"] -> do - let outfmt = case last ps of - _ -> EPS - sizeSpec = case (opts^.width, opts^.height) of - (Nothing, Nothing) -> Absolute - (Just w, Nothing) -> Width (fromIntegral w) - (Nothing, Just h) -> Height (fromIntegral h) - (Just w, Just h) -> Dims (fromIntegral w) - (fromIntegral h) + let outfmt = EPS + sizeSpec = fromIntegral <$> mkSizeSpec2D (opts^.width) (opts^.height) renderer (PostscriptOptions (opts^.output) sizeSpec outfmt) | otherwise -> putStrLn $ "Unknown file type: " ++ last ps -renderDias' :: [Diagram Postscript R2] -> Options Postscript R2 -> IO () +renderDias' :: [QDiagram Postscript V2 Double Any] -> Options Postscript V2 Double -> IO () renderDias' ds o = renderDias o ds >> return () -renderDia' :: Diagram Postscript R2 -> Options Postscript R2 -> IO () +renderDia' :: QDiagram Postscript V2 Double Any -> Options Postscript V2 Double -> IO () renderDia' d o = renderDia Postscript o d >> return () @@ -196,11 +187,11 @@ -- $ ./MultiTest --selection bar -o Bar.eps -w 200 -- @ -multiMain :: [(String, Diagram Postscript R2)] -> IO () +multiMain :: [(String, QDiagram Postscript V2 Double Any)] -> IO () multiMain = mainWith -instance Mainable [(String,Diagram Postscript R2)] where - type MainOpts [(String,Diagram Postscript R2)] = (DiagramOpts, DiagramMultiOpts) +instance Mainable [(String,QDiagram Postscript V2 Double Any)] where + type MainOpts [(String,QDiagram Postscript V2 Double Any)] = (DiagramOpts, DiagramMultiOpts) mainRender = defaultMultiMainRender @@ -217,11 +208,11 @@ -- $ ./MultiPage -o Pages.ps -w 200 -- @ -pagesMain :: [Diagram Postscript R2] -> IO () +pagesMain :: [QDiagram Postscript V2 Double Any] -> IO () pagesMain = mainWith -instance Mainable [Diagram Postscript R2] where - type MainOpts [Diagram Postscript R2] = DiagramOpts +instance Mainable [QDiagram Postscript V2 Double Any] where + type MainOpts [QDiagram Postscript V2 Double Any] = DiagramOpts mainRender opts ds = chooseRender opts (renderDias' ds) @@ -241,10 +232,10 @@ -- -- The @--fpu@ option can be used to control how many frames will be -- output for each second (unit time) of animation. -animMain :: Animation Postscript R2 -> IO () +animMain :: Animation Postscript V2 Double -> IO () animMain = mainWith -instance Mainable (Animation Postscript R2) where - type MainOpts (Animation Postscript R2) = (DiagramOpts, DiagramAnimOpts) +instance Mainable (Animation Postscript V2 Double) where + type MainOpts (Animation Postscript V2 Double) = (DiagramOpts, DiagramAnimOpts) - mainRender = defaultAnimMainRender output + mainRender = defaultAnimMainRender mainRender output 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 @@ -1,4 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | @@ -67,25 +69,30 @@ , FontWeight(..) , face, slant, weight, size, isLocal - , fillRule, ignoreFill, font + , fillRule, font , CMYK(..), cyan, magenta, yellow, blacK ) where -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 -import Control.Monad.State -import Control.Lens (makeLenses, use, (%=), (.=)) -import Data.List(intersperse) -import Data.DList(DList,toList,fromList) -import Data.Char(ord,isPrint) -import Numeric(showIntAtBase) -import System.IO (openFile, hPutStr, IOMode(..), hClose) +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif +import Control.Lens (Lens', makeLenses, use, (%=), (.=)) +import Control.Monad.State +import Control.Monad.Writer +import Data.Char (isPrint, ord) +import Data.DList (DList, fromList, toList) +import Data.List (intersperse) +import Diagrams.Attributes (Color (..), LineCap (..), + LineJoin (..), SomeColor (..), + colorToSRGBA) +import Diagrams.TwoD.Attributes (Texture (..)) +import Diagrams.TwoD.Path hiding (fillRule, stroke) +import Numeric (showIntAtBase) +import System.IO (IOMode (..), hClose, hPutStr, + openFile) -data CMYK = CMYK +data CMYK = CMYK { _cyan :: Double , _magenta :: Double , _yellow :: Double @@ -106,10 +113,10 @@ deriving (Show, Eq) data PostscriptFont = PostscriptFont - { _face :: String - , _slant :: FontSlant - , _weight :: FontWeight - , _size :: Double + { _face :: String + , _slant :: FontSlant + , _weight :: FontWeight + , _size :: Double , _isLocal :: Bool } deriving (Eq, Show) @@ -124,14 +131,13 @@ data DrawState = DS { _fillRule :: FillRule , _font :: PostscriptFont - , _ignoreFill :: Bool } deriving (Eq) makeLenses ''DrawState -- This reflects the defaults from the standard. emptyDS :: DrawState -emptyDS = DS Winding defaultFont False +emptyDS = DS Winding defaultFont data RenderState = RS { _drawState :: DrawState -- The current state. @@ -254,18 +260,14 @@ fill :: Render () fill = do - ign <- use $ drawState . ignoreFill rule <- use $ drawState . fillRule - unless ign $ - case rule of - Winding -> renderPS "fill" - EvenOdd -> renderPS "eofill" + case rule of + Winding -> renderPS "fill" + EvenOdd -> renderPS "eofill" -- | Fill the current path without affecting the graphics state. fillPreserve :: Render () fillPreserve = do - ign <- use $ drawState . ignoreFill - unless ign $ do gsave fill grestore @@ -361,12 +363,12 @@ where (r,g,b,_) = colorToSRGBA c -- | Set the color of the stroke. Ignore gradients. -strokeColor :: Texture -> Render () +strokeColor :: Texture n -> Render () strokeColor (SC (SomeColor c)) = mkPSCall "setrgbcolor" (colorPS c) strokeColor _ = return () -- | Set the color of the fill. Ignore gradients. -fillColor :: Texture -> Render () +fillColor :: Texture n -> Render () fillColor (SC (SomeColor c)) = mkPSCall "setrgbcolor" (colorPS c) fillColor _ = return () @@ -489,6 +491,7 @@ s <- show <$> f size renderPS $ concat ["/", n, " ", s, " selectfont"] where + f :: Lens' PostscriptFont a -> Render a f x = use $ drawState . font . x -- This is a little hacky. I'm not sure there are good options.