diagrams-postscript (empty) → 0.6
raw patch · 6 files changed
+1005/−0 lines, 6 filesdep +basedep +cmdargsdep +diagrams-coresetup-changed
Dependencies added: base, cmdargs, diagrams-core, diagrams-lib, dlist, monoid-extras, mtl, semigroups, split, vector-space
Files
- LICENSE +32/−0
- Setup.hs +3/−0
- diagrams-postscript.cabal +43/−0
- src/Diagrams/Backend/Postscript.hs +243/−0
- src/Diagrams/Backend/Postscript/CmdLine.hs +214/−0
- src/Graphics/Rendering/Postscript.hs +470/−0
+ LICENSE view
@@ -0,0 +1,32 @@+Copyright Ryan Yates 2011-2013++PostScript (TM) is a trademark of Adobe.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Ryan Yates nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ diagrams-postscript.cabal view
@@ -0,0 +1,43 @@+Name: diagrams-postscript+Version: 0.6+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+ based on command line options.+ .+ * "Diagrams.Backend.Postscript" - Provides the+ general API for rendering diagrams using the+ Postscript backend.+Homepage: http://projects.haskell.org/diagrams/+License: BSD3+License-file: LICENSE+Author: Ryan Yates+Maintainer: diagrams-discuss@googlegroups.com+Bug-reports: http://github.com/diagrams/diagrams-postscript/issues+Category: Graphics+Build-type: Simple+Cabal-version: >=1.10+Source-repository head+ type: git+ location: https://github.com/diagrams/diagrams-postscript.git++Library+ Exposed-modules: Diagrams.Backend.Postscript+ Diagrams.Backend.Postscript.CmdLine+ Graphics.Rendering.Postscript+ Hs-source-dirs: src+ Build-depends: base >= 4.2 && < 4.7,+ mtl >= 2.0 && < 2.2,+ dlist >= 0.5 && < 0.6,+ vector-space >= 0.7.7 && < 0.9,+ diagrams-core >= 0.6 && < 0.7,+ diagrams-lib >= 0.6 && < 0.7,+ cmdargs >= 0.6 && < 0.11,+ split >= 0.1.2 && < 0.3,+ monoid-extras >= 0.2.2 && < 0.3,+ semigroups >= 0.3.4 && < 0.10+ default-language: Haskell2010+
+ src/Diagrams/Backend/Postscript.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , FlexibleContexts+ , TypeSynonymInstances+ , DeriveDataTypeable+ , ViewPatterns+ , NoMonomorphismRestriction+ #-}++-----------------------------------------------------------------------------+-- |+-- Module : Diagrams.Backend.Postscript+-- Copyright : (c) 2013 Diagrams team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- A Postscript rendering backend for diagrams.+--+-- To build diagrams for Postscript rendering use the @Postscript@+-- type in the diagram type construction+--+-- > d :: Diagram Postscript R2+-- > d = ...+--+-- and render giving the @Postscript@ token+--+-- > renderDia Postscript (PostscriptOptions "file.eps" (Width 400) EPS) d+--+-- This IO action will write the specified file.+--+-----------------------------------------------------------------------------+module Diagrams.Backend.Postscript++ ( -- * Backend token+ Postscript(..)++ -- * Postscript-specific options+ -- $PostscriptOptions++ , Options(..)++ -- * Postscript-supported output formats+ , OutputFormat(..)+ ) where+++import qualified Graphics.Rendering.Postscript as C++import Diagrams.Prelude++import Diagrams.Core.Transform++import Diagrams.TwoD.Ellipse+import Diagrams.TwoD.Shapes+import Diagrams.TwoD.Adjust (adjustDia2D)+import Diagrams.TwoD.Size (requiredScaleT)+import Diagrams.TwoD.Text+import Diagrams.TwoD.Path (Clip(..), getFillRule)++import Control.Applicative ((<$>))+import Control.Monad (when)+import Data.Maybe (catMaybes, fromMaybe)++import Data.VectorSpace++import Data.Monoid hiding ((<>))+import Data.Monoid.MList+import Data.Monoid.Split+import qualified Data.List.NonEmpty as N+import qualified Data.Foldable as F+import Data.Typeable++-- | This data declaration is simply used as a token to distinguish this rendering engine.+data Postscript = Postscript+ deriving (Eq,Ord,Read,Show,Typeable)++-- | 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.++instance Monoid (Render Postscript R2) where+ mempty = C $ return ()+ (C r1) `mappend` (C r2) = C (r1 >> r2)+++instance Backend Postscript R2 where+ data Render Postscript R2 = C (C.Render ())+ type Result Postscript R2 = IO ()+ data 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+ }++ 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) =+ 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++ in case out of+ EPS -> C.withEPSSurface file (round w) (round h) surfaceF++ adjustDia c opts d = adjustDia2D psSizeSpec setPsSize c opts d+ where setPsSize sz o = o { psSizeSpec = sz }+ +sizeFromSpec size = case size of+ Width w' -> (w',w')+ Height h' -> (h',h')+ Dims w' h' -> (w',h')+ Absolute -> (100,100)++instance MultiBackend Postscript R2 where+ renderDias b opts ds = doRenderPages b (combineSizes (map fst rs)) (map snd rs) >> return ()+ where+ mkMax (a,b) = (Max a, Max b)+ fromMaxPair (Max a, Max b) = (a,b)++ 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))++ combineSizes (o:os) = o { psSizeSpec = uncurry Dims . fromMaxPair . sconcat $ f o N.:| fmap f os }+ where f = mkMax . sizeFromSpec . psSizeSpec+ + doRenderPages _ (PostscriptOptions file size out) rs =+ let surfaceF surface = C.renderPagesWith surface (map (\(C r) -> r) rs)+ (w,h) = sizeFromSpec size+ in case out of+ EPS -> C.withEPSSurface file (round w) (round h) surfaceF++renderC :: (Renderable a Postscript, V a ~ R2) => a -> C.Render ()+renderC a = case render Postscript a of C r -> r++-- | Handle \"miscellaneous\" style attributes (clip, font stuff, fill+-- color and fill rule).+postscriptMiscStyle :: Style v -> C.Render ()+postscriptMiscStyle s =+ sequence_+ . catMaybes $ [ handle clip+ , handle fFace+ , handle fSlant+ , handle fWeight+ , handle fSize+ , handle fColor+ , handle lFillRule+ ]+ where handle :: AttributeClass a => (a -> C.Render ()) -> Maybe (C.Render ())+ handle f = f `fmap` getAttr s+ clip = mapM_ (\p -> renderC p >> C.clip) . getClip+ fSize = C.setFontSize <$> getFontSize+ fFace = C.setFontFace <$> getFont+ fSlant = C.setFontSlant . fromFontSlant <$> getFontSlant+ fWeight = C.setFontWeight . fromFontWeight <$> getFontWeight+ fColor c = C.fillColor (getFillColor c)+ lFillRule = C.setFillRule . getFillRule++fromFontSlant :: FontSlant -> C.FontSlant+fromFontSlant FontSlantNormal = C.FontSlantNormal+fromFontSlant FontSlantItalic = C.FontSlantItalic+fromFontSlant FontSlantOblique = C.FontSlantOblique++fromFontWeight :: FontWeight -> C.FontWeight+fromFontWeight FontWeightNormal = C.FontWeightNormal+fromFontWeight FontWeightBold = C.FontWeightBold++postscriptStyle :: Style v -> C.Render ()+postscriptStyle s = sequence_ -- foldr (>>) (return ())+ . catMaybes $ [ handle fColor+ , handle lColor+ , handle lWidth+ , handle lJoin+ , handle lCap+ , handle lDashing+ ]+ where handle :: (AttributeClass a) => (a -> C.Render ()) -> Maybe (C.Render ())+ handle f = f `fmap` getAttr s+ lColor = C.strokeColor . getLineColor+ fColor c = C.fillColor (getFillColor c) >> C.fillPreserve+ lWidth = C.lineWidth . getLineWidth+ lCap = C.lineCap . getLineCap+ lJoin = C.lineJoin . getLineJoin+ lDashing (getDashing -> Dashing ds offs) =+ C.setDash ds offs++postscriptTransf :: Transformation R2 -> C.Render ()+postscriptTransf t = C.transform a1 a2 b1 b2 c1 c2+ where (a1,a2) = unr2 $ apply t unitX+ (b1,b2) = unr2 $ apply t unitY+ (c1,c2) = unr2 $ transl t++instance Renderable (Segment R2) Postscript where+ render _ (Linear (unr2 -> v)) = C $ uncurry C.relLineTo v+ render _ (Cubic (unr2 -> (x1,y1))+ (unr2 -> (x2,y2))+ (unr2 -> (x3,y3))) = C $ C.relCurveTo x1 y1 x2 y2 x3 y3++instance Renderable (Trail R2) Postscript where+ render _ (Trail segs c) = C $ do+ mapM_ renderC segs+ when c C.closePath++instance Renderable (Path R2) Postscript where+ render _ (Path trs) = C $ C.newPath >> F.mapM_ renderTrail trs+ where renderTrail (p, tr) = do+ uncurry C.moveTo (unp2 p)+ renderC tr++instance Renderable Text Postscript where+ render _ (Text tr al str) = C $ do+ C.save+ postscriptTransf tr+ case al of+ BoxAlignedText xt yt -> C.showTextAlign xt yt str+ BaselineText -> C.moveTo 0 0 >> C.showText str+ C.restore++-- $PostscriptOptions+--+-- Unfortunately, Haddock does not yet support documentation for+-- 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+-- > }
+ src/Diagrams/Backend/Postscript/CmdLine.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE DeriveDataTypeable, NoMonomorphismRestriction #-}+-----------------------------------------------------------------------------+-- |+-- Module : Diagrams.Backend.Postscript.CmdLine+-- Copyright : (c) 2013 Diagrams team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- Convenient creation of command-line-driven executables for+-- rendering diagrams using the Postscript backend.+--+-- * 'defaultMain' creates an executable which can render a single+-- diagram at various options.+--+-- * 'multiMain' is like 'defaultMain' but allows for a list of+-- diagrams from which the user can choose one to render.+--+-- * 'pagesMain' is like 'defaultMain' but renders a list of+-- diagrams as pages in a single file.+--+-- If you want to generate diagrams programmatically---/i.e./ if you+-- want to do anything more complex than what the below functions+-- provide---you have several options.+--+-- * A simple but somewhat inflexible approach is to wrap up+-- 'defaultMain' (or 'multiMain', or 'pagesMain') in a call to+-- 'System.Environment.withArgs'.+--+-- * A more flexible approach is to directly call 'renderDia'; see+-- "Diagrams.Backend.Postscript" for more information.+--+-----------------------------------------------------------------------------++module Diagrams.Backend.Postscript.CmdLine+ ( defaultMain+ , multiMain+ , pagesMain+ , Postscript+ ) where++import Diagrams.Prelude hiding (width, height, interval)+import Diagrams.Backend.Postscript++import System.Console.CmdArgs.Implicit hiding (args)++import Prelude++import Data.Maybe (fromMaybe)+import Control.Applicative ((<$>))+import Control.Monad (when)+import Data.List.Split+import Data.List (intercalate)++import System.Environment (getArgs, getProgName)++data DiagramOpts = DiagramOpts+ { width :: Maybe Int+ , height :: Maybe Int+ , output :: FilePath+ , selection :: Maybe String+ , list :: Bool+ }+ deriving (Show, Data, Typeable)++diagramOpts :: String -> Bool -> DiagramOpts+diagramOpts prog sel = DiagramOpts+ { width = def+ &= typ "INT"+ &= help "Desired width of the output image (default 400)"++ , height = def+ &= typ "INT"+ &= help "Desired height of the output image (default 400)"++ , output = def+ &= typFile+ &= help "Output file"++ , selection = def+ &= help "Name of the diagram to render"+ &= (if sel then typ "NAME" else ignore)++ , list = def+ &= (if sel then help "List all available diagrams" else ignore)+ }+ &= summary "Command-line diagram generation."+ &= program prog++-- | This is the simplest way to render diagrams, and is intended to+-- be used like so:+--+-- > ... other definitions ...+-- > myDiagram = ...+-- >+-- > main = defaultMain myDiagram+--+-- Compiling a source file like the above example will result in an+-- executable which takes command-line options for setting the size,+-- output file, and so on, and renders @myDiagram@ with the+-- specified options.+--+-- Pass @--help@ to the generated executable to see all available+-- options. Currently it looks something like+--+-- @+-- Command-line diagram generation.+--+-- Foo [OPTIONS]+--+-- Common flags:+-- -w --width=INT Desired width of the output image+-- -h --height=INT Desired height of the output image+-- -o --output=FILE Output file+-- -? --help Display help message+-- -V --version Print version information+-- @+--+-- For example, a couple common scenarios include+--+-- @+-- $ ghc --make MyDiagram+--+-- # output image.png with a width of 400pt (and auto-determined height)+-- $ ./MyDiagram -o image.eps -w 400+-- @++defaultMain :: Diagram Postscript R2 -> IO ()+defaultMain d = do+ prog <- getProgName+ opts <- cmdArgs (diagramOpts prog False)+ chooseRender opts (renderDia' d)++chooseRender :: DiagramOpts -> (Options Postscript R2 -> IO ()) -> IO ()+chooseRender opts render =+ case splitOn "." (output opts) 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 (width opts, height opts) 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)++ render (PostscriptOptions (output opts) 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 ()++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.+-- The generated executable then takes a @--selection@ option+-- specifying the name of the diagram that should be rendered. The+-- list of available diagrams may also be printed by passing the+-- option @--list@.+--+-- Example usage:+--+-- @+-- $ ghc --make MultiTest+-- [1 of 1] Compiling Main ( MultiTest.hs, MultiTest.o )+-- Linking MultiTest ...+-- $ ./MultiTest --list+-- Available diagrams:+-- foo bar+-- $ ./MultiTest --selection bar -o Bar.eps -w 200+-- @++multiMain :: [(String, Diagram Postscript R2)] -> IO ()+multiMain ds = do+ prog <- getProgName+ opts <- cmdArgs (diagramOpts prog True)+ if list opts+ then showDiaList (map fst ds)+ else+ case selection opts of+ Nothing -> putStrLn "No diagram selected." >> showDiaList (map fst ds)+ Just sel -> case lookup sel ds of+ Nothing -> putStrLn $ "Unknown diagram: " ++ sel+ Just d -> chooseRender opts (renderDia' d)++-- | Display the list of diagrams available for rendering.+showDiaList :: [String] -> IO ()+showDiaList ds = do+ putStrLn "Available diagrams:"+ putStrLn $ " " ++ intercalate " " ds ++-- | @pagesMain@ is like 'defaultMain', except instead of a single+-- diagram it takes a list of diagrams and each wil be rendered as a page+-- in the Postscript file.+--+-- Example usage:+--+-- @+-- $ ghc --make MultiPage+-- [1 of 1] Compiling Main ( MultiPage.hs, MultiPage.o )+-- Linking MultiPage ...+-- $ ./MultiPage -o Pages.ps -w 200+-- @++pagesMain :: [Diagram Postscript R2] -> IO ()+pagesMain ds = do+ prog <- getProgName+ opts <- cmdArgs (diagramOpts prog False)+ chooseRender opts (renderDias' ds)+
+ src/Graphics/Rendering/Postscript.hs view
@@ -0,0 +1,470 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, RecordWildCards #-}+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Postscript+-- Copyright : (c) 2013 diagrams team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- Generic tools for generating Postscript files. There is some+-- limited support for tracking the state of the renderer when+-- given a side-effecting (in the Postscript) command. Only drawing+-- operations are supported, not general Postscript language generation.+--+-- In the future the tracking of rendering state could lead to optimizing+-- output, but for now little optimization is attempted. Most systems are+-- equiped with tools to optimize Postscript such as 'eps2eps'.+--+-- For details on the PostScript language see the PostScript(R) Language+-- Reference: <http://www.adobe.com/products/postscript/pdfs/PLRM.pdf>+-----------------------------------------------------------------------------+module Graphics.Rendering.Postscript+ ( Render+ , RenderState+ , Surface+ , PSWriter(..)+ , renderWith+ , renderPagesWith+ , withEPSSurface+ , newPath+ , moveTo+ , lineTo+ , curveTo+ , relLineTo+ , relCurveTo+ , arc+ , closePath+ , stroke+ , fill+ , fillPreserve+ , transform+ , save+ , restore+ , gsave+ , grestore+ , saveMatrix+ , restoreMatrix+ , translate+ , scale+ , rotate+ , strokeColor+ , fillColor+ , lineWidth+ , lineCap+ , lineJoin+ , setDash+ , setFillRule+ , showText+ , showTextCentered+ , showTextAlign+ , showTextInBox+ , clip+ + , FontSlant(..)+ , FontWeight(..)+ , setFontFace+ , setFontSlant+ , setFontWeight+ , setFontSize+ ) where++import Diagrams.Attributes(Color(..),LineCap(..),LineJoin(..),colorToSRGBA)+import Diagrams.TwoD.Path hiding (stroke)+import Control.Monad.Writer+import Control.Monad.State+import Control.Monad(when)+import Data.List(intersperse)+import Data.DList(DList,toList,fromList)+import Data.Word(Word8)+import Data.Char(ord,isPrint)+import Numeric(showIntAtBase)+import System.IO (openFile, hPutStr, IOMode(..), hClose)++-- Here we want to mirror the state of side-effecting calls+-- that we have emitted into the postscript file (at least+-- ones that we do not protect in other ways).+data DrawState = DS+ { _fillRule :: FillRule+ , _font :: PostscriptFont+ } deriving (Eq)++-- This reflects the defaults from the standard.+emptyDS :: DrawState+emptyDS = DS Winding defaultFont++data RenderState = RS+ { _drawState :: DrawState -- The current state.+ , _saved :: [DrawState] -- A stack of passed states pushed by save and poped with restore.+ }++emptyRS :: RenderState+emptyRS = RS emptyDS []++-- ++-- | Type for a monad that writes Postscript using the commands we will define later.+newtype PSWriter m = PSWriter { runPSWriter :: WriterT (DList String) IO m }+ deriving (Functor, Monad, MonadWriter (DList String))++-- | Type of the monad that tracks the state from side-effecting commands.+newtype Render m = Render { runRender :: StateT RenderState PSWriter m }+ deriving (Functor, Monad, MonadState RenderState)++-- | Abstraction of the drawing surface details.+data Surface = Surface { header :: Int -> String, footer :: Int -> String, width :: Int, height :: Int, fileName :: String } ++doRender :: Render a -> PSWriter a+doRender r = evalStateT (runRender r) emptyRS++-- | Handles opening and closing the file associated with the+-- passed 'Surface' and renders the commands built up in the+-- 'Render' argument.+renderWith :: MonadIO m => Surface -> Render a -> m a+renderWith s r = liftIO $ do + (v,ss) <- runWriterT . runPSWriter . doRender $ r+ h <- openFile (fileName s) WriteMode+ hPutStr h (header s 1)+ mapM_ (hPutStr h) (toList ss)+ hPutStr h (footer s 1)+ hClose h+ return v++-- | Renders multiple pages given as a list of 'Render' actions+-- to the file associated with the 'Surface' argument.+renderPagesWith :: MonadIO m => Surface -> [Render a] -> m [a]+renderPagesWith s rs = liftIO $ do + h <- openFile (fileName s) WriteMode+ hPutStr h (header s (length rs))+ + vs <- mapM (page h) (zip rs [1..])+ + hClose h+ return vs+ where + page h (r,i) = do+ (v,ss) <- runWriterT . runPSWriter . doRender $ r+ mapM_ (hPutStr h) (toList ss)+ hPutStr h (footer s i)+ return v++-- | Builds a surface and performs an action on that surface.+withEPSSurface :: String -> Int -> Int -> (Surface -> IO a) -> IO a+withEPSSurface file w h f = f s+ where s = Surface (epsHeader w h) epsFooter w h file++renderPS :: String -> Render ()+renderPS s = Render . lift . tell $ fromList [s, "\n"]++-- | Clip with the current path.+clip :: Render ()+clip = renderPS "clip"++mkPSCall :: Show a => String -> [a] -> Render()+mkPSCall n vs = renderPS . concat $ intersperse " " (map show vs) ++ [" ", n]++mkPSCall' :: String -> [String] -> Render()+mkPSCall' n vs = renderPS . concat $ intersperse " " vs ++ [" ", n]++-- | Start a new path.+newPath :: Render ()+newPath = renderPS "newpath"++-- | Close the current path.+closePath :: Render ()+closePath = renderPS "closepath"++-- | Draw an arc given a center, radius, start, and end angle.+arc :: Double -- ^ x-coordinate of center.+ -> Double -- ^ y-coordiante of center.+ -> Double -- ^ raidus.+ -> Double -- ^ start angle in radians.+ -> Double -- ^ end angle in radians.+ -> Render ()+arc a b c d e = mkPSCall "arc" [a,b,c, d * 180 / pi, e* 180 / pi]++-- | Move the current point.+moveTo :: Double -> Double -> Render ()+moveTo x y = mkPSCall "moveto" [x,y]++-- | Add a line to the current path from the current point to the given point.+-- The current point is also moved with this command.+lineTo :: Double -> Double -> Render ()+lineTo x y = mkPSCall "lineto" [x,y]++-- | Add a cubic Bézier curve segment to the current path from the current point.+-- The current point is also moved with this command.+curveTo :: Double -> Double -> Double -> Double -> Double -> Double -> Render ()+curveTo ax ay bx by cx cy = mkPSCall "curveto" [ax,ay,bx,by,cx,cy]++-- | Add a line segment to the current path using relative coordinates.+relLineTo :: Double -> Double -> Render ()+relLineTo x y = mkPSCall "rlineto" [x,y]++-- | Add a cubic Bézier curve segment to the current path from the current point+-- using relative coordinates.+relCurveTo :: Double -> Double -> Double -> Double -> Double -> Double -> Render ()+relCurveTo ax ay bx by cx cy = mkPSCall "rcurveto" [ax,ay,bx,by,cx,cy]++-- | Stroke the current path.+stroke :: Render ()+stroke = renderPS "s"++-- | Fill the current path.+fill :: Render ()+fill = do+ (RS (DS {..}) _) <- get+ case _fillRule of+ Winding -> renderPS "fill"+ EvenOdd -> renderPS "eofill"++-- | Fill the current path without affecting the graphics state.+fillPreserve :: Render ()+fillPreserve = do+ gsave+ fill+ grestore++-- | Draw a string at the current point.+showText :: String -> Render ()+showText s = do+ renderFont+ stringPS s+ renderPS " show"++-- | Draw a string by first measuring the width then offseting by half.+showTextCentered :: String -> Render ()+showTextCentered s = do+ renderFont+ stringPS s+ renderPS " showcentered"++-- | Draw a string uniformally scaling to fit within a bounding box.+showTextInBox :: (Double,Double) -> (Double,Double) -> String -> Render ()+showTextInBox (a,b) (c,d) s = do+ renderFont+ renderPS . unwords . map show $ [a,b,c,d]+ stringPS s+ renderPS " showinbox"++-- | Draw a string with offset factors from center relative to the width and height.+showTextAlign :: Double -> Double -> String -> Render ()+showTextAlign xt yt s = do+ renderFont+ renderPS . unwords . map show $ [xt, yt]+ stringPS s+ renderPS " showalign"++-- | Apply a transform matrix to the current transform.+transform :: Double -> Double -> Double -> Double -> Double -> Double -> Render ()+transform ax ay bx by tx ty = when (vs /= [1.0,0.0,0.0,1.0,0.0,0.0]) $+ renderPS (matrixPS vs ++ " concat")+ where vs = [ax,ay,bx,by,tx,ty]++matrixPS :: Show a => [a] -> String+matrixPS vs = unwords ("[" : map show vs ++ ["]"])++-- | Push the current state of the renderer onto the state stack.+save :: Render ()+save = do+ renderPS "save"+ modify $ \rs@(RS{..}) -> rs { _saved = _drawState : _saved }++-- | Replace the current state by popping the state stack.+restore :: Render ()+restore = do+ renderPS "restore"+ modify go+ where+ go rs@(RS{_saved = d:ds}) = rs { _drawState = d, _saved = ds }+ go rs = rs++-- | Push the current graphics state.+gsave :: Render ()+gsave = do+ renderPS "gsave"+ modify $ \rs@(RS{..}) -> rs { _saved = _drawState : _saved }++-- | Pop the current graphics state.+grestore :: Render ()+grestore = do+ renderPS "grestore"+ modify go+ where+ go rs@(RS{_saved = d:ds}) = rs { _drawState = d, _saved = ds }+ go rs = rs++-- | Push the current transform matrix onto the execution stack.+saveMatrix :: Render ()+saveMatrix = renderPS "matrix currentmatrix"++-- | Set the current transform matrix to be the matrix found by popping+-- the execution stack.+restoreMatrix :: Render ()+restoreMatrix = renderPS "setmatrix"++colorPS :: Color c => c -> [Double]+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 fill.+fillColor :: (Color c) => c -> Render ()+fillColor c = mkPSCall "setrgbcolor" (colorPS c)++-- | Set the line width.+lineWidth :: Double -> Render ()+lineWidth w = mkPSCall "setlinewidth" [w]++-- | Set the line cap style.+lineCap :: LineCap -> Render ()+lineCap lc = mkPSCall "setlinecap" [fromLineCap lc] ++-- | Set the line join method.+lineJoin :: LineJoin -> Render ()+lineJoin lj = mkPSCall "setlinejoin" [fromLineJoin lj]++-- | Set the dash style.+setDash :: [Double] -- ^ Dash pattern (even indices are "on").+ -> Double -- ^ Offset.+ -> Render ()+setDash as offset = mkPSCall' "setdash" [showArray as, show offset]++-- | Set the fill rule.+setFillRule :: FillRule -> Render ()+setFillRule r = modify (\rs@(RS ds _) -> rs { _drawState = ds { _fillRule = r } })++showArray :: Show a => [a] -> String+showArray as = concat ["[", concat $ intersperse " " (map show as), "]"]++fromLineCap :: LineCap -> Int+fromLineCap LineCapRound = 1+fromLineCap LineCapSquare = 2+fromLineCap _ = 0++fromLineJoin :: LineJoin -> Int+fromLineJoin LineJoinRound = 1+fromLineJoin LineJoinBevel = 2+fromLineJoin _ = 0++-- | Translate the current transform matrix.+translate :: Double -> Double -> Render ()+translate x y = mkPSCall "translate" [x,y]++-- | Scale the current transform matrix.+scale :: Double -> Double -> Render ()+scale x y = mkPSCall "scale" [x,y]++-- | Rotate the current transform matrix.+rotate :: Double -> Render ()+rotate t = mkPSCall "rotate" [t]++stringPS :: String -> Render ()+stringPS ss = Render $ lift (tell (fromList ("(" : map escape ss)) >> tell (fromList [")"]))+ where escape '\n' = "\\n"+ escape '\r' = "\\r"+ escape '\t' = "\\t"+ escape '\b' = "\\b"+ escape '\f' = "\\f"+ escape '\\' = "\\"+ escape '(' = "\\("+ escape ')' = "\\)"+ escape c | isPrint c = [c]+ | otherwise = '\\' : showIntAtBase 7 ("01234567"!!) (ord c) ""++epsHeader w h pages = concat+ [ "%!PS-Adobe-3.0", if pages == 1 then " EPSF-3.0\n" else "\n"+ , "%%Creator: diagrams-postscript 0.1\n"+ , "%%BoundingBox: 0 0 ", show w, " ", show h, "\n"+ , "%%Pages: ", show pages, "\n"+ , "%%EndComments\n\n"+ , "%%BeginProlog\n"+ , "%%BeginResource: procset diagrams-postscript 0 0\n"+ , "/s { 0.0 currentlinewidth ne { stroke } if } bind def\n"+ , "/nvhalf { 2 div neg exch 2 div neg exch } bind def\n"+ , "/showcentered { dup stringwidth nvhalf moveto show } bind def\n"+ , "/stringbbox { 0 0 moveto true charpath flattenpath pathbbox } bind def\n"+ , "/wh { 1 index 4 index sub 1 index 4 index sub } bind def\n"+ , "/showinbox { gsave dup stringbbox wh 11 7 roll mark 11 1 roll "+ , "wh dup 7 index div 2 index 9 index div 1 index 1 index lt "+ , "{ pop dup 9 index mul neg 3 index add 2 div 7 index add "+ , " 6 index 13 index abs add } "+ , "{ exch pop 6 index 12 index abs 2 index mul 7 index add } "+ , "ifelse 17 3 roll cleartomark 4 1 roll translate dup scale "+ , "0 0 moveto show grestore } bind def\n"+ , "/showalign { dup mark exch stringbbox wh 10 -1 roll exch 10 1 roll mul "+ , "neg 9 -2 roll mul 4 index add neg 8 2 roll cleartomark 3 1 roll moveto "+ , "show } bind def\n"+ , "%%EndResource\n"+ , "%%EndProlog\n"+ , "%%BeginSetup\n"+ , "%%EndSetup\n"+ , "%%Page: 1 1\n"+ ]+epsFooter page = concat+ [ "showpage\n"+ , "%%PageTrailer\n"+ , "%%EndPage: ", show page, "\n"+ ]++---------------------------+-- Font+data PostscriptFont = PostscriptFont+ { _face :: String+ , _slant :: FontSlant+ , _weight :: FontWeight+ , _size :: Double+ } deriving (Eq, Show)++data FontSlant = FontSlantNormal+ | FontSlantItalic+ | FontSlantOblique+ | FontSlant Double+ deriving (Show, Eq)++data FontWeight = FontWeightNormal+ | FontWeightBold+ deriving (Show, Eq)++defaultFont :: PostscriptFont+defaultFont = PostscriptFont "Helvetica" FontSlantNormal FontWeightNormal 1++renderFont :: Render ()+renderFont = do+ (RS (DS _ (PostscriptFont {..})) _) <- get+ renderPS $ concat ["/", fontFromName _face _slant _weight, " ", show _size, " selectfont"]++-- This is a little hacky. I'm not sure there are good options.+fontFromName :: String -> FontSlant -> FontWeight -> String+fontFromName n s w = font ++ bold w ++ italic s+ where+ font = map f n+ f ' ' = '-'+ f c = c++ bold FontWeightNormal = ""+ bold FontWeightBold = "Bold"++ italic FontSlantNormal = ""+ italic FontSlantItalic = "Italic"+ italic FontSlantOblique = "Oblique"+ italic _ = ""++-- | Set the font face.+setFontFace :: String -> Render ()+setFontFace n = modify (\rs@(RS ds@(DS {..}) _) -> rs { _drawState = ds { _font = _font { _face = n } } })++-- | Set the font slant.+setFontSlant :: FontSlant -> Render ()+setFontSlant s = modify (\rs@(RS ds@(DS {..}) _) -> rs { _drawState = ds { _font = _font { _slant = s } } })++-- | Set the font weight.+setFontWeight :: FontWeight -> Render ()+setFontWeight w = modify (\rs@(RS ds@(DS {..}) _) -> rs { _drawState = ds { _font = _font { _weight = w } } })++-- | Set the font size.+setFontSize :: Double -> Render ()+setFontSize s = modify (\rs@(RS ds@(DS {..}) _) -> rs { _drawState = ds { _font = _font { _size = s } } })+