diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/diagrams-postscript.cabal b/diagrams-postscript.cabal new file mode 100644 --- /dev/null +++ b/diagrams-postscript.cabal @@ -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 + diff --git a/src/Diagrams/Backend/Postscript.hs b/src/Diagrams/Backend/Postscript.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/Postscript.hs @@ -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 +-- > } diff --git a/src/Diagrams/Backend/Postscript/CmdLine.hs b/src/Diagrams/Backend/Postscript/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/Postscript/CmdLine.hs @@ -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) + diff --git a/src/Graphics/Rendering/Postscript.hs b/src/Graphics/Rendering/Postscript.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Postscript.hs @@ -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: +----------------------------------------------------------------------------- +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 } } }) +