diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,10 @@ +ChangeLog + +v0.1.0.0 2013/12/14 + (2013/12/15) PS1 - converted to Cabal package. + +Release 2013/09/02 + Released as part of Quipper 0.5 (no changes). + +Release 2013/06/19 + Initial public release, as part of Quipper 0.4. diff --git a/Graphics/EasyRender.hs b/Graphics/EasyRender.hs new file mode 100644 --- /dev/null +++ b/Graphics/EasyRender.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | This module provides efficient functions for rendering vector +-- graphics to a number of formats, including EPS, PostScript, and +-- PDF. It provides an abstraction for multi-page documents, as well +-- as a set of graphics primitives for page descriptions. +-- +-- The graphics model is similar to that of the PostScript and PDF +-- languages, but we only implement a subset of their functionality. +-- Care has been taken that graphics rendering is done efficiently and +-- as lazily as possible; documents are rendered \"on the fly\", +-- without the need to store the whole document in memory. +-- +-- The provided document description model consists of two separate +-- layers of abstraction: +-- +-- * /drawing/ is concerned with placing marks on a fixed surface, and +-- takes place in the 'Draw' monad; +-- +-- * /document structure/ is concerned with a sequence of pages, their +-- bounding boxes, and other meta-data. It takes place in the +-- 'Document' monad. + +module Graphics.EasyRender ( + -- * Types + -- ** Coordinates + X, + Y, + -- ** Color + Color(..), + + -- ** Fonts + Basefont(..), + Font(..), + nominalsize, + text_width, + + -- ** Alignment + Alignment, + align_left, + align_center, + align_right, + + -- * The Document monad + -- $DOCUMENTMODEL + Document, + newpage, + newpage_defer, + endpage, + + -- * The Draw monad + -- $DRAWINGMODEL + Draw, + + -- ** Path construction commands + -- $PATHCONSTRUCTION + newpath, + moveto, + lineto, + curveto, + closepath, + arc, + arc_append, + oval, + rectangle, + + -- ** Painting commands + stroke, + fill, + fillstroke, + + -- ** Text commands + textbox, + + -- ** Graphics parameters + -- $GRAPHICSPARAMETERS + setlinewidth, + setcolor, + + -- ** Coordinate system + -- $COORDINATESYSTEM + translate, + scale, + + -- ** Comments + comment, + + -- ** Block structure + -- $BLOCKSTRUCTURE + block, + + -- * Backends + -- $BACKENDS + RenderFormat(..), + render_stdout, + render_file, + render_string, + + -- * Customization + -- $CUSTOMIZATION + + -- ** Custom drawing commands + -- $CUSTOMCOMMANDS + draw_subroutine, + custom_ps, + custom_pdf, + custom_ascii, + + -- ** Customization interface + Custom(..), + custom, + + -- ** Customized rendering functions + -- $CUSTOMRENDER + render_custom_stdout, + render_custom_file, + render_custom_string, + ) where + +import Graphics.EasyRender.Internal + +-- $DOCUMENTMODEL +-- +-- Document description takes place in the 'Document' monad. A basic +-- multi-page document has the following structure: +-- +-- > document :: Document () +-- > document = do +-- > newpage x y $ do +-- > <<>> +-- > newpage x y $ do +-- > <<>> +-- > ... +-- +-- Here, each 'newpage' command describes one page of the +-- document. The parameters /x/ and /y/ specify the dimensions of the +-- page bounding box. They are expressed in units of PostScript +-- points, i.e., multiples of 1/72 inch. +-- +-- Sometimes the bounding box for a page is not known until after the +-- page content has been generated. For this purpose, we also provide +-- the following alternative to the 'newpage' command: +-- +-- > newpage_defer $ do +-- > <<>> +-- > endpage x y +-- +-- It works just like the 'newpage' command, except that the bounding +-- box is given at the end. + +-- $DRAWINGMODEL +-- +-- The description of the visible content of a page take place in the +-- 'Draw' monad. It takes the form of a sequence of drawing commands, +-- for example: +-- +-- > moveto 10 10 +-- > lineto 10 100 +-- > lineto 100 100 +-- > lineto 100 10 +-- > closepath +-- > stroke +-- +-- The graphics model is similar to that of the PostScript and PDF +-- languages. The basic concept is that of a /path/, which is a +-- sequence of straight and curved line segments. Paths are first +-- constructed using /path construction commands/, and then painted +-- using /painting commands/, depending on a set of current +-- /graphics parameters/ and a current /coordinate system/. +-- +-- We also provide block structure. Changes to the graphics state +-- (color, coordinate system, etc.) that are done within a block are +-- local to the block. +-- +-- > block $ do +-- > <> + +-- $PATHCONSTRUCTION +-- +-- During path construction, there is a notion of /current path/ and +-- /current point/. A path may consist of zero or more connected +-- subpaths, and each subpath is either open or closed. + +-- $GRAPHICSPARAMETERS +-- +-- The painting commands rely on a set of graphics parameters. The +-- graphics parameters are initially set to default values, and can be +-- altered with the following commands. + +-- $COORDINATESYSTEM +-- +-- Coordinates, lengths, widths, etc, are all interpreted relative to +-- a /current coordinate system/. The initial coordinate system of +-- each page has the origin in the lower left corner, with each unit +-- equaling one PostScript point (1/72 inch). The following commands +-- can be used to change the current coordinate system. + +-- $BLOCKSTRUCTURE +-- +-- Drawing operations can be grouped into blocks with the 'block' +-- operator. Changes to the graphics parameters and coordinate system +-- are local to the block. It is undefined whether changes to the +-- current path made within a block persist after the end of the block +-- (they do in PDF, but not in PostScript). Therefore, path +-- construction should not be broken up across end-of-block boundaries. + +-- $CUSTOMIZATION +-- +-- The document and drawing abstractions provided by this module are +-- purposely kept general-purpose, and do not include +-- application-specific features. However, we provide a mechanism by +-- which applications can provide customized drawing commands and +-- other custom features. + +-- $CUSTOMCOMMANDS +-- +-- It is sometimes useful to use customized drawing commands. For +-- example, an application that draws many rectangles might like to +-- define a custom 'rectangle' function for appending a rectangle to +-- the current path. Of course this can be defined as an ordinary +-- Haskell function, using elementary drawing commands: +-- +-- > my_rect :: X -> Y -> X -> Y -> Draw () +-- > my_rect x0 y0 x1 y1 = do +-- > moveto x0 y0 +-- > lineto x0 y1 +-- > lineto x1 y1 +-- > lineto x1 y0 +-- > closepath +-- +-- However, sometimes it is nice to make use of specialized abilities +-- of individual backends. For example, PDF already has a built-in +-- rectangle drawing command, and PostScript has the ability to define +-- custom subroutines within the document text. Using these features +-- can decrease the size of the generated documents. +-- +-- We therefore provide a facility for defining new drawing commands +-- with backend-specific implementations. For example, a more general +-- version of the above 'my_rect' function can be defined as +-- follows: +-- +-- > my_rect :: X -> Y -> X -> Y -> Draw () +-- > my_rect x0 y0 x1 y1 = draw_subroutine alt $ do +-- > moveto x0 y0 +-- > lineto x0 y1 +-- > lineto x1 y1 +-- > lineto x1 y0 +-- > closepath +-- > where +-- > alt = [ +-- > custom_ps $ printf "%f %f %f %f rect\n" x0 y0 x1 y1, +-- > custom_pdf $ printf "%f %f %f %f re\n" x0 y0 (x1-x0) (y1-y0), +-- > custom_ascii $ printf "My_rect %f %f %f %f\n" x0 y0 x1 y1 +-- > ] +-- +-- The idea is to provide a default definition in terms of primitive +-- drawing commands, as well as a list of various backend specific +-- definitions. In the case of PostScript subroutines, the PostScript +-- file must then also be supplied with a definition for the /rect/ +-- subroutine, which can be done with the command 'render_ps_custom': +-- +-- > my_ps_defs = "/rect { ... } bind def\n" +-- > +-- > my_render_ps = render_ps_custom custom { ps_defs = my_ps_defs } +-- +-- Note that the 'draw_subroutine' customization mechanism is entirely +-- optional. Its purpose is to generate shorter output for some +-- backends; if it is omitted, the file may be be longer but should +-- look the same. + +-- $BACKENDS +-- +-- The following commands can be used to render documents to various +-- available formats. The available formats are PostScript, PDF, EPS, +-- and an ASCII-based debugging format. Output can be written to +-- standard output, to a file, or to a string. + +-- $CUSTOMRENDER +-- +-- The following are versions of the generic rendering functions that +-- also take a customization data structure as an additional +-- parameter. + diff --git a/Graphics/EasyRender/Auxiliary.hs b/Graphics/EasyRender/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/Graphics/EasyRender/Auxiliary.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module provides miscellaneous general-purpose auxiliary +-- functions used by the "Graphics.EasyRender" package. + +module Graphics.EasyRender.Auxiliary where + +-- ---------------------------------------------------------------------- +-- * Arithmetic operations + +-- | A version of the 'ceiling' function that returns an 'Integer'. +int_ceiling :: RealFrac a => a -> Integer +int_ceiling = toInteger . ceiling + +-- ---------------------------------------------------------------------- +-- * The Curry type class + +-- | The 'Curry' type class is used to implement functions that have a +-- variable number of arguments. It provides a family of type +-- isomorphisms +-- +-- @fun ≅ args -> res,@ +-- +-- where +-- +-- > fun = a1 -> a2 -> ... -> an -> res, +-- > args = (a1, (a2, (..., (an, ())))). + +class Curry fun args res | args res -> fun where + -- | Multiple curry: map a function + -- (/a/[sub 1], (/a/[sub 2], (…, ())) → /b/ + -- to its curried form + -- /a/[sub 1] → /a/[sub 2] → … → /b/. + mcurry :: (args -> res) -> fun + -- | Multiple uncurry: map a function + -- /a/[sub 1] → /a/[sub 2] → … → /b/ + -- to its uncurried form + -- (/a/[sub 1], (/a/[sub 2], (…, ())) → /b/. + muncurry :: fun -> (args -> res) + +instance Curry b () b where + mcurry g = g () + muncurry x = const x + +instance Curry fun args res => Curry (a -> fun) (a,args) res where + mcurry g x = mcurry (\xs -> g (x,xs)) + muncurry f (x,xs) = muncurry (f x) xs + diff --git a/Graphics/EasyRender/Internal.hs b/Graphics/EasyRender/Internal.hs new file mode 100644 --- /dev/null +++ b/Graphics/EasyRender/Internal.hs @@ -0,0 +1,1903 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | This module exposes the implementation details of +-- "Graphics.EasyRender". Most user code should not need to import +-- this; they should import "Graphics.EasyRender" instead. +-- +-- This module provides efficient functions for rendering vector +-- graphics to a number of formats, including EPS, PostScript, and +-- PDF. It provides an abstraction for multi-page documents, as well +-- as a set of graphics primitives for page descriptions. +-- +-- The graphics model is similar to that of the PostScript and PDF +-- languages, but we only implement a subset of their functionality. +-- Care has been taken that graphics rendering is done efficiently and +-- as lazily as possible; documents are rendered \"on the fly\", +-- without the need to store the whole document in memory. +-- +-- The provided document description model consists of two separate +-- layers of abstraction: +-- +-- * /drawing/ is concerned with placing marks on a fixed surface, and +-- takes place in the 'Draw' monad; +-- +-- * /document structure/ is concerned with a sequence of pages, their +-- bounding boxes, and other meta-data. It takes place in the +-- 'Document' monad. + +module Graphics.EasyRender.Internal where + +import Graphics.EasyRender.Auxiliary + +import Codec.Compression.Zlib +import Control.Monad.State +import qualified Data.ByteString.Lazy as ByteString +import Data.Char +import Data.List +import qualified Data.Map as Map +import Data.Map (Map) +import System.IO +import Text.Printf + +-- ---------------------------------------------------------------------- +-- * Types + +-- ---------------------------------------------------------------------- +-- ** Coordinates + +-- | The type of /x/-coordinates. +type X = Double + +-- | The type of /y/-coordinates. +type Y = Double + +-- ---------------------------------------------------------------------- +-- ** Colors + +-- | The type of colors. +data Color = + Color_RGB Double Double Double -- ^ Red, green and blue components, + -- in the range from 0.0 (dark) to + -- 1.0 (bright). + | Color_Gray Double -- ^ Gray value, in the range from + -- 0.0 (black) to 1.0 (white). + deriving (Show) + +-- ---------------------------------------------------------------------- +-- ** Fonts + +-- | A enumeration type for base fonts. For the time being, we only +-- offer TimesRoman and Helvetica. +data Basefont = TimesRoman | Helvetica + deriving (Show) + +-- | A type representing font metrics for a given base font. The first +-- component is the default width of characters; the second component +-- is a map from characters to widths. +type Fontmetric = (Double, Map Char Double) + +-- | Define a font metric for each base font. +metric :: Basefont -> Fontmetric +metric TimesRoman = metric_timesroman +metric Helvetica = metric_helvetica + +-- | Font metrics for TimesRoman. +metric_timesroman :: Fontmetric +metric_timesroman = (0.5, m) where + m = Map.fromList $ map (\(n,w) -> (chr n, w)) + [(32,0.25), (33,0.332031), (34,0.40625), (37,0.832031), (38,0.777344), + (39,0.332031), (40,0.332031), (41,0.332031), (44,0.25), (45,0.332031), + (46,0.25), (47,0.277344), (58,0.277344), (59,0.277344), (63,0.441406), + (64,0.917969), (65,0.71875), (66,0.664062), (67,0.664062), (68,0.71875), + (69,0.609375), (71,0.71875), (72,0.71875), (73,0.332031), (74,0.386719), + (75,0.71875), (76,0.609375), (77,0.886719), (78,0.71875), (79,0.71875), + (81,0.71875), (82,0.664062), (84,0.609375), (85,0.71875), (86,0.71875), + (87,0.941406), (88,0.71875), (89,0.71875), (90,0.609375), (91,0.332031), + (92,0.277344), (93,0.332031), (94,0.46875), (96,0.332031), + (97,0.441406), (99,0.441406), (101,0.441406), (102,0.332031), + (105,0.277344), (106,0.277344), (108,0.277344), (109,0.777344), + (114,0.332031), (115,0.386719), (116,0.277344), (119,0.71875), + (122,0.441406), (123,0.476562), (124,0.199219), (125,0.476562), + (161,0.332031), (164,0.164062), (169,0.179688), (170,0.441406), + (172,0.332031), (173,0.332031), (180,0.25), (182,0.449219), + (183,0.347656), (184,0.332031), (185,0.441406), (186,0.441406), + (188,1.0), (189,1.0), (191,0.441406), (193,0.332031), (194,0.332031), + (195,0.332031), (196,0.332031), (197,0.332031), (198,0.332031), + (199,0.332031), (200,0.332031), (202,0.332031), (203,0.332031), + (205,0.332031), (206,0.332031), (207,0.332031), (208,1.0), + (225,0.886719), (227,0.273438), (232,0.609375), (233,0.71875), + (234,0.886719), (241,0.664062), (245,0.277344), (248,0.277344), + (250,0.71875)] + +-- | Font metrics for Helvetica. +metric_helvetica :: Fontmetric +metric_helvetica = (0.277344, m) where + m = Map.fromList $ map (\(n,w) -> (chr n, w)) + [(34,0.351562), (35,0.554688), (36,0.554688), (37,0.886719), + (38,0.664062), (39,0.21875), (40,0.332031), (41,0.332031), (42,0.386719), + (43,0.582031), (45,0.332031), (48,0.554688), (49,0.554688), + (50,0.554688), (51,0.554688), (52,0.554688), (53,0.554688), + (54,0.554688), (55,0.554688), (56,0.554688), (57,0.554688), + (60,0.582031), (61,0.582031), (62,0.582031), (63,0.554688), (64,1.01172), + (65,0.664062), (66,0.664062), (67,0.71875), (68,0.71875), (69,0.664062), + (70,0.609375), (71,0.777344), (72,0.71875), (74,0.5), (75,0.664062), + (76,0.554688), (77,0.832031), (78,0.71875), (79,0.777344), (80,0.664062), + (81,0.777344), (82,0.71875), (83,0.664062), (84,0.609375), (85,0.71875), + (86,0.664062), (87,0.941406), (88,0.664062), (89,0.664062), + (90,0.609375), (94,0.46875), (95,0.554688), (96,0.21875), (97,0.554688), + (98,0.554688), (99,0.5), (100,0.554688), (101,0.554688), (103,0.554688), + (104,0.554688), (105,0.21875), (106,0.21875), (107,0.5), (108,0.21875), + (109,0.832031), (110,0.554688), (111,0.554688), (112,0.554688), + (113,0.554688), (114,0.332031), (115,0.5), (117,0.554688), (118,0.5), + (119,0.71875), (120,0.5), (121,0.5), (122,0.5), (123,0.332031), + (124,0.257812), (125,0.332031), (126,0.582031), (161,0.332031), + (162,0.554688), (163,0.554688), (164,0.164062), (165,0.554688), + (166,0.554688), (167,0.554688), (168,0.554688), (169,0.1875), + (170,0.332031), (171,0.554688), (172,0.332031), (173,0.332031), + (174,0.5), (175,0.5), (177,0.554688), (178,0.554688), (179,0.554688), + (182,0.535156), (183,0.347656), (184,0.21875), (185,0.332031), + (186,0.332031), (187,0.554688), (188,1.0), (189,1.0), (191,0.609375), + (193,0.332031), (194,0.332031), (195,0.332031), (196,0.332031), + (197,0.332031), (198,0.332031), (199,0.332031), (200,0.332031), + (202,0.332031), (203,0.332031), (205,0.332031), (206,0.332031), + (207,0.332031), (208,1.0), (225,1.0), (227,0.367188), (232,0.554688), + (233,0.777344), (234,1.0), (235,0.363281), (241,0.886719), (248,0.21875), + (249,0.609375), (250,0.941406), (251,0.609375)] + +-- | Look up the width of a character in the given metric. +char_metric :: Fontmetric -> Char -> Double +char_metric (d, m) c = case Map.lookup c m of + Nothing -> d + Just w -> w + +-- | Look up with width of a string in the given metric. +string_metric :: Fontmetric -> String -> Double +string_metric metric s = sum [ char_metric metric c | c <- s ] + +-- | A data type describing a scaled font. This consists of a base +-- font and a point size. +data Font = Font Basefont Double + deriving (Show) + +-- | Return the nominal point size of a font. +nominalsize :: Font -> Double +nominalsize (Font basefont pointsize) = pointsize + +-- | Return the width of the given string in the given font. +text_width :: Font -> String -> Double +text_width (Font basefont pointsize) s = pointsize * string_metric m s + where + m = metric basefont + +-- ---------------------------------------------------------------------- +-- ** Alignment + +-- | A real number representing text alignment. 0 = left aligned, 0.5 +-- = centered, 1 = right aligned. Intermediate values are also +-- possible. For example, an alignment value of 0.25 means one quarter +-- of the way between left aligned and right aligned. +type Alignment = Double + +-- | Left alignment. +align_left :: Alignment +align_left = 0.0 + +-- | Centered alignment. +align_center :: Alignment +align_center = 0.5 + +-- | Right alignment. +align_right :: Alignment +align_right = 1.0 + +-- ---------------------------------------------------------------------- +-- * The Document monad + +-- $DOCUMENTMODEL +-- +-- Document description takes place in the 'Document' monad. A basic +-- multi-page document has the following structure: +-- +-- > document :: Document () +-- > document = do +-- > newpage x y $ do +-- > <<>> +-- > newpage x y $ do +-- > <<>> +-- > ... +-- +-- Here, each 'newpage' command describes one page of the +-- document. The parameters /x/ and /y/ specify the dimensions of the +-- page bounding box. They are expressed in units of PostScript +-- points, i.e., multiples of 1/72 inch. +-- +-- Sometimes the bounding box for a page is not known until after the +-- page content has been generated. For this purpose, we also provide +-- the following alternative to the 'newpage' command: +-- +-- > newpage_defer $ do +-- > <<>> +-- > endpage x y +-- +-- It works just like the 'newpage' command, except that the bounding +-- box is given at the end. + +-- | The Document monad. +data Document a = + Document_Return a -- ^ Terminate with a result. + | Document_Page X Y (Draw (Document a)) -- ^ Page with bounding box + -- known at the beginning. + | Document_Page_defer (Draw (X, Y, Document a)) + -- ^ Page with bounding box + -- known at the end. + +instance Monad Document where + return a = Document_Return a + f >>= g = case f of + Document_Return a -> g a + Document_Page x y draw -> Document_Page x y draw' where + draw' = do + f' <- draw + return (f' >>= g) + Document_Page_defer draw -> Document_Page_defer draw' where + draw' = do + (x, y, f') <- draw + return (x, y, f' >>= g) + +-- ---------------------------------------------------------------------- +-- ** A vacuous run function + +-- | Skip document without rendering. +document_skip :: Document a -> a +document_skip (Document_Return a) = a +document_skip (Document_Page x y draw) = document_skip a where + a = draw_skip draw +document_skip (Document_Page_defer draw) = document_skip a where + (x, y, a) = draw_skip draw + +-- ---------------------------------------------------------------------- +-- ** User-level document structuring commands + +-- | Create a page of the given bounding box, containing the given +-- drawing. +newpage :: X -> Y -> Draw a -> Document a +newpage x y draw = + Document_Page x y draw' where + draw' = do + a <- draw + return (Document_Return a) + +-- | Create a page containing the given drawing, with the bounding box +-- computed at the end of the drawing routines. +newpage_defer :: Draw (X, Y, a) -> Document a +newpage_defer draw = + Document_Page_defer draw' where + draw' = do + (x, y, a) <- draw + return (x, y, Document_Return a) + +-- | End the page with the given bounding box. +endpage :: X -> Y -> Draw (X, Y, ()) +endpage x y = do + return (x, y, ()) + +-- ---------------------------------------------------------------------- +-- * The Draw monad + +-- $DRAWINGMODEL +-- +-- The description of the visible content of a page take place in the +-- 'Draw' monad. It takes the form of a sequence of drawing commands, +-- for example: +-- +-- > moveto 10 10 +-- > lineto 10 100 +-- > lineto 100 100 +-- > lineto 100 10 +-- > closepath +-- > stroke +-- +-- The graphics model is similar to that of the PostScript and PDF +-- languages. The basic concept is that of a /path/, which is a +-- sequence of straight and curved line segments. Paths are first +-- constructed using /path construction commands/, and then painted +-- using /painting commands/, depending on a set of current +-- /graphics parameters/ and a current /coordinate system/. +-- +-- We also provide block structure. Changes to the graphics state +-- (color, coordinate system, etc.) that are done within a block are +-- local to the block. +-- +-- > block $ do +-- > <> + +-- ---------------------------------------------------------------------- +-- ** Internal definition of the Draw monad + +-- | An abstract data type describing individual drawing commands. +data DrawCommand = + Newpath -- ^ Set the current path to empty. + | Moveto X Y -- ^ Start a new subpath at the given coordinates. + | Lineto X Y -- ^ Append a straight line to the current subpath. + | Curveto X Y X Y X Y -- ^ Append a Bezier curve segment. + | Closepath -- ^ Close the current subpath. + | Stroke -- ^ Stroke and clear the current path. + | Fill Color -- ^ Fill and clear the current path. + | FillStroke Color -- ^ Fill and stroke and clear the current path. + | TextBox Alignment Font Color X Y X Y Double String -- ^ Text. + | SetLineWidth Double -- ^ Set current line width. + | SetColor Color -- ^ Set current color. + | Translate X Y -- ^ Translate current coordinate system. + | Scale X Y -- ^ Scale the current coordinate system. + | Rotate Double -- ^ Rotate the current coordinate system. + | Comment String -- ^ A human-readable comment, not rendered + | Subroutine (Draw ()) [CustomDef] + -- ^ A subroutine is a composite drawing command. In + -- addition to a default definition that works for + -- any backend, it can also have optional specialized + -- definitions for particular backends. + deriving (Show) + +-- $ In understanding how the 'Draw' monad works, it is useful to keep +-- in mind that there is an isomorphism +-- +-- @Draw /a/@ ≅ @Draw ()@ ×. /a/, +-- +-- where \"×.\" is left-strict product, i.e., if the left-hand-side is +-- undefined, then so is the entire expression. + +-- | The Draw monad. +data Draw a = + Draw_Return a -- ^ Terminate with a result. + | Draw_Write DrawCommand (Draw a) -- ^ Write a command and continue. + | Draw_Block (Draw (Draw a)) -- ^ Block structure. Perform the + -- commands of the outer 'Draw' in + -- a temporary copy of the + -- graphics state, then continue + -- with the inner 'Draw' in the + -- original graphics state. + deriving (Show) + +instance Monad Draw where + return a = Draw_Return a + f >>= g = case f of + Draw_Return a -> g a + Draw_Write cmd f' -> Draw_Write cmd (f' >>= g) + Draw_Block draw -> Draw_Block draw' where + draw' = do + f' <- draw + return (f' >>= g) + +-- ---------------------------------------------------------------------- +-- ** Low-level operations for the Draw monad + +-- | Write the given command to the 'Draw' monad. +draw_write :: DrawCommand -> Draw () +draw_write cmd = + Draw_Write cmd (Draw_Return ()) + +-- | Create a new subroutine. +draw_subroutine :: [CustomDef] -> Draw () -> Draw () +draw_subroutine alt draw = + draw_write (Subroutine draw alt) + +-- | Write a block to the 'Draw' monad. +draw_block :: Draw a -> Draw a +draw_block draw = + Draw_Block draw' where + draw' = do + a <- draw + return (Draw_Return a) + +-- ---------------------------------------------------------------------- +-- ** A vacuous run function + +-- | Skip draw actions without rendering. +draw_skip :: Draw a -> a +draw_skip (Draw_Return x) = x +draw_skip (Draw_Write cmd cont) = draw_skip cont +draw_skip (Draw_Block f) = draw_skip (draw_skip f) + +-- ---------------------------------------------------------------------- +-- ** User-level drawing commands + +-- ---------------------------------------------------------------------- +-- *** Path construction commands + +-- $PATHCONSTRUCTION +-- +-- During path construction, there is a notion of /current path/ and +-- /current point/. A path may consist of zero or more connected +-- subpaths, and each subpath is either open or closed. + +-- | Set the current path to empty. +newpath :: Draw () +newpath = draw_write (Newpath) + +-- | Start a new subpath at (/x/,/y/). The point (/x/,/y/) becomes the +-- current point. +moveto :: X -> Y -> Draw () +moveto x y = draw_write (Moveto x y) + +-- | Extend the current subpath by a straight line segment from the +-- current point to (/x/,/y/). The point (/x/,/y/) becomes the current +-- point. +lineto :: X -> Y -> Draw () +lineto x y = draw_write (Lineto x y) + +-- | @'curveto' /x1/ /y1/ /x2/ /y2/ /x/ /y/@: Extend the current +-- subpath by a Bezier curve segment from the current point to +-- (/x/,/y/), with control points (/x1/,/y1/) and (/x2/,/y2/). The +-- point (/x/,/y/) becomes the current point. +curveto :: X -> Y -> X -> Y -> X -> Y -> Draw () +curveto x1 y1 x2 y2 x y = draw_write (Curveto x1 y1 x2 y2 x y) + +-- | Close the current subpath. If necessary, connect the subpath's +-- final and initial points by a straight line segment. Note that a +-- closed path is rendered differently than a non-closed path whose +-- initial and final points coincide, because in the latter case, the +-- endpoints are capped rather than mitered. +closepath :: Draw () +closepath = draw_write (Closepath) + +-- ---------------------------------------------------------------------- +-- *** Painting commands + +-- | Stroke the current path, using the current line color, line +-- width, and other graphics parameters. This operation implicitly +-- resets the current path to empty. +stroke :: Draw () +stroke = draw_write (Stroke) + +-- | Fill the current path, using the given color. This operation +-- implicitly resets the current path to empty. +fill :: Color -> Draw () +fill color = draw_write (Fill color) + +-- | Fill the current path, using the given color; also stroke the +-- path using the current line color. This operation implicitly resets +-- the current path to empty. +fillstroke :: Color -> Draw () +fillstroke color = draw_write (FillStroke color) + +-- ---------------------------------------------------------------------- +-- *** Text + +-- | @'textbox' /a/ /f/ /c/ /x0/ /y0/ /x1/ /y1/ /b/ /s/@: Write the +-- given string on an imaginary line from point (/x0/,/y0/) to +-- (/x1/,/y1/), using font /f/ and color /c/. If the text is too wide +-- to fit on the line, it is scaled down. Otherwise, it is aligned +-- according to the alignment parameter /a/. The parameter /b/ +-- specifies an additional offset by which to lower the text, with +-- respect to the text's nominal size. For example, if /b/=0, then the +-- above-mentioned imaginary line from (/x0/,/y0/) to (/x1/,/y1/) +-- coincides with the text's usual baseline. If /b/=0.5, then this +-- line approximately goes through the center of each character. +-- +-- \[image textbox.png] +textbox :: Alignment -> Font -> Color -> X -> Y -> X -> Y -> Double -> String -> Draw () +textbox a f c x0 y0 x1 y1 b s = draw_write (TextBox a f c x0 y0 x1 y1 b s) + +-- ---------------------------------------------------------------------- +-- *** Graphics parameters + +-- $GRAPHICSPARAMETERS +-- +-- The painting commands rely on a set of graphics parameters. The +-- graphics parameters are initially set to default values, and can be +-- altered with the following commands. + +-- | Set the line width. The initial line width is 1. +setlinewidth :: Double -> Draw () +setlinewidth x = draw_write (SetLineWidth x) + +-- | Set the current color for stroking. The initial stroke color is +-- black. +setcolor :: Color -> Draw () +setcolor color = draw_write (SetColor color) + +-- ---------------------------------------------------------------------- +-- *** Coordinate system + +-- $COORDINATESYSTEM +-- +-- Coordinates, lengths, widths, etc, are all interpreted relative to +-- a /current coordinate system/. The initial coordinate system of +-- each page has the origin in the lower left corner, with each unit +-- equaling one PostScript point (1/72 inch). The following commands +-- can be used to change the current coordinate system. + +-- | Translate the current coordinate system by (/x/,/y/). +translate :: X -> Y -> Draw () +translate x y = draw_write (Translate x y) + +-- | Scale the current coordinate system by (/s/,/t/). Here, /s/ is +-- the scaling factor in the /x/-direction, and /t/ is the scaling +-- factor in the /y/-direction. +scale :: X -> Y -> Draw () +scale x y = draw_write (Scale x y) + +-- | Rotate the current coordinate system by /angle/, measured +-- counterclockwise in degrees. +rotate :: Double -> Draw () +rotate angle = draw_write (Rotate angle) + +-- ---------------------------------------------------------------------- +-- *** Comments + +-- | Insert a human-readable comment in the content stream. This is +-- for information only, and is not rendered in the graphical output. +comment :: String -> Draw () +comment s = draw_write (Comment s) + +-- ---------------------------------------------------------------------- +-- *** Block structure + +-- $BLOCKSTRUCTURE +-- +-- Drawing operations can be grouped into blocks with the 'block' +-- operator. Changes to the graphics parameters and coordinate system +-- are local to the block. It is undefined whether changes to the +-- current path made within a block persist after the end of the block +-- (they do in PDF, but not in PostScript). Therefore, path +-- construction should not be broken up across end-of-block boundaries. + +-- | Perform a block of commands in a local copy of the graphics +-- state. This is intended to be used like this: +-- +-- > block $ do +-- > <> +block :: Draw a -> Draw a +block = draw_block + +-- ---------------------------------------------------------------------- +-- *** Derived commands + +-- $ PDF has no built-in command for drawing circular arcs, so we +-- define it here. Since PostScript does have such a command, we use +-- the 'draw_subroutine' mechanism. + +-- | Start a new subpath consisting of a circular arc segment. The +-- arc segment is centered at (/x/,/y/), has radius /r/, and extends +-- from angle /a1/ to angle /a2/, measured in degrees, +-- counterclockwise from the /x/-axis. The arc is drawn clockwise if +-- /a2/ ≥ /a1/, and counterclockwise otherwise. The final point +-- becomes the new current point. +arc :: X -> Y -> Double -> Double -> Double -> Draw () +arc x y r a1 a2 = draw_subroutine alt $ do + arc_internal False x y r r a1 a2 + where + alt = [custom_ps $ printf "%f %f moveto\n" x0 y0 ++ printf "%f %f %f %f %f %s\n" x y r a1 a2 (if a1 <= a2 then "arc" else "arcn"), + custom_ascii $ printf "Arc %f %f %f %f %f\n" x y r a1 a2] + x0 = x + r * cos (pi/180 * a1) + y0 = y + r * sin (pi/180 * a1) + +-- | Like 'arc', except append to the current subpath. If necessary, +-- add a straight line segment from the current point to the starting +-- point of the arc. +arc_append :: X -> Y -> Double -> Double -> Double -> Draw () +arc_append x y r a1 a2 = draw_subroutine alt $ do + arc_internal True x y r r a1 a2 + where + alt = [custom_ps $ printf "%f %f %f %f %f %s\n" x y r a1 a2 (if a1 <= a2 then "arc" else "arcn"), + custom_ascii $ printf "Arc_append %f %f %f %f %f\n" x y r a1 a2] + +-- | Append a new closed subpath consisting of an oval centered at +-- (/x/,/y/), with horizontal and vertical radii /rx/ and /ry/, +-- respectively. +oval :: X -> Y -> X -> Y -> Draw () +oval x y rx ry = do + arc_internal False x y rx ry 0 360 + closepath + +-- | The common implementation of 'arc', 'arc_append', and 'oval'. The +-- first parameter is a boolean flag indicating whether to append to +-- an existing subpath or start a new subpath. The fourth and fifth +-- parameter are the horizontal and vertical radius. +arc_internal :: Bool -> X -> Y -> Double -> Double -> Double -> Double -> Draw () +arc_internal connect x y rx ry a1 a2 = do + if connect then lineto x0 y0 else moveto x0 y0 + -- We divide the arc into n segments of 90 degrees or less. + sequence_ [ aux a | i <- [0..n-1], let a = a1 + (fromIntegral i)*phi ] + where + (x0, y0) = point rx ry a1 + n = int_ceiling (abs(a2 - a1) / 90) + phi = if n > 0 then (a2 - a1) / (fromIntegral n) else 0 + alpha = 4/3 * c / (1+c) + c = cos' (phi/2) + point rx ry a = (x + rx * cos' a, y + ry * sin' a) + cos' x = cos (pi/180 * x) + sin' x = sin (pi/180 * x) + along (x0,y0) (x1,y1) alpha = (x0 + alpha * (x1-x0), y0 + alpha * (y1-y0)) + aux a = curveto x1 y1 x2 y2 x3 y3 + where + (x0, y0) = point rx ry a + (x3, y3) = point rx ry (a + phi) + (xp, yp) = point (rx/c) (ry/c) (a + phi/2) + (x1, y1) = along (x0, y0) (xp, yp) alpha + (x2, y2) = along (x3, y3) (xp, yp) alpha + +-- | @'rectangle' /x/ /y/ /w/ /h/@: Draw a rectangle of width /w/ and +-- height /h/, starting from (/x/,/y/). If /w/ and /h/ are positive, +-- then (/x/,/y/) is the lower left corner. +rectangle :: X -> Y -> X -> Y -> Draw () +rectangle x y w h = draw_subroutine alt def where + def = do + moveto x y + lineto x (y+h) + lineto (x+w) (y+h) + lineto (x+w) y + closepath + alt = [ + custom_pdf $ printf "%f %f %f %f re\n" x y w h, + custom_ascii $ printf "Rectangle %f %f %f %f\n" x y w h + ] + +-- ---------------------------------------------------------------------- +-- * Customization + +-- $CUSTOMIZATION +-- +-- The document and drawing abstractions provided by this module are +-- purposely kept general-purpose, and do not include +-- application-specific features. However, we provide a mechanism by +-- which applications can provide customized drawing commands and +-- other custom features. + +-- ** Custom drawing commands + +-- $CUSTOMCOMMANDS +-- +-- It is sometimes useful to use customized drawing commands. For +-- example, an application that draws many rectangles might like to +-- define a custom 'rectangle' function for appending a rectangle to +-- the current path. Of course this can be defined as an ordinary +-- Haskell function, using elementary drawing commands: +-- +-- > my_rect :: X -> Y -> X -> Y -> Draw () +-- > my_rect x0 y0 x1 y1 = do +-- > moveto x0 y0 +-- > lineto x0 y1 +-- > lineto x1 y1 +-- > lineto x1 y0 +-- > closepath +-- +-- However, sometimes it is nice to make use of specialized abilities +-- of individual backends. For example, PDF already has a built-in +-- rectangle drawing command, and PostScript has the ability to define +-- custom subroutines within the document text. Using these features +-- can decrease the size of the generated documents. +-- +-- We therefore provide a facility for defining new drawing commands +-- with backend-specific implementations. For example, a more general +-- version of the above 'my_rect' function can be defined as +-- follows: +-- +-- > my_rect :: X -> Y -> X -> Y -> Draw () +-- > my_rect x0 y0 x1 y1 = draw_subroutine alt $ do +-- > moveto x0 y0 +-- > lineto x0 y1 +-- > lineto x1 y1 +-- > lineto x1 y0 +-- > closepath +-- > where +-- > alt = [ +-- > custom_ps $ printf "%f %f %f %f rect\n" x0 y0 x1 y1, +-- > custom_pdf $ printf "%f %f %f %f re\n" x0 y0 (x1-x0) (y1-y0), +-- > custom_ascii $ printf "My_rect %f %f %f %f\n" x0 y0 x1 y1 +-- > ] +-- +-- The idea is to provide a default definition in terms of primitive +-- drawing commands, as well as a list of various backend specific +-- definitions. In the case of PostScript subroutines, the PostScript +-- file must then also be supplied with a definition for the /rect/ +-- subroutine, which can be done with the command 'render_ps_custom': +-- +-- > my_ps_defs = "/rect { ... } bind def\n" +-- > +-- > my_render_ps = render_ps_custom custom { ps_defs = my_ps_defs } +-- +-- Note that the 'draw_subroutine' customization mechanism is entirely +-- optional. Its purpose is to generate shorter output for some +-- backends; if it is omitted, the file may be be longer but should +-- look the same. + +-- | An enumeration of backend languages, for the purpose of defining +-- custom drawing commands. Note that several backends (e.g. EPS and +-- PostScript) may share the same language, and therefore they are +-- only represented once in this enumeration. +data Language = + Language_PS -- ^ PostScript (including EPS) + | Language_PDF -- ^ PDF + | Language_ASCII -- ^ ASCII (for debugging) + deriving (Show, Eq, Ord) + +-- | The type of custom definitions, to be used with the +-- 'draw_subroutine' command. +data CustomDef = CustomDef Language String + deriving (Show) + +-- | Define a custom PostScript definition. +custom_ps :: String -> CustomDef +custom_ps s = CustomDef Language_PS s + +-- | Define a custom PDF definition. +custom_pdf :: String -> CustomDef +custom_pdf s = CustomDef Language_PDF s + +-- | Define a custom ASCII definition. +custom_ascii :: String -> CustomDef +custom_ascii s = CustomDef Language_ASCII s + +-- | Look up an element in a list of 'CustomDef's. +custom_lookup :: Language -> [CustomDef] -> Maybe String +custom_lookup lang defs = + case find (\(CustomDef l _) -> l==lang) defs of + Nothing -> Nothing + Just (CustomDef l s) -> Just s + +-- ---------------------------------------------------------------------- +-- ** Customization interface + +-- | A data structure that holds application-specific meta-data and +-- customization information. +data Custom = Custom { + creator :: String, -- ^ Name of the software that created the file. + -- Example: \"MyApp 1.0\". Note: this is intended + -- to hold the name of the software, not the + -- human user, that created the document. + ps_defs :: String -- ^ Definitions to go in the PostScript + -- preamble. + } + +-- | An empty customization structure. Customizations should be +-- specified by modifying 'custom', for example: +-- +-- > custom { creator = "MyApp 1.0" } +custom :: Custom +custom = Custom { + creator = "", + ps_defs = "" + } + +-- ---------------------------------------------------------------------- +-- * Generic string output + +-- ---------------------------------------------------------------------- +-- ** The WriterMonad class + +-- | A 'WriterMonad' is any monad that one can output strings to. +-- +-- Minimal complete definition: 'wPutChar' or 'wPutStr'. +class Monad m => WriterMonad m where + -- | Write a character. + wPutChar :: Char -> m () + wPutChar c = wPutStr [c] + + -- | Write a string. + wPutStr :: String -> m () + wPutStr s = sequence_ [ wPutChar c | c <- s ] + +-- | Like 'wPutStr', but adds a newline character. +wPutStrLn :: (WriterMonad m) => String -> m () +wPutStrLn s = do + wPutStr s + wPutChar '\n' + +-- | Write a value of any printable type, and add a newline. +wprint :: (WriterMonad m, Show a) => a -> m () +wprint x = wPutStrLn (show x) + +instance WriterMonad IO where + wPutChar = putChar + wPutStr = putStr + +-- ---------------------------------------------------------------------- +-- ** The Writer monad + +-- | A generic 'WriterMonad'. +data Writer a = + Writer_Return a -- ^ Terminate with a result. + | Writer_PutChar Char (Writer a) -- ^ Write a character. + | Writer_PutStr String (Writer a) -- ^ Write a string. + +instance Monad Writer where + return a = Writer_Return a + f >>= g = case f of + Writer_Return a -> g a + Writer_PutChar c f' -> Writer_PutChar c (f' >>= g) + Writer_PutStr s f' -> Writer_PutStr s (f' >>= g) + +instance WriterMonad Writer where + wPutChar c = Writer_PutChar c (Writer_Return ()) + wPutStr s = Writer_PutStr s (Writer_Return ()) + +-- ---------------------------------------------------------------------- +-- ** Isomorphism with (String, a) + +-- | Isomorphically map a 'Writer' computation to a pair of a string +-- and a value. +-- +-- Important usage note: the 'String' in the output is produced +-- lazily, and before /a/ is produced. To preserve laziness, do not +-- evaluate /a/ before the end of 'String' has been reached. +writer_to_pair :: Writer a -> (String, a) +writer_to_pair (Writer_Return a) = ("", a) +writer_to_pair (Writer_PutChar c cont) = (c:t, a) where + (t, a) = writer_to_pair cont +writer_to_pair (Writer_PutStr s cont) = (s ++ t, a) where + (t, a) = writer_to_pair cont + +-- | The inverse of 'writer_to_pair'. +pair_to_writer :: (String, a) -> Writer a +pair_to_writer (s, a) = do + wPutStr s + return a + +-- ---------------------------------------------------------------------- +-- ** Run functions + +-- | Run a 'Writer' computation in any 'WriterMonad'. +run_writer :: (WriterMonad m) => Writer a -> m a +run_writer (Writer_Return a) = return a +run_writer (Writer_PutChar c cont) = do + wPutChar c + run_writer cont +run_writer (Writer_PutStr s cont) = do + wPutStr s + run_writer cont + +-- | Run a writer in the 'IO' monad by printing to a file. +writer_to_file :: Handle -> Writer a -> IO a +writer_to_file h (Writer_Return a) = return a +writer_to_file h (Writer_PutChar c cont) = do + hPutChar h c + writer_to_file h cont +writer_to_file h (Writer_PutStr s cont) = do + hPutStr h s + writer_to_file h cont + +-- | Run a writer by printing to a string. +writer_to_string :: Writer a -> String +writer_to_string = fst . writer_to_pair + +-- ---------------------------------------------------------------------- +-- ** Boxed monads + +-- | Create an identical \"boxed\" copy of a type constructor. This is +-- used for technical reasons, to allow the 'wprintf' operation to be +-- typed. +newtype Boxed m a = Boxed (m a) + +-- | Unbox a boxed item. +unbox :: Boxed m a -> m a +unbox (Boxed x) = x + +instance Monad m => Monad (Boxed m) where + return a = Boxed (return a) + f >>= g = Boxed (unbox f >>= (unbox . g)) + +instance WriterMonad m => WriterMonad (Boxed m) where + wPutChar c = Boxed (wPutChar c) + wPutStr c = Boxed (wPutStr c) + +instance MonadState s m => MonadState s (Boxed m) where + get = Boxed get + put s = Boxed (put s) + +-- ---------------------------------------------------------------------- +-- ** Currying in a boxed monad + +-- | A class to curry/uncurry functions in any boxed monad. This +-- establishes an isomorphism +-- +-- > @fun ≅ args -> Boxed m res,@ +-- +-- where +-- +-- > fun = a1 -> a2 -> ... -> an -> Boxed m res, +-- > args = (a1, (a2, (..., (an, ())))). +class Boxed_Curry fun args m res | fun -> args res m, args res m -> fun where + boxed_curry :: (args -> Boxed m res) -> fun + boxed_uncurry :: fun -> (args -> Boxed m res) + +instance Boxed_Curry (Boxed m a) () m a where + boxed_curry g = g () + boxed_uncurry x = const x + +instance Boxed_Curry fun args m res => Boxed_Curry (a -> fun) (a, args) m res where + boxed_curry g x = boxed_curry (\xs -> g (x,xs)) + boxed_uncurry f (x,xs) = boxed_uncurry (f x) xs + +-- ---------------------------------------------------------------------- +-- ** Formatted printing + +-- | Print a formatted value in the context of a boxed WriterMonad. Usage: +-- +-- wprintf "%f %f" x y :: Boxed Writer +wprintf :: (Boxed_Curry fun args m (), WriterMonad m, Curry fun' args String, PrintfType fun') => String -> fun +wprintf fmt = g where + g = boxed_curry g' + g' args = wPutStr (f' args) + f' = muncurry f + f = printf fmt + +-- | In any 'WriterMonad', introduce a block in which 'wprintf' can be +-- used. This has no computational overhead, i.e., is compiled to the +-- identity operation; it exists only to please the type system, +-- due to the fancy typing of 'wprintf'. +with_printf :: (WriterMonad m) => Boxed m a -> m a +with_printf = unbox + +-- ---------------------------------------------------------------------- +-- ** Filters + +-- $ A filter is any function from strings to strings, but it should +-- usually be lazy. Typical examples are compression, encryption, +-- ASCII armoring, character encoding, and their inverses. +-- +-- We provide a convenient operator for temporarily wrapping a filter +-- around the 'Writer' monad, as well as specific filters. + +-- | Wrap a filter around a 'Writer' computation. This introduces a +-- local block within the 'Writer' monad; all text written within the +-- block is encoded through the given filter. Filters can be composed +-- and nested. +with_filter :: (WriterMonad m) => (String -> String) -> Writer a -> m a +with_filter encoding = run_writer . pair_to_writer . (\(x,y) -> (encoding x, y)) . writer_to_pair + +-- | A filter for performing \"flate\" (also known as \"zlib\") +-- compression. +-- +-- Note: both the input and output strings are regarded as sequences +-- of bytes, not characters. Any characters outside the byte range are +-- truncated to 8 bits. +flate_filter :: String -> String +flate_filter = map chr . map fromIntegral . ByteString.unpack . compress . ByteString.pack . map fromIntegral . map ord + +-- ---------------------------------------------------------------------- +-- * Backends + +-- ---------------------------------------------------------------------- +-- ** Auxiliary functions + +-- | Ensure that the last line of the string ends in a newline +-- character, adding one if necessary. An empty string is considered to contain zero lines, so no newline character needs to be added. +ensure_nl :: String -> String +ensure_nl "" = "" +ensure_nl s = + if last s == '\n' then s else s++"\n" + +-- ---------------------------------------------------------------------- +-- * ASCII output + +-- | Render draw actions as ASCII. +draw_to_ascii :: Draw a -> Writer a +draw_to_ascii (Draw_Return x) = return x +draw_to_ascii (Draw_Write cmd cont) = do + command_to_ascii cmd + draw_to_ascii cont +draw_to_ascii (Draw_Block f) = do + wPutStrLn "begin" + cont <- draw_to_ascii f + wPutStrLn "end" + draw_to_ascii cont + +-- | Render drawing commands as ASCII. +command_to_ascii :: DrawCommand -> Writer () +command_to_ascii (Subroutine draw alt) = + case custom_lookup Language_ASCII alt of + Just out -> wPutStr (ensure_nl out) + Nothing -> draw_to_ascii draw +command_to_ascii cmd = + wprint cmd + +-- | Render a document as ASCII. +document_to_ascii :: Document a -> Writer a +document_to_ascii (Document_Return x) = return x +document_to_ascii (Document_Page x y draw) = do + wPutStrLn $ "startpage " ++ show x ++ " " ++ show y + cont <- draw_to_ascii draw + wPutStrLn "endpage" + document_to_ascii cont +document_to_ascii (Document_Page_defer draw) = do + wPutStrLn "startpage (atend)" + (x, y, cont) <- draw_to_ascii draw + wPutStrLn $ "endpage " ++ show x ++ " " ++ show y + document_to_ascii cont + +-- | Render a document as ASCII. This is for debugging purposes only. +-- The output is a sequence of drawing commands, rather than a +-- graphical representation. +render_ascii :: Document a -> Writer a +render_ascii = document_to_ascii + +-- ---------------------------------------------------------------------- +-- * PostScript output + +-- ---------------------------------------------------------------------- +-- ** Auxiliary functions + +-- | Escape special characters in a string literal. +ps_escape :: String -> String +ps_escape [] = [] +ps_escape ('\\' : t) = '\\' : '\\' : ps_escape t +ps_escape ('(' : t) = '\\' : '(' : ps_escape t +ps_escape (')' : t) = '\\' : ')' : ps_escape t +ps_escape (h : t) = h : ps_escape t + +-- | Remove newline characters in a string. +remove_nl :: String -> String +remove_nl = map f where + f '\n' = ' ' + f '\r' = ' ' + f x = x + +-- ---------------------------------------------------------------------- +-- ** The PSWriter monad + +-- $ For convenience, we wrap the 'Writer' monad in a custom state monad; +-- the latter keeps track of the current document bounding box (i.e., +-- the smallest bounding box containing all pages) and the current +-- number of pages. + +-- | The type of page numbers. +type Page = Integer + +-- | A state to keep track of a current bounding box and page number. +data PS_State = PS_State !X !Y !Page + +-- | The initial 'PS_State'. +ps_state_empty :: PS_State +ps_state_empty = PS_State 0 0 0 + +-- | The 'PSWriter' monad. This is just a 'PS_State' wrapped around +-- the 'Writer' monad. +type PSWriter = Boxed (StateT PS_State Writer) + +instance WriterMonad (StateT PS_State Writer) where + wPutChar c = lift (wPutChar c) + wPutStr s = lift (wPutStr s) + +-- | Run function for the 'PSWriter' monad. +pswriter_run :: PSWriter a -> Writer a +pswriter_run f = evalStateT (unbox f) ps_state_empty + +-- ---------------------------------------------------------------------- +-- *** Access functions for the PSWriter monad + +-- | Get the bounding box. +ps_get_bbox :: PSWriter (X, Y) +ps_get_bbox = do + PS_State x y _ <- get + return (x, y) + +-- | Add to the bounding box. +ps_add_bbox :: X -> Y -> PSWriter () +ps_add_bbox x y = do + PS_State x' y' p <- get + put (PS_State (x `max` x') (y `max` y') p) + +-- | Get the page count. +ps_get_pagecount :: PSWriter Page +ps_get_pagecount = do + PS_State _ _ p <- get + return p + +-- | Return the next page number. +ps_next_page :: PSWriter Page +ps_next_page = do + PS_State x y p <- get + put (PS_State x y (p+1)) + return (p+1) + +-- ---------------------------------------------------------------------- +-- ** Internal rendering to the PSWriter monad + +-- | Render draw actions as PostScript. +draw_to_ps :: Draw a -> PSWriter a +draw_to_ps (Draw_Return x) = return x +draw_to_ps (Draw_Write cmd cont) = do + command_to_ps cmd + draw_to_ps cont +draw_to_ps (Draw_Block body) = do + wPutStrLn "gsave" + cont <- draw_to_ps body + wPutStrLn "grestore" + draw_to_ps cont + +-- | Set the color. +color_to_ps :: Color -> PSWriter () +color_to_ps (Color_RGB r g b) = do + wprintf "%f %f %f setrgbcolor\n" r g b +color_to_ps (Color_Gray v) = do + wprintf "%f setgray\n" v + +-- | Set the font. +font_to_ps :: Font -> PSWriter () +font_to_ps (Font TimesRoman pt) = do + wprintf "/Times-Roman findfont %f scalefont setfont\n" pt +font_to_ps (Font Helvetica pt) = do + wprintf "/Helvetica findfont %f scalefont setfont\n" pt + +-- | Draw a single drawing command to PostScript. +command_to_ps :: DrawCommand -> PSWriter () +command_to_ps (Newpath) = do + wPutStrLn "newpath" +command_to_ps (Moveto x y) = do + wprintf "%f %f moveto\n" x y +command_to_ps (Lineto x y) = do + wprintf "%f %f lineto\n" x y +command_to_ps (Curveto x1 y1 x2 y2 x y) = do + wprintf "%f %f %f %f %f %f curveto\n" x1 y1 x2 y2 x y +command_to_ps (Closepath) = do + wPutStrLn "closepath" +command_to_ps (Stroke) = do + wPutStrLn "stroke" +command_to_ps (Fill color) = do + wPutStrLn "gsave" + color_to_ps color + wPutStrLn "fill" + wPutStrLn "grestore" + wPutStrLn "newpath" +command_to_ps (FillStroke color) = do + wPutStrLn "gsave" + color_to_ps color + wPutStrLn "fill" + wPutStrLn "grestore" + wPutStrLn "stroke" +command_to_ps (TextBox align font color x0 y0 x1 y1 b s) = do + wPutStrLn "gsave" + font_to_ps font + color_to_ps color + wprintf "(%s) %f %f %f %f %f %f textbox\n" (ps_escape s) x0 y0 x1 y1 align yshift + wPutStrLn "grestore" + where + yshift = -b * nominalsize font +command_to_ps (SetLineWidth x) = do + wprintf "%f setlinewidth\n" x +command_to_ps (SetColor color) = do + color_to_ps color +command_to_ps (Translate x y) = do + wprintf "%f %f translate\n" x y +command_to_ps (Scale x y) = do + wprintf "%f %f scale\n" x y +command_to_ps (Rotate angle) = do + wprintf "%f rotate\n" angle +command_to_ps (Comment s) = do + wprintf "%% %s\n" (remove_nl s) +command_to_ps (Subroutine draw alt) = + case custom_lookup Language_PS alt of + Just out -> wprintf "%s" (ensure_nl out) + Nothing -> draw_to_ps draw + +-- | Render a document as PostScript. +document_to_ps :: Custom -> Document a -> PSWriter a +document_to_ps custom document = do + -- global header + wPutStrLn "%!PS-Adobe-3.0" + wPutStrLn "%%LanguageLevel: 2" + when (creator custom /= "") $ do + wprintf "%%%%Creator: %s\n" (creator custom) + wPutStrLn "%%BoundingBox: (atend)" + wPutStrLn "%%HiResBoundingBox: (atend)" + wPutStrLn "%%Pages: (atend)" + wPutStrLn "%%EndComments" + wPutStrLn "%%BeginSetup" + wprintf "%s" global_ps_defs + when (ps_defs custom /= "") $ do + wprintf "%s" (ensure_nl $ ps_defs custom) + wPutStrLn "%%EndSetup" + a <- pages_to_ps document + (x, y) <- ps_get_bbox + pagecount <- ps_get_pagecount + wPutStrLn "%%Trailer" + wprintf "%%%%BoundingBox: 0 0 %d %d\n" (int_ceiling x) (int_ceiling y) + wprintf "%%%%HiResBoundingBox: 0 0 %f %f\n" x y + wprintf "%%%%Pages: %d\n" pagecount + wPutStrLn "%%EOF" + return a + +-- | Global PostScript definitions used by the rendering engine. +global_ps_defs :: String +global_ps_defs = "/textbox { /b exch def /align exch def /y1 exch def /x1 exch def /y0 exch def /x0 exch def /dx x1 x0 sub def /dy y1 y0 sub def /d dx dx mul dy dy mul add sqrt def dup stringwidth pop /w exch def /fontscale w d le {d} {w} ifelse def gsave [dx dy dy neg dx x0 y0] concat 1 fontscale div dup scale fontscale w sub align mul b moveto show grestore } bind def\n" + +-- | Render pages as PostScript. +pages_to_ps :: Document a -> PSWriter a +pages_to_ps (Document_Return a) = return a +pages_to_ps (Document_Page x y draw) = do + page <- ps_next_page + ps_add_bbox x y + wprintf "%%%%Page: %d %d\n" page page + wprintf "%%%%PageBoundingBox: 0 0 %d %d\n" (int_ceiling x) (int_ceiling y) + wprintf "%%%%PageHiResBoundingBox: 0 0 %f %f\n" x y + wPutStrLn "save" + cont <- draw_to_ps draw + wPutStrLn "showpage" + wPutStrLn "restore" + pages_to_ps cont +pages_to_ps (Document_Page_defer draw) = do + page <- ps_next_page + wprintf "%%%%Page: %d %d\n" page page + wPutStrLn "%%PageBoundingBox: (atend)" + wPutStrLn "%%PageHiResBoundingBox: (atend)" + (x, y, cont) <- draw_to_ps draw + wPutStrLn "showpage" + wPutStrLn "%%PageTrailer" + wprintf "%%%%PageBoundingBox: 0 0 %d %d\n" (int_ceiling x) (int_ceiling y) + wprintf "%%%%PageHiResBoundingBox: 0 0 %f %f\n" x y + ps_add_bbox x y + pages_to_ps cont + +-- ---------------------------------------------------------------------- +-- ** Rendering to the Writer monad + +-- | Render document as PostScript. The first argument is a +-- customization data structure. +render_ps_custom :: Custom -> Document a -> Writer a +render_ps_custom custom doc = + pswriter_run (document_to_ps custom doc) + +-- ---------------------------------------------------------------------- +-- * EPS output + +-- $ Encapsulated PostScript (EPS) output is slightly different from +-- normal PostScript output. EPS is limited to a single page, and +-- contains no \"showpage\" command. We permit the user to print a +-- single page from a multi-page document, by specifying the page +-- number. + +-- | Render a document as EPS. Since EPS only permits a single page of +-- output, the 'Page' parameter is used to specify which page (of a +-- potential multi-page document) should be printed. An error will be +-- thrown if the page number was out of range. +-- +-- Note: if the return value is not used, the remaining pages are +-- lazily skipped. +document_to_eps :: Custom -> Page -> Document a -> PSWriter a +document_to_eps custom page (Document_Return a) = + error "document_to_eps: requested page does not exist" +document_to_eps custom page (Document_Page x y draw) + | page == 1 = do + -- EPS header + wPutStrLn "%!PS-Adobe-3.0 EPSF-3.0" + wPutStrLn "%%LanguageLevel: 2" + when (creator custom /= "") $ do + wprintf "%%%%Creator: %s\n" (creator custom) + wprintf "%%%%BoundingBox: 0 0 %d %d\n" (int_ceiling x) (int_ceiling y) + wprintf "%%%%HiResBoundingBox: 0 0 %f %f\n" x y + wPutStrLn "%%Pages: 1" + wPutStrLn "%%EndComments" + wPutStrLn "%%Page: 1 1" + wPutStrLn "save" + wprintf "%s" global_ps_defs + when (ps_defs custom /= "") $ do + wprintf "%s" (ensure_nl $ ps_defs custom) + cont <- draw_to_ps draw + wPutStrLn "restore" + wPutStrLn "%%EOF" + let a = document_skip cont + return a + | otherwise = do + let cont = draw_skip draw + document_to_eps custom (page-1) cont +document_to_eps custom page (Document_Page_defer draw) + | page == 1 = do + -- EPS header + wPutStrLn "%!PS-Adobe-3.0 EPSF-3.0" + wPutStrLn "%%LanguageLevel: 2" + when (creator custom /= "") $ do + wprintf "%%%%Creator: %s\n" (creator custom) + wPutStrLn "%%BoundingBox: (atend)" + wPutStrLn "%%HiResBoundingBox: (atend)" + wPutStrLn "%%Pages: 1" + wPutStrLn "%%EndComments" + wPutStrLn "%%Page: 1 1" + wPutStrLn "save" + wprintf "%s" global_ps_defs + when (ps_defs custom /= "") $ do + wprintf "%s" (ensure_nl $ ps_defs custom) + (x, y, cont) <- draw_to_ps draw + wPutStrLn "restore" + wPutStrLn "%%Trailer" + wprintf "%%%%BoundingBox: 0 0 %d %d\n" (int_ceiling x) (int_ceiling y) + wprintf "%%%%HiResBoundingBox: 0 0 %f %f\n" x y + wPutStrLn "%%EOF" + let a = document_skip cont + return a + | otherwise = do + let (_, _, cont) = draw_skip draw + document_to_eps custom (page-1) cont + +-- | Render document as EPS. The first argument is a customization +-- data structure, and the second argument is the number of the page +-- to extract from the document. +render_eps_custom :: Custom -> Page -> Document a -> Writer a +render_eps_custom custom page doc = + pswriter_run (document_to_eps custom page doc) + +-- ---------------------------------------------------------------------- +-- * PDF output + +-- ---------------------------------------------------------------------- +-- ** Auxiliary functions + +-- | Escape special characters in a string literal. +pdf_escape :: String -> String +pdf_escape [] = [] +pdf_escape ('\\' : t) = '\\' : '\\' : pdf_escape t +pdf_escape ('(' : t) = '\\' : '(' : pdf_escape t +pdf_escape (')' : t) = '\\' : ')' : pdf_escape t +pdf_escape (h : t) = h : pdf_escape t + +-- ---------------------------------------------------------------------- +-- ** The PDF state + +-- $ Creating PDF files requires some state: we need to keep track of +-- the current file position, page numbering, and object numbering. + +-- | A position in a file. The first byte is 0. +type Filepos = Integer + +-- | A PDF object reference. +type Object = Integer + +-- | A state to keep track of PDF document structure: current +-- character count, current TOC, current page, etc. +data PDF_State = PDF_State { + pdf_filepos :: !Filepos, -- ^ Current position in file. + pdf_obj :: !Object, -- ^ Object count. + pdf_xref :: !(Map Object Filepos), -- ^ Cross-reference table. + pdf_page :: !Page, -- ^ Next available page number. + pdf_pagetable :: !(Map Page Object), -- ^ Page table. + pdf_font :: !Integer, -- ^ Next available font number. + pdf_fonttable :: !(Map String String) -- ^ Font table mapping each font's PostScript name to a local name. + } + +-- | The initial 'PDF_State'. +pdf_state_empty :: PDF_State +pdf_state_empty = PDF_State { + pdf_filepos = 0, + pdf_obj = 0, + pdf_xref = Map.empty, + pdf_page = 0, + pdf_pagetable = Map.empty, + pdf_font = 0, + pdf_fonttable = Map.empty + } + +-- ---------------------------------------------------------------------- +-- ** The PDFWriter monad + +-- | The 'RawPDFWriter' monad is just a 'PDF_State' wrapped around +-- the 'Writer' monad. Its 'wPutChar' and 'wPutStr' methods +-- automatically keep track of the file position. +type RawPDFWriter = StateT PDF_State Writer + +instance WriterMonad RawPDFWriter where + wPutChar c = do + lift (wPutChar c) + pdf_inc_filepos 1 + wPutStr s = do + lift (wPutStr s) + pdf_inc_filepos (toInteger $ length s) + +-- | Boxed version of the 'RawPDFWriter' monad. +type PDFWriter = Boxed RawPDFWriter + +-- | Run function for the 'PDFWriter' monad. +pdfwriter_run :: PDFWriter a -> Writer a +pdfwriter_run f = do + evalStateT (unbox f) pdf_state_empty + +-- ---------------------------------------------------------------------- +-- *** Access functions for the PDFWriter monad + +-- | Get the file position. +pdf_get_filepos :: PDFWriter Filepos +pdf_get_filepos = do + s <- get + return $ pdf_filepos s + +-- | Add to the file position. +pdf_inc_filepos :: Integer -> RawPDFWriter () +pdf_inc_filepos n = do + s <- get + let p = pdf_filepos s + put s { pdf_filepos = p+n } + +-- | Get the number of allocated objects. Note that objects are +-- allocated as 1, 2, ..., /n/; this function returns /n/. +pdf_get_objcount :: PDFWriter Object +pdf_get_objcount = do + s <- get + return $ pdf_obj s + +-- | Allocate an unused object identifier. +pdf_next_object :: PDFWriter Object +pdf_next_object = do + s <- get + let o = pdf_obj s + put s { pdf_obj = o+1 } + return $ o+1 + +-- | Add a cross reference to the cross reference table. +pdf_add_xref :: Object -> Filepos -> PDFWriter () +pdf_add_xref obj pos = do + s <- get + let xref = pdf_xref s + put s { pdf_xref = Map.insert obj pos xref } + +-- | Retrieve the cross reference table. +pdf_get_xref :: PDFWriter (Map Object Filepos) +pdf_get_xref = do + s <- get + return $ pdf_xref s + +-- | Get the page count. +pdf_get_pagecount :: PDFWriter Page +pdf_get_pagecount = do + s <- get + return $ pdf_page s + +-- | Return the next page number. +pdf_next_page :: PDFWriter Page +pdf_next_page = do + s <- get + let p = pdf_page s + put s { pdf_page = p+1 } + return $ p+1 + +-- | Add a page to the page table. +pdf_add_pagetable :: Page -> Object -> PDFWriter () +pdf_add_pagetable page obj = do + s <- get + let pagetable = pdf_pagetable s + put s { pdf_pagetable = Map.insert page obj pagetable } + +-- | Retrieve the page table. +pdf_get_pagetable :: PDFWriter (Map Page Object) +pdf_get_pagetable = do + s <- get + return $ pdf_pagetable s + +-- | Look up the local font identifier for a font. +pdf_find_font :: String -> PDFWriter String +pdf_find_font font = do + s <- get + let t = pdf_fonttable s + case Map.lookup font t of + Nothing -> do + let f = pdf_font s + let fontname = "F" ++ show f + put s { pdf_font = f+1, pdf_fonttable = Map.insert font fontname t } + return fontname + Just fontname -> return fontname + +-- | Retrieve the font table. +pdf_get_fonttable :: PDFWriter (Map String String) +pdf_get_fonttable = do + s <- get + return $ pdf_fonttable s + +-- | Clear the font table. +pdf_clear_fonttable :: PDFWriter () +pdf_clear_fonttable = do + s <- get + put s { pdf_font = 0, pdf_fonttable = Map.empty } + +-- ---------------------------------------------------------------------- +-- *** Filters + +-- | A version of 'with_filter' tailored to the 'PDFWriter' monad. +-- +-- This allows certain global state updates within the local block. +-- Specifically, updates to everything except the file position are +-- propagated from the inner to the outer block. The outer block's +-- file position is updated to reflect the encoded content's +-- length. From the inner block's point of view, the file position +-- starts from 0. +with_filter_pdf :: (String -> String) -> PDFWriter a -> PDFWriter a +with_filter_pdf encoding body = do + s <- get + let s' = s { pdf_filepos = 0 } -- pass everything except filepos to the body + (a, s'') <- with_filter encoding $ do + runStateT (unbox body) s' + pos <- pdf_get_filepos + put s'' { pdf_filepos = pos } -- pass everything except filepos from the body + return a + +-- ---------------------------------------------------------------------- +-- *** Higher access functions + +-- | Define an indirect PDF object with the given object id, which +-- must have previously been uniquely obtained with 'pdf_next_object'. +-- +-- This can be used to define objects with forward references: first +-- obtain an object id, then create references to the object, and +-- finally define the object. +-- +-- It should be used like this: +-- +-- > obj <- pdf_next_object +-- > ... +-- > pdf_deferred_object obj $ do +-- > <> +pdf_deferred_object :: Object -> PDFWriter a -> PDFWriter a +pdf_deferred_object obj body = do + pos <- pdf_get_filepos + pdf_add_xref obj pos + wprintf "%d 0 obj\n" obj + a <- body + wprintf "endobj\n" + return a + +-- | Define an indirect PDF object with a newly generated object id. +-- Return the object id. This essentially combines 'pdf_next_object' +-- and 'pdf_deferred_object' into a single function, and should be +-- used like this: +-- +-- > obj <- pdf_define_object $ do +-- > <> +pdf_define_object :: PDFWriter a -> PDFWriter Object +pdf_define_object body = do + obj <- pdf_next_object + pdf_deferred_object obj body + return obj + +-- | Define a PDF stream object with the given object id, which must +-- have previously been uniquely obtained with 'pdf_next_object'. It +-- should be used like this: +-- +-- > obj <- pdf_next_object +-- > ... +-- > pdf_deferred_stream obj $ do +-- > <> +pdf_deferred_stream :: Object -> PDFWriter a -> PDFWriter a +pdf_deferred_stream obj body = do + length_obj <- pdf_next_object + (a, len) <- pdf_deferred_object obj $ do + wprintf "<>\n" (objref length_obj) + wPutStr "stream\n" + x0 <- pdf_get_filepos + a <- body + x1 <- pdf_get_filepos + wPutStr "\n" + wPutStr "endstream\n" + return (a, x1-x0) + pdf_deferred_object length_obj $ do + wprintf "%d\n" len + return a + +-- | Define a PDF stream object with a newly generated object +-- id. Return the object id. This should be used like this: +-- +-- > obj <- pdf_define_stream $ do +-- > <> +pdf_define_stream :: PDFWriter a -> PDFWriter Object +pdf_define_stream body = do + obj <- pdf_next_object + pdf_deferred_stream obj body + return obj + +-- | Define a compressed PDF stream object with the given object id, +-- which must have previously been uniquely obtained with +-- 'pdf_next_object'. It should be used like this: +-- +-- > obj <- pdf_next_object +-- > ... +-- > pdf_deferred_flate_stream obj $ do +-- > <> +pdf_deferred_flate_stream :: Object -> PDFWriter a -> PDFWriter a +pdf_deferred_flate_stream obj body = do + length_obj <- pdf_next_object + (a, len) <- pdf_deferred_object obj $ do + wprintf "<>\n" (objref length_obj) + wPutStr "stream\n" + x0 <- pdf_get_filepos + a <- with_filter_pdf flate_filter body + x1 <- pdf_get_filepos + wPutStr "\n" + wPutStr "endstream\n" + return (a, x1-x0) + pdf_deferred_object length_obj $ do + wprintf "%d\n" len + return a + +-- | Create a direct object from a reference to an indirect object. +objref :: Object -> String +objref n = + show n ++ " 0 R" + +-- | Write one line in the cross reference table. This must be exactly +-- 20 characters long, including the terminating newline. +wprintf_xref_entry :: Filepos -> Integer -> Char -> PDFWriter () +wprintf_xref_entry pos gen c = + wprintf "%010u %05u %c \n" pos gen c + +-- | Format the cross reference table. Return the file position of the +-- cross reference table. +wprintf_xref :: PDFWriter Filepos +wprintf_xref = do + xref <- pdf_get_xref + n <- pdf_get_objcount + pos <- pdf_get_filepos + wprintf "xref\n" + wprintf "0 %d\n" (n+1) + wprintf_xref_entry 0 65535 'f' + sequence_ [ case Map.lookup obj xref of + Nothing -> wprintf_xref_entry 0 0 'f' + Just p -> wprintf_xref_entry p 0 'n' | obj <- [1..n] ] + return pos + +-- ---------------------------------------------------------------------- +-- ** Internal rendering to the PDFWriter monad + +-- | Set the fill color. +fillcolor_to_pdf :: Color -> PDFWriter () +fillcolor_to_pdf (Color_RGB r g b) = do + wprintf "%f %f %f rg\n" r g b +fillcolor_to_pdf (Color_Gray v) = do + wprintf "%f g\n" v + +-- | Set the stroke color. +strokecolor_to_pdf :: Color -> PDFWriter () +strokecolor_to_pdf (Color_RGB r g b) = do + wprintf "%f %f %f RG\n" r g b +strokecolor_to_pdf (Color_Gray v) = do + wprintf "%f G\n" v + +-- | Set the font. +font_to_pdf :: Font -> PDFWriter () +font_to_pdf (Font TimesRoman pt) = do + fn <- pdf_find_font "Times-Roman" + wprintf "/%s %f Tf\n" fn pt +font_to_pdf (Font Helvetica pt) = do + fn <- pdf_find_font "Helvetica" + wprintf "/%s %f Tf\n" fn pt + +-- | Render a drawing command to PDF. +command_to_pdf :: DrawCommand -> PDFWriter () +command_to_pdf (Newpath) = do + wPutStr "n\n" +command_to_pdf (Moveto x y) = do + wprintf "%f %f m\n" x y +command_to_pdf (Lineto x y) = do + wprintf "%f %f l\n" x y +command_to_pdf (Curveto x1 y1 x2 y2 x y) = do + wprintf "%f %f %f %f %f %f c\n" x1 y1 x2 y2 x y +command_to_pdf (Closepath) = do + wPutStr "h\n" +command_to_pdf (Stroke) = do + wPutStr "S\n" +command_to_pdf (Fill color) = do + fillcolor_to_pdf color + wPutStr "f\n" +command_to_pdf (FillStroke color) = do + fillcolor_to_pdf color + wPutStr "B\n" +command_to_pdf (TextBox align font color x0 y0 x1 y1 b s) = do + let w = text_width font s + dx = x1 - x0 + dy = y1 - y0 + d = sqrt (dx*dx + dy*dy) + f = max w d + dxf = if f > 0 then dx/f else 1 + dyf = if f > 0 then dy/f else 1 + xshift = (f-w) * align + yshift = -b * nominalsize font + wPutStr "BT\n" + font_to_pdf font + wprintf "%f %f %f %f %f %f Tm\n" dxf dyf (-dyf) dxf (x0 + xshift*dxf - yshift*dyf) (y0 + xshift*dyf + yshift*dxf) + fillcolor_to_pdf color + wprintf "(%s) Tj\n" (pdf_escape s) + wPutStr "ET\n" +command_to_pdf (SetLineWidth x) = do + wprintf "%f w\n" x +command_to_pdf (SetColor color) = do + strokecolor_to_pdf color +command_to_pdf (Translate x y) = do + wprintf "1 0 0 1 %f %f cm\n" x y +command_to_pdf (Scale x y) = do + wprintf "%f 0 0 %f 0 0 cm\n" x y +command_to_pdf (Rotate angle) = do + wprintf "%f %f %f %f 0 0 cm\n" c s (-s) c where + c = cos (pi/180 * angle) + s = sin (pi/180 * angle) +command_to_pdf (Comment s) = do + wprintf "%% %s\n" (remove_nl s) +command_to_pdf (Subroutine draw alt) = do + case custom_lookup Language_PDF alt of + Just out -> wprintf "%s" (ensure_nl out) + Nothing -> draw_to_pdf draw + +-- | Render a draw action to PDF. +draw_to_pdf :: Draw a -> PDFWriter a +draw_to_pdf (Draw_Return x) = return x +draw_to_pdf (Draw_Write cmd cont) = do + command_to_pdf cmd + draw_to_pdf cont +draw_to_pdf (Draw_Block body) = do + wprintf "q\n" + cont <- draw_to_pdf body + wprintf "Q\n" + draw_to_pdf cont + +-- | Render pages as PDF. The first argument is a reference to the +-- document's page tree node. +-- +-- Note: Acrobat reader cannot handle pages whose bounding box width +-- or height exceed 200 inches (14400 points). Therefore, we +-- automatically scale pages to be no greater than 199 inches. +pages_to_pdf :: Object -> Document a -> PDFWriter a +pages_to_pdf pagetree_obj (Document_Return a) = return a +pages_to_pdf pagetree_obj (Document_Page x y draw) = do + let sc = 14328 / maximum [x, y, 14328] + page <- pdf_next_page + wprintf "%% Page %d\n" page + pdf_clear_fonttable + contents_obj <- pdf_next_object + cont <- pdf_deferred_flate_stream contents_obj $ do + when (sc /= 1.0) $ do + draw_to_pdf $ do + scale sc sc + draw_to_pdf draw + fonttable_obj <- pdf_define_object $ do + fonttable <- pdf_get_fonttable + wprintf "<<\n" + sequence_ [ wprintf "/%s<>\n" x f | (f,x) <- Map.toList fonttable ] + wprintf ">>\n" + page_obj <- pdf_define_object $ do + wprintf "<>/MediaBox[0 0 %f %f]/Contents %s>>\n" (objref pagetree_obj) (objref fonttable_obj) (x*sc) (y*sc) (objref contents_obj) + pdf_add_pagetable page page_obj + pages_to_pdf pagetree_obj cont +pages_to_pdf pagetree_obj (Document_Page_defer draw) = do + page <- pdf_next_page + wprintf "%% Page %d\n" page + pdf_clear_fonttable + contents_obj <- pdf_next_object + (x, y, cont) <- pdf_deferred_stream contents_obj $ do + draw_to_pdf draw + fonttable_obj <- pdf_define_object $ do + fonttable <- pdf_get_fonttable + wprintf "<<\n" + sequence_ [ wprintf "/%s<>\n" x f | (f,x) <- Map.toList fonttable ] + wprintf ">>\n" + let sc = 14328 / maximum [x, y, 14328] + scaled_contents_obj <- + if sc == 1.0 then do + return contents_obj + else do + scale_obj <- pdf_define_stream $ do + draw_to_pdf $ do + scale sc sc + obj <- pdf_define_object $ do + wprintf "[%s %s]\n" (objref scale_obj) (objref contents_obj) + return obj + page_obj <- pdf_define_object $ do + wprintf "<>/MediaBox[0 0 %f %f]/Contents %s>>\n" (objref pagetree_obj) (objref fonttable_obj) (x*sc) (y*sc) (objref scaled_contents_obj) + pdf_add_pagetable page page_obj + pages_to_pdf pagetree_obj cont + +-- | Render a document as PDF. +document_to_pdf :: Custom -> Document a -> PDFWriter a +document_to_pdf custom document = do + -- global header + wprintf "%%PDF-1.3\n" + info_obj <- pdf_define_object $ do + if (creator custom /= "") + then wprintf "<>\n" (pdf_escape $ creator custom) + else wprintf "<<>>\n" + pagetree_obj <- pdf_next_object + catalog_obj <- pdf_define_object $ do + wprintf "<>\n" (objref pagetree_obj) + a <- pages_to_pdf pagetree_obj document + pages <- pdf_get_pagecount + pagetable <- pdf_get_pagetable + pdf_deferred_object pagetree_obj $ do + wprintf "<>\n" + xref_pos <- wprintf_xref + wprintf "trailer\n" + objcount <- pdf_get_objcount + wprintf "<>\n" objcount (objref catalog_obj) (objref info_obj) + wprintf "startxref\n" + wprintf "%d\n" xref_pos + wprintf "%%%%EOF\n" + return a + +-- ---------------------------------------------------------------------- +-- ** Rendering to the Writer monad + +-- | Render document as PDF. The first argument is a +-- customization data structure. +render_pdf_custom :: Custom -> Document a -> Writer a +render_pdf_custom custom doc = pdfwriter_run (document_to_pdf custom doc) + +-- ---------------------------------------------------------------------- +-- * Generic output functions + +-- $BACKENDS +-- +-- The following commands can be used to render documents to various +-- available formats. The available formats are PostScript, PDF, EPS, +-- and an ASCII-based debugging format. Output can be written to +-- standard output, to a file, or to a string. + +-- | Available graphics formats for rendering. +data RenderFormat = + Format_PS -- ^ PostScript. + | Format_PDF -- ^ Portable Document Format. + | Format_EPS Integer -- ^ Encapsulated PostScript. The integer + -- argument specifies which single page to + -- extract from the document. + | Format_Debug -- ^ An ASCII-based debugging format. + deriving Show + +-- | Does the format require raw binary output? +is_binary_format :: RenderFormat -> Bool +is_binary_format Format_PS = False +is_binary_format Format_PDF = True +is_binary_format (Format_EPS page) = False +is_binary_format Format_Debug = False + +-- ---------------------------------------------------------------------- +-- ** Rendering with custom format + +-- $CUSTOMRENDER +-- +-- The following are versions of the generic rendering functions that +-- also take a customization data structure as an additional +-- parameter. + +-- | Render a document to the 'Writer' monad, using the given output +-- format and customization data structure. +render_custom :: RenderFormat -> Custom -> Document a -> Writer a +render_custom Format_PS = render_ps_custom +render_custom Format_PDF = render_pdf_custom +render_custom (Format_EPS page) = (\c -> render_eps_custom c page) +render_custom Format_Debug = \c -> render_ascii + +-- | Render a document to a file, using the given output format and +-- customization data structure. +render_custom_file :: Handle -> RenderFormat -> Custom -> Document a -> IO a +render_custom_file h format custom d = do + when (is_binary_format format) $ do + hSetBinaryMode h True + writer_to_file h (render_custom format custom d) + +-- | Render a document to standard output, using the given output +-- format and customization data structure. +render_custom_stdout :: RenderFormat -> Custom -> Document a -> IO a +render_custom_stdout = render_custom_file stdout + +-- | Render a document to a string, using the given output format and +-- customization data structure. +render_custom_string :: RenderFormat -> Custom -> Document a -> String +render_custom_string format custom d = + writer_to_string (render_custom format custom d) + +-- ---------------------------------------------------------------------- +-- ** Rendering without custom format + +-- | Render a document to the 'Writer' monad, using the given output format. +render :: RenderFormat -> Document a -> Writer a +render format doc = render_custom format custom doc + +-- | Render a document to a file, using the given output format. +render_file :: Handle -> RenderFormat -> Document a -> IO a +render_file h format doc = render_custom_file h format custom doc + +-- | Render a document to standard output, using the given output format. +render_stdout :: RenderFormat -> Document a -> IO a +render_stdout = render_file stdout + +-- | Render a document to a string, using the given output format. +render_string :: RenderFormat -> Document a -> String +render_string format doc = render_custom_string format custom doc diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,675 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Superdoc +main = superdocMain diff --git a/easyrender.cabal b/easyrender.cabal new file mode 100644 --- /dev/null +++ b/easyrender.cabal @@ -0,0 +1,87 @@ +-- The name of the package. +name: easyrender + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: User-friendly creation of EPS, PostScript, and PDF files + +-- A longer description of the package. +description: + + This module provides efficient functions for rendering vector + graphics to a number of formats, including EPS, PostScript, and + PDF. It provides an abstraction for multi-page documents, as well + as a set of graphics primitives for page descriptions. + . + The graphics model is similar to that of the PostScript and PDF + languages, but we only implement a subset of their functionality. + Care has been taken that graphics rendering is done efficiently and + as lazily as possible; documents are rendered \"on the fly\", + without the need to store the whole document in memory. + . + The provided document description model consists of two separate + layers of abstraction: + . + * /drawing/ is concerned with placing marks on a fixed surface, and + takes place in the 'Draw' monad; + . + * /document structure/ is concerned with a sequence of pages, their + bounding boxes, and other meta-data. It takes place in the + 'Document' monad. + . + In principle, the functionality provided by EasyRender is similar to + a subset of Cairo; however, EasyRender is lightweight and at least + an order of magnitude faster. + +-- URL for the project homepage or repository. +homepage: http://www.mathstat.dal.ca/~selinger/easyrender/ + +-- The license under which the package is released. +license: GPL-3 + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Peter Selinger + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: selinger@mathstat.dal.ca + +-- A copyright notice. +copyright: Copyright (c) 2012-2013 Peter Selinger + +-- A classification category for future use by the package catalogue +-- Hackage. These categories have not yet been specified, but the +-- upper levels of the module hierarchy make a good start. +category: Graphics + +-- The type of build used by this package. +build-type: Custom + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.8 + +-- A list of additional files to be included in source distributions +-- built with setup sdist. +extra-source-files: + images/*.png ChangeLog + +library + -- Modules exported by the library. + exposed-modules: Graphics.EasyRender, Graphics.EasyRender.Auxiliary, Graphics.EasyRender.Internal + + -- Modules included in this library but not exported. + -- other-modules: + + -- Other library packages from which modules are imported. + build-depends: base ==4.6.*, zlib ==0.5.*, mtl ==2.1.*, bytestring ==0.10.*, containers ==0.5.*, superdoc ==0.1.* + diff --git a/images/textbox.png b/images/textbox.png new file mode 100644 Binary files /dev/null and b/images/textbox.png differ