diagrams-postscript 0.7.0.2 → 1.0
raw patch · 5 files changed
+269/−243 lines, 5 filesdep +lensdep −cmdargsdep ~diagrams-coredep ~diagrams-lib
Dependencies added: lens
Dependencies removed: cmdargs
Dependency ranges changed: diagrams-core, diagrams-lib
Files
- LICENSE +10/−1
- diagrams-postscript.cabal +5/−5
- src/Diagrams/Backend/Postscript.hs +63/−45
- src/Diagrams/Backend/Postscript/CmdLine.hs +100/−108
- src/Graphics/Rendering/Postscript.hs +91/−84
LICENSE view
@@ -1,4 +1,13 @@-Copyright Ryan Yates 2011-2013+Copyright 2011-2013:++ Ryan Yates <fryguybob@gmail.com>++ Daniel Bergey <bergey@alum.mit.edu>+ Jan Bracker <jan.bracker@googlemail.com>+ Jeffrey Rosenbluth <jeffrey.rosenbluth@gmail.com>+ Michael Sloan <mgsloan@gmail.com>+ Brent Yorgey <byorgey@gmail.com>+ PostScript (TM) is a trademark of Adobe.
diagrams-postscript.cabal view
@@ -1,5 +1,5 @@ Name: diagrams-postscript-Version: 0.7.0.2+Version: 1.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.@@ -35,11 +35,11 @@ filepath, dlist >= 0.5 && < 0.6, vector-space >= 0.7.7 && < 0.9,- diagrams-core >= 0.7 && < 0.8,- diagrams-lib >= 0.7 && < 0.8,- cmdargs >= 0.6 && < 0.11,+ diagrams-core >= 1.0 && < 1.1,+ diagrams-lib >= 1.0 && < 1.1, split >= 0.1.2 && < 0.3, monoid-extras >= 0.3 && < 0.4,- semigroups >= 0.3.4 && < 0.12+ semigroups >= 0.3.4 && < 0.12,+ lens >= 3.8 && < 4 default-language: Haskell2010
src/Diagrams/Backend/Postscript.hs view
@@ -34,11 +34,12 @@ ( -- * Backend token Postscript(..)+ , B -- * Postscript-specific options -- $PostscriptOptions - , Options(..)+ , Options(..), psfileName, psSizeSpec, psOutputFormat -- * Postscript-supported output formats , OutputFormat(..)@@ -47,27 +48,19 @@ import qualified Graphics.Rendering.Postscript as C -import Diagrams.Prelude--import Diagrams.Core.Transform+import Diagrams.Prelude hiding (view) import Diagrams.TwoD.Adjust (adjustDia2D)-import Diagrams.TwoD.Ellipse-import Diagrams.TwoD.Path (Clip (..), getFillRule)-import Diagrams.TwoD.Shapes-import Diagrams.TwoD.Size (requiredScaleT)+import Diagrams.TwoD.Path (Clip (Clip), getFillRule) import Diagrams.TwoD.Text+import Diagrams.TwoD.Types -import Control.Applicative ((<$>))+import Control.Lens hiding (transform) import Control.Monad (when)-import Data.Maybe (catMaybes, fromMaybe)--import Data.VectorSpace+import Data.Maybe (catMaybes) import qualified Data.Foldable as F import qualified Data.List.NonEmpty as N-import Data.Monoid hiding ((<>))-import Data.Monoid.MList import Data.Monoid.Split import Data.Typeable @@ -75,6 +68,8 @@ data Postscript = Postscript deriving (Eq,Ord,Read,Show,Typeable) +type B = Postscript+ -- | 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.@@ -82,16 +77,16 @@ instance Monoid (Render Postscript R2) where mempty = C $ return ()- (C r1) `mappend` (C r2) = C (r1 >> r2)+ (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- { 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+ { _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 } deriving Show @@ -115,20 +110,33 @@ 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 }+ adjustDia c opts d = adjustDia2D _psSizeSpec setPsSize c opts d+ where setPsSize sz o = o { _psSizeSpec = sz } +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 (\(PostscriptOptions {_psfileName = f}) -> f)+ (\o f -> o {_psfileName = f})++psSizeSpec :: Lens' (Options Postscript R2) SizeSpec2D+psSizeSpec = lens (\(PostscriptOptions {_psSizeSpec = s}) -> s)+ (\o s -> o {_psSizeSpec = s})++psOutputFormat :: Lens' (Options Postscript R2) OutputFormat+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 (a,b) = (Max a, Max b)- fromMaxPair (Max a, Max b) = (a,b)+ mkMax (x,y) = (Max x, Max y)+ fromMaxPair (Max x, Max y) = (x,y) rs = map mkRender ds mkRender d = (opts', mconcat . map renderOne . prims $ d')@@ -137,11 +145,12 @@ 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+ 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 - doRenderPages _ (PostscriptOptions file size out) rs =- let surfaceF surface = C.renderPagesWith surface (map (\(C r) -> r) rs)+ 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@@ -162,15 +171,16 @@ , 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+ where+ 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+ 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)+ lFillRule = assign (C.drawState . C.fillRule) . getFillRule fromFontSlant :: FontSlant -> C.FontSlant fromFontSlant FontSlantNormal = C.FontSlantNormal@@ -187,6 +197,7 @@ , handle lColor , handle lWidth , handle lJoin+ , handle lMiter , handle lCap , handle lDashing ]@@ -197,20 +208,21 @@ lWidth = C.lineWidth . getLineWidth lCap = C.lineCap . getLineCap lJoin = C.lineJoin . getLineJoin+ lMiter = C.miterLimit . getLineMiterLimit 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+ where (R2 a1 a2) = apply t unitX+ (R2 b1 b2) = apply t unitY+ (R2 c1 c2) = transl t instance Renderable (Segment Closed R2) Postscript where- render _ (Linear (OffsetClosed (unr2 -> v))) = C $ uncurry C.relLineTo v- render _ (Cubic (unr2 -> (x1,y1))- (unr2 -> (x2,y2))- (OffsetClosed (unr2 -> (x3,y3))))+ 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 (Trail R2) Postscript where@@ -221,10 +233,16 @@ mapM_ renderC segs when (isLoop t) C.closePath + -- 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+ instance Renderable (Path R2) Postscript where- render _ (Path trs) = C $ C.newPath >> F.mapM_ renderTrail trs- where renderTrail (viewLoc -> (unp2 -> p, tr)) = do- uncurry C.moveTo p+ render _ p = C $ C.newPath >> F.mapM_ renderTrail (op Path p)+ where renderTrail (viewLoc -> (unp2 -> pt, tr)) = do+ uncurry C.moveTo pt renderC tr instance Renderable Text Postscript where
src/Diagrams/Backend/Postscript/CmdLine.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE DeriveDataTypeable, NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Backend.Postscript.CmdLine@@ -18,84 +20,92 @@ -- * 'pagesMain' is like 'defaultMain' but renders a list of -- diagrams as pages in a single file. --+-- * 'animMain' renders an animation at a given frame rate+-- into separate files with an index number.+--+-- * 'mainWith' is a generic form that does all of the above but with+-- a slightly scarier type. See "Diagrams.Backend.CmdLine". This+-- form can also take a function type that has a subtable final result+-- (any of arguments to the above types) and 'Parseable' arguments.+-- -- 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'.+-- * Use a function with 'mainWith'. This may require making+-- 'Parseable' instances for custom argument types. ----- * A more flexible approach is to directly call 'renderDia'; see+-- * Make a new 'Mainable' instance. This may require a newtype+-- wrapper on your diagram type to avoid the existing instances.+-- This gives you more control over argument parsing, intervening+-- steps, and diagram creation.+--+-- * Build option records and pass them along with a diagram to 'mainRender'+-- from "Diagrams.Backend.CmdLine".+--+-- * An even more flexible approach is to directly call 'renderDia'; see -- "Diagrams.Backend.Postscript" for more information. --+-- For a tutorial on command-line diagram creation see+-- <http://projects.haskell.org/diagrams/doc/cmdline.html>.+-- ----------------------------------------------------------------------------- module Diagrams.Backend.Postscript.CmdLine- ( defaultMain+ ( + -- * General form of @main@+ -- $mainwith++ mainWith++ -- * Supported forms of @main@++ , defaultMain , multiMain , pagesMain , animMain++ -- * Backend tokens+ , Postscript- ) where+ , B -import Diagrams.Prelude hiding (width, height, interval)+ ) where++import Diagrams.Prelude hiding (width, height, interval, option, value, (<>)) import Diagrams.Backend.Postscript+import Diagrams.Backend.CmdLine -import System.Console.CmdArgs.Implicit hiding (args)+import Control.Lens import Prelude -import Data.Maybe (fromMaybe)-import Control.Monad (forM_)-import Control.Applicative ((<$>))-import Control.Monad (when) import Data.List.Split-import Data.List (intercalate) -import Text.Printf+-- $mainwith+-- The 'mainWith' method unifies all of the other forms of @main@ and is+-- now the recommended way to build a command-line diagrams program. It+-- works as a direct replacement for 'defaultMain', 'multiMain', 'pagesMain',+-- or 'animMain' as well as allowing more general arguments. For example,+-- given a function that produces a diagram when given an @Int@ and a @'Colour'+-- Double@, 'mainWith' will produce a program that looks for additional number+-- and color arguments.+--+-- > ... definitions ...+-- > f :: Int -> Colour Double -> Diagram Postscript R2+-- > f i c = ...+-- >+-- > main = mainWith f+--+-- We can run this program as follows:+--+-- > $ ghc --make MyDiagram+-- >+-- > # output image.eps built by `f 20 red`+-- > $ ./MyDiagram -o image.eps -w 200 20 red -import System.Environment (getArgs, getProgName)-import System.FilePath (addExtension, splitExtension) -data DiagramOpts = DiagramOpts- { width :: Maybe Int- , height :: Maybe Int- , output :: FilePath- , selection :: Maybe String- , list :: Bool- , fpu :: Double- }- 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)-- , fpu = 30- &= typ "FLOAT"- &= help "Frames per unit time (for animations)"- }- &= summary "Command-line diagram generation."- &= program prog- -- | This is the simplest way to render diagrams, and is intended to -- be used like so: --@@ -113,20 +123,19 @@ -- options. Currently it looks something like -- -- @--- Command-line diagram generation.+-- ./Program ----- Foo [OPTIONS]+-- Usage: ./Program [-w|--width WIDTH] [-h|--height HEIGHT] [-o|--output OUTPUT]+-- Command-line diagram generation. ----- 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--- -f --fpu=FLOAT Frames per unit time (for animations)--- -? --help Display help message--- -V --version Print version information+-- Available options:+-- -?,--help Show this help text+-- -w,--width WIDTH Desired WIDTH of the output image+-- -h,--height HEIGHT Desired HEIGHT of the output image+-- -o,--output OUTPUT OUTPUT file -- @ ----- For example, a couple common scenarios include+-- For example, a common scenario is -- -- @ -- $ ghc --make MyDiagram@@ -136,27 +145,29 @@ -- @ defaultMain :: Diagram Postscript R2 -> IO ()-defaultMain d = do- prog <- getProgName- opts <- cmdArgs (diagramOpts prog False)- chooseRender opts (renderDia' d)+defaultMain = mainWith +instance Mainable (Diagram Postscript R2) where+ type MainOpts (Diagram Postscript R2) = DiagramOpts++ mainRender opts d = chooseRender opts (renderDia' d)+ chooseRender :: DiagramOpts -> (Options Postscript R2 -> IO ()) -> IO ()-chooseRender opts render =- case splitOn "." (output opts) of+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 (width opts, height opts) of+ 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) - render (PostscriptOptions (output opts) sizeSpec outfmt)+ renderer (PostscriptOptions (opts^.output) sizeSpec outfmt) | otherwise -> putStrLn $ "Unknown file type: " ++ last ps renderDias' :: [Diagram Postscript R2] -> Options Postscript R2 -> IO ()@@ -186,26 +197,15 @@ -- @ 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)+multiMain = mainWith --- | Display the list of diagrams available for rendering.-showDiaList :: [String] -> IO ()-showDiaList ds = do- putStrLn "Available diagrams:"- putStrLn $ " " ++ intercalate " " ds +instance Mainable [(String,Diagram Postscript R2)] where+ type MainOpts [(String,Diagram Postscript R2)] = (DiagramOpts, DiagramMultiOpts) + mainRender = defaultMultiMainRender+ -- | @pagesMain@ is like 'defaultMain', except instead of a single--- diagram it takes a list of diagrams and each wil be rendered as a page+-- diagram it takes a list of diagrams and each will be rendered as a page -- in the Postscript file. -- -- Example usage:@@ -218,11 +218,13 @@ -- @ pagesMain :: [Diagram Postscript R2] -> IO ()-pagesMain ds = do- prog <- getProgName- opts <- cmdArgs (diagramOpts prog False)- chooseRender opts (renderDias' ds)+pagesMain = mainWith +instance Mainable [Diagram Postscript R2] where+ type MainOpts [Diagram Postscript R2] = DiagramOpts++ mainRender opts ds = chooseRender opts (renderDias' ds)+ -- | @animMain@ is like 'defaultMain', but renders an animation -- instead of a diagram. It takes as input an animation and produces -- a command-line program which will crudely \"render\" the animation@@ -240,19 +242,9 @@ -- 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 anim = do- prog <- getProgName- opts <- cmdArgs (diagramOpts prog False)- let frames = simulate (toRational $ fpu opts) anim- nDigits = length . show . length $ frames- forM_ (zip [1..] frames) $ \(i,d) ->- chooseRender (indexize nDigits i opts) (renderDia' d)+animMain = mainWith --- | @indexize d n@ adds the integer index @n@ to the end of the--- output file name, padding with zeros if necessary so that it uses--- at least @d@ digits.-indexize :: Int -> Integer -> DiagramOpts -> DiagramOpts-indexize nDigits i opts = opts { output = output' }- where fmt = "%0" ++ show nDigits ++ "d"- output' = addExtension (base ++ printf fmt (i::Integer)) ext- (base, ext) = splitExtension (output opts)+instance Mainable (Animation Postscript R2) where+ type MainOpts (Animation Postscript R2) = (DiagramOpts, DiagramAnimOpts)++ mainRender = defaultAnimMainRender output
src/Graphics/Rendering/Postscript.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Postscript@@ -20,7 +21,7 @@ ----------------------------------------------------------------------------- module Graphics.Rendering.Postscript ( Render- , RenderState+ , RenderState, drawState , Surface , PSWriter(..) , renderWith@@ -52,66 +53,92 @@ , lineWidth , lineCap , lineJoin+ , miterLimit , setDash- , setFillRule , showText , showTextCentered , showTextAlign , showTextInBox , clip- + , FontSlant(..) , FontWeight(..)- , setFontFace- , setFontSlant- , setFontWeight- , setFontSize+ , face, slant, weight, size++ , fillRule, ignoreFill, font ) where import Diagrams.Attributes(Color(..),LineCap(..),LineJoin(..),colorToSRGBA)-import Diagrams.TwoD.Path hiding (stroke)+import Diagrams.TwoD.Path hiding (stroke, fillRule)+import Control.Applicative import Control.Monad.Writer import Control.Monad.State-import Control.Monad(when)+import Control.Lens hiding (transform, moveTo) 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) +data FontSlant = FontSlantNormal+ | FontSlantItalic+ | FontSlantOblique+ | FontSlant Double+ deriving (Show, Eq)++data FontWeight = FontWeightNormal+ | FontWeightBold+ deriving (Show, Eq)++data PostscriptFont = PostscriptFont+ { _face :: String+ , _slant :: FontSlant+ , _weight :: FontWeight+ , _size :: Double+ } deriving (Eq, Show)++makeLenses '' PostscriptFont++defaultFont :: PostscriptFont+defaultFont = PostscriptFont "Helvetica" FontSlantNormal FontWeightNormal 1+ -- 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+ { _fillRule :: FillRule+ , _font :: PostscriptFont+ , _ignoreFill :: Bool } deriving (Eq) +makeLenses ''DrawState+ -- This reflects the defaults from the standard. emptyDS :: DrawState-emptyDS = DS Winding defaultFont+emptyDS = DS Winding defaultFont False data RenderState = RS { _drawState :: DrawState -- The current state. , _saved :: [DrawState] -- A stack of passed states pushed by save and poped with restore. } +makeLenses ''RenderState+ 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))+ deriving (Functor, Applicative, 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)+ deriving (Functor, Applicative, Monad, MonadState RenderState) -- | Abstraction of the drawing surface details.-data Surface = Surface { header :: Int -> String, footer :: Int -> String, width :: Int, height :: Int, fileName :: String } +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@@ -120,7 +147,7 @@ -- 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 +renderWith s r = liftIO $ do (v,ss) <- runWriterT . runPSWriter . doRender $ r h <- openFile (fileName s) WriteMode hPutStr h (header s 1)@@ -132,15 +159,15 @@ -- | 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 +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 + where page h (r,i) = do (v,ss) <- runWriterT . runPSWriter . doRender $ r mapM_ (hPutStr h) (toList ss)@@ -209,20 +236,23 @@ stroke :: Render () stroke = renderPS "s" --- | Fill the current path. fill :: Render () fill = do- (RS (DS {..}) _) <- get- case _fillRule of+ ign <- use $ drawState . ignoreFill+ rule <- use $ drawState . fillRule+ unless ign $+ case rule of Winding -> renderPS "fill" EvenOdd -> renderPS "eofill" -- | Fill the current path without affecting the graphics state. fillPreserve :: Render () fillPreserve = do- gsave- fill- grestore+ ign <- use $ drawState . ignoreFill+ unless ign $ do+ gsave+ fill+ grestore -- | Draw a string at the current point. showText :: String -> Render ()@@ -267,31 +297,38 @@ save :: Render () save = do renderPS "save"- modify $ \rs@(RS{..}) -> rs { _saved = _drawState : _saved }+ d <- use drawState+ saved %= (d:) -- | 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+ s <- use saved+ case s of+ [] -> do saved .= []+ (x:xs) -> do+ drawState .= x+ saved .= xs + -- | Push the current graphics state. gsave :: Render () gsave = do renderPS "gsave"- modify $ \rs@(RS{..}) -> rs { _saved = _drawState : _saved }+ d <- use drawState+ saved %= (d:) -- | 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+ s <- use saved+ case s of+ [] -> do saved .= []+ (x:xs) -> do+ drawState .= x+ saved .= xs -- | Push the current transform matrix onto the execution stack. saveMatrix :: Render ()@@ -320,22 +357,22 @@ -- | Set the line cap style. lineCap :: LineCap -> Render ()-lineCap lc = mkPSCall "setlinecap" [fromLineCap lc] +lineCap lc = mkPSCall "setlinecap" [fromLineCap lc] -- | Set the line join method. lineJoin :: LineJoin -> Render () lineJoin lj = mkPSCall "setlinejoin" [fromLineJoin lj] +-- | Set the miter limit.+miterLimit :: Double -> Render ()+miterLimit ml = mkPSCall "setmiterlimit" [ml]+ -- | 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), "]"] @@ -374,6 +411,7 @@ escape c | isPrint c = [c] | otherwise = '\\' : showIntAtBase 7 ("01234567"!!) (ord c) "" +epsHeader :: Int -> Int -> Int -> String 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"@@ -403,6 +441,8 @@ , "%%EndSetup\n" , "%%Page: 1 1\n" ]++epsFooter :: Int -> String epsFooter page = concat [ "showpage\n" , "%%PageTrailer\n"@@ -411,36 +451,20 @@ --------------------------- -- 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"]+ n <- fontFromName <$> f face <*> f slant <*> f weight+ s <- show <$> f size+ renderPS $ concat ["/", n, " ", s, " selectfont"]+ where+ f x = use $ drawState . font . x -- 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+fontFromName n s w = fontName ++ bold w ++ italic s where- font = map f n+ fontName = map f n f ' ' = '-' f c = c @@ -451,20 +475,3 @@ 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 } } })-