diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,13 @@ -Copyright Ryan Yates 2011-2013 +Copyright 2011-2013: + + Ryan Yates + + Daniel Bergey + Jan Bracker + Jeffrey Rosenbluth + Michael Sloan + Brent Yorgey + PostScript (TM) is a trademark of Adobe. diff --git a/diagrams-postscript.cabal b/diagrams-postscript.cabal --- a/diagrams-postscript.cabal +++ b/diagrams-postscript.cabal @@ -1,5 +1,5 @@ Name: diagrams-postscript -Version: 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 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 @@ -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 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,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 +-- . +-- ----------------------------------------------------------------------------- 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 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,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 } } }) -