diagrams-postscript 1.1.0.5 → 1.3.0.0
raw patch · 6 files changed
+264/−221 lines, 6 filesdep +statestackdep −vector-spacedep ~basedep ~diagrams-coredep ~diagrams-lib
Dependencies added: statestack
Dependencies removed: vector-space
Dependency ranges changed: base, diagrams-core, diagrams-lib, monoid-extras
Files
- LICENSE +4/−1
- diagrams-postscript.cabal +11/−8
- src/Diagrams/Backend/Postscript.hs +186/−143
- src/Diagrams/Backend/Postscript/CMYK.hs +6/−6
- src/Diagrams/Backend/Postscript/CmdLine.hs +25/−34
- src/Graphics/Rendering/Postscript.hs +32/−29
LICENSE view
@@ -1,10 +1,13 @@-Copyright 2011-2014:+Copyright 2011-2015: Ryan Yates <fryguybob@gmail.com> Daniel Bergey <bergey@alum.mit.edu> Jan Bracker <jan.bracker@googlemail.com>+ Christopher Chalmers <c.chalmers@me.com>+ Tim Docker <tim@dockerz.net> Jeffrey Rosenbluth <jeffrey.rosenbluth@gmail.com>+ Ryan Scott <ryan.gl.scott@ku.edu> Michael Sloan <mgsloan@gmail.com> Brent Yorgey <byorgey@gmail.com>
diagrams-postscript.cabal view
@@ -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,
src/Diagrams/Backend/Postscript.hs view
@@ -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 -- > }
src/Diagrams/Backend/Postscript/CMYK.hs view
@@ -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--
src/Diagrams/Backend/Postscript/CmdLine.hs view
@@ -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
src/Graphics/Rendering/Postscript.hs view
@@ -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.