diff --git a/CHANGES b/CHANGES deleted file mode 100644 --- a/CHANGES +++ /dev/null @@ -1,59 +0,0 @@ -Version 0.2.2.3: May 2011 - - * Mark package as deprecated in favor of diagrams-core, - diagrams-lib, diagrams-cairo - -Version 0.2.2.2: December 3, 2010 - - * Update containers dependency - * Tested with GHC 7.0.1 - -Version 0.2.2.1: November 13, 2010 - - * update cairo dependency; compiles fine with cairo 0.12 - -Version 0.2.2: November 2, 2010 - - * update mtl dependency to 2.0. Note that due to the changed - definition of Cont, this version does NOT compile with versions of - mtl previous to 2.0. If you need to use a version of mtl < 2.0 - then stick with 0.2.1.3 for now. - -Version 0.2.1.3: May 30, 2010 - - * update cairo version range to allow 0.11 - * include example files in distribution tarball - -Version 0.2.1.2: March 18, 2010 - - * widen some dependency version ranges to include new releases that - still work. - * remove some redundant imports. - -Version 0.2.1.1: September 25, 2009 - - * builds with colour-2.3.1, so update allowable version range - -Version 0.2.1: September 24, 2009 - - * new shape primitive 'arc' - * multi-page PS/PDF output (Ganesh Sittampalam) - * new grid layout combinators (Ganesh Sittampalam) - * new primitives for generating rounded rectangles and rectangular paths - * more path functions, and new path layout 'positionAlong' - * various bug fixes and minor improvements - -Version 0.2: January 31, 2009 - - * rawCairo function for creating primitive diagrams from raw Cairo code - * line join, cap, and dashing attributes - * bouding box visualization functions for debugging - * new padding and positioning combinators - * PDF, PS, and SVG output - * experimental tree layout - * paths, polygons, bezier curves - * create diagrams from text - * render on top of arbitrary background images - * depend on colour package instead of built-in colors - * new examples: snellen, wordcloud, dragon - * emptyPath and pathConcat diff --git a/Graphics/Rendering/Diagrams.hs b/Graphics/Rendering/Diagrams.hs deleted file mode 100644 --- a/Graphics/Rendering/Diagrams.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-type-defaults #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams --- Copyright : (c) Brent Yorgey 2008 --- License : BSD-style (see LICENSE) --- Maintainer : byorgey@gmail.com --- Stability : experimental --- Portability : portable --- --- An embedded domain-specific language (EDSL) for creating simple --- diagrams, illustrations, and other types of graphics, built on top --- of the Cairo rendering engine. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams - ( - - -- * Introduction - - -- $intro - - -- * Primitives - - Diagram, nil - - -- ** Shapes - - , circle - , arc - , rectPath - , rect - , roundRect - , roundRectF - - , regPolyPath - , regPoly - , rotRegPoly - - , shape - , rawCairo - , text - , textPath - - -- ** Spacers - - , hspace - , vspace - , empty - - -- ** Paths - - , Path - , emptyPath - , pathFromVertices, pathFromVectors - , pathToVertices, pathToVectors - , pathConcat - , closed, isClosed - , rotPath - - , straight - , curved - - -- * Combinators - -- $comb - - -- ** Union - - , (##), union, unionA - - -- ** Lists - - , (<>), (//) - , hcat, vcat - , hcatA, vcatA - , hsep, vsep - , hsepA, vsepA - , hdistrib, vdistrib - , hdistribA, vdistribA - - , position, positionA - , positionAlong, positionAlongA - - , grid, gridA, gridAs - - , VAlignment - , top, vcenter, bottom - , HAlignment - , left, hcenter, right - - -- ** Complex layouts - - , tree - - -- ** Miscellaneous - - , pad, padA - , showBBox, showBBoxes - , withSize - - -- * Transformations - -- $transf - - , stretch, scale, scaleX, scaleY - , translate, translateX, translateY - , rotate, rotateR - - , view - - -- * Attributes - -- $attr - - -- ** Colors - -- $color - - , Color - , module Data.Colour.Names - , fillColor, fc - , lineColor, lc - - -- ** Other attributes - - , lineWidth, lw - - , lineCap, LineCap(..) - , lineJoin, LineJoin(..) - , dashing - - , typeface, tf - - -- * Rendering - -- $render - - , renderAs - , renderPagesAs - , OutputType(..) - , SizeSpec(..) - , renderOverPNG - - ) where - -import Graphics.Rendering.Diagrams.Types -import Graphics.Rendering.Diagrams.Shapes -import Graphics.Rendering.Diagrams.Paths -import Graphics.Rendering.Diagrams.Attributes -import Graphics.Rendering.Diagrams.Layouts -import Graphics.Rendering.Diagrams.Engine -import Data.Colour.Names - -{- $intro - -"Graphics.Rendering.Diagrams" is an embedded domain-specific language -(EDSL) for creating simple graphics. It is compositional; starting -with some basic shapes, you can build up complex diagrams by combining -simpler diagrams in various ways. - -A few fundamental concepts to keep in mind: - - * When constructing diagrams, there is no concept of an absolute - coordinate system, although each diagram does have a local - coordinate system. - - * Every diagram has an associated rectangular bounding box, which - determines its positioning and alignment relative to other - diagrams. Usually this makes no difference but there are times - when it\'s nice to be aware of it. For example, translating a - diagram works by moving the diagram relative to its bounding box; - positioning the bounding box where it would have gone means the - diagram itself ends up elsewhere. To visualize bounding boxes, - you can use the 'showBBox' and 'showBBoxes' functions. - - * The positive y-axis points downwards. This also means that - positive rotations are clockwise. - -For some simple examples, see . - -Enjoy! Please send comments, suggestions, bug reports, or patches to -byorgey at cis dot upenn dot edu. - --} - --- | The nil diagram, which takes up no space and produces no output. -nil :: Diagram -nil = Empty - --- | Create a 'Diagram' out of any instance of 'ShapeClass'. -shape :: (ShapeClass s) => s -> Diagram -shape = Prim . Shape - --- | Create text with black fill, no outline, and a default font. -text :: Double -> String -> Diagram -text sz str = fc black $ lw 0 $ textPath sz str - --- | @hspace w@ is a 'Diagram' which produces no output but takes up --- @w@ amount of space horizontally. Useful for manually creating --- horizontal separation between two diagrams. A negative value --- of @w@ can also be used to move two diagrams closer to one --- another. @hspace w@ is equivalent to @empty w 0@. -hspace :: Double -> Diagram -hspace w = empty w 0 - --- | @vspace h@ is a 'Diagram' which produces no output but takes up --- @h@ amount of space vertically. Useful for manually creating --- vertical separation between two diagrams. A negative value of --- @h@ can also be used to move two diagrams closer to one --- another. @vspace h@ is equivalent to @empty 0 h@. -vspace :: Double -> Diagram -vspace h = empty 0 h - --- | @empty w h@ is an empty diagram which produces no output, but --- takes up an amount of space equal to a @w@ by @h@ rectangle. -empty :: Double -> Double -> Diagram -empty w h = Sized (w, h) Empty - --- $comb --- Various ways to combine 'Diagram's into larger 'Diagram's. - --- $transf --- Various ways to modify and transform 'Diagram's. - --- | Explicitly set a diagram's bounding box, by giving the --- coordinates of the upper left and lower right corners (keeping in --- mind that the positive y-axis points downwards). Particularly --- useful for applying to the top-level diagram in order to only --- view a portion of it in the rendered output. -view :: Point -> Point -> Diagram -> Diagram -view (x1,y1) (x2,y2) = Sized (x2-x1, y2-y1) . translate ((x1-x2)/2 - x1) - ((y1-y2)/2 - y1) - --- $attr --- Attributes which affect the way in which a 'Diagram' is rendered. - --- $color --- Diagrams depends on the "Data.Colour" library (available on Hackage --- as the \"colour\" package) for colo(u)r. Any functions expecting a --- color can take any instance of the 'Color' type class, which has --- instances for both the 'Data.Colour.Colour' and --- 'Data.Colour.AlphaColour' types from "Data.Colour". --- --- For normal use, you can just use color names from --- "Data.Colour.Names", which is re-exported by --- "Graphics.Rendering.Diagrams" for convenience. For more --- sophisticated color manipulation, use the facilities provided by --- the "Data.Colour" library. For example, to create a color directly --- from RGB values, you can use the @rgb@ function from --- "Data.Colour.SRGB.Linear". - --- $render --- Rendering diagrams to a file is accomplished with the 'renderAs' --- function. 'renderPagesAs' renders multiple diagrams as multiple --- pages for suitable backends. 'renderOverPNG' also provides a --- specialized rendering method, which overlays a rendererd diagram on --- top of an existing PNG. - --- | Render a diagram to a file. -renderAs :: OutputType -- ^ The output type to use (PNG, PS, PDF, or SVG) - -> String -- ^ The name of the file to create. - -> SizeSpec -- ^ The desired width or height of the image. - -> Diagram -- ^ The diagram to render. - -> IO () -renderAs otype = renderWithBackend (chooseBackend otype) - --- | Render a list of diagrams as separate pages to a file. -renderPagesAs :: OutputType -- ^ The output type to use (PS or PDF) - -> String -- ^ The name of the file to create. - -> SizeSpec -- ^ The desired width or height of the image. - -> [Diagram] -- ^ The diagram to render. - -> IO () -renderPagesAs otype = renderPagesWithBackend (choosePagesBackend otype) - --- | @renderOverPNG infile outfile d@ reads the PNG @infile@ --- and renders @d@ over this, saving the output as a PNG to @outfile@. -renderOverPNG :: FilePath -> FilePath -> Diagram -> IO () -renderOverPNG srcfile dstfile dia = renderOverlayPNG srcfile dstfile dia diff --git a/Graphics/Rendering/Diagrams/Attributes.hs b/Graphics/Rendering/Diagrams/Attributes.hs deleted file mode 100644 --- a/Graphics/Rendering/Diagrams/Attributes.hs +++ /dev/null @@ -1,230 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Attributes --- Copyright : (c) Brent Yorgey 2008 --- License : BSD-style (see LICENSE) --- Maintainer : byorgey@gmail.com --- Stability : experimental --- Portability : portable --- --- Attributes which can be added as annotations to a 'Diagram', --- implemented via instances of 'AttrClass'. --- ------------------------------------------------------------------------------ -module Graphics.Rendering.Diagrams.Attributes - ( defaultAttributes - , fillColor, fc - , lineColor, lc - , lineWidth, lw - , lineCap, C.LineCap(..) - , lineJoin, C.LineJoin(..) - , dashing - - , typeface, tf - - , stretch, scale, scaleX, scaleY - , translate, translateX, translateY - , rotate, rotateR - - ) where - -import Graphics.Rendering.Diagrams.Types - -import qualified Graphics.Rendering.Cairo as C - - --- Fill color ---------------------- - --- | Specify the default fill color for a 'Diagram'. -newtype Fill = Fill SomeColor -instance AttrClass Fill where - renderAttr (Fill (SomeColor f)) = return (setEnvFillColor f) - --- | Draw a diagram using the given fill color. Note that the new --- color only applies to parts of the diagram which are not --- otherwise colored; subdiagrams which already have an explicit --- fill color will not be affected. The default fill color is --- completely transparent. -fillColor :: Color c => c -> Diagram -> Diagram -fillColor = Ann . Attr . Fill . SomeColor - --- | 'fc' is provided as a convenient short synonym for 'fillColor'. -fc :: Color c => c -> Diagram -> Diagram -fc = fillColor - --- Stroke color ---------------------- - --- | Specify the default stroke color for a 'Diagram'. -newtype Stroke = Stroke SomeColor -instance AttrClass Stroke where - renderAttr (Stroke (SomeColor sc)) = return (setEnvStrokeColor sc) - --- | Draw a diagram using the given color for lines. Note that the new --- color only applies to parts of the diagram which are not --- otherwise colored; subdiagrams which already have an explicit --- line color will not be affected. The default line color is black. -lineColor :: Color c => c -> Diagram -> Diagram -lineColor = Ann . Attr . Stroke . SomeColor - --- | 'lc' is provided as a convenient short synonym for 'lineColor'. -lc :: Color c => c -> Diagram -> Diagram -lc = lineColor - - --- Stroke width ------------------------------ - --- | The stroke width to be used in drawing lines or shape outlines. --- Note that the stroke width is measured in /device coordinates/, --- so a stroke width of a certain size will look the same under any --- uniform scaling. Under non-uniform (i.e. different in the x and --- y axes) scaling, however, strokes may look distorted. -newtype StrokeWidth = StrokeWidth Double deriving (Eq, Show, Read) -instance AttrClass StrokeWidth where - renderAttr (StrokeWidth w) = return (setEnvStrokeWidth w) - --- | Draw shape outlines and lines with the given width. Note that --- the line width is invariant under uniform scaling, although under --- non-uniform scaling (scaling by different amounts in the x and y --- axes) lines can become distorted. The default line width is 1. -lineWidth :: Double -> Diagram -> Diagram -lineWidth = Ann . Attr . StrokeWidth - --- | 'lw' is provided as a convenient short synonym for 'lineWidth'. -lw :: Double -> Diagram -> Diagram -lw = lineWidth - --- Fonts ----------------------------- - --- | Set the typeface for a text diagram -newtype Typeface = Typeface String deriving (Eq, Show, Read) -instance AttrClass Typeface where - renderAttr (Typeface fontname) = c $ C.selectFontFace fontname C.FontSlantNormal C.FontWeightNormal >> return id - --- | Change the default typeface to one named. -typeface :: String -> Diagram -> Diagram -typeface fontname = Ann (Attr (Typeface fontname)) - --- | Convenience function to change the typeface. -tf :: String -> Diagram -> Diagram -tf = typeface - --- Rotate ---------------------------- - --- | Rotate a diagram clockwise through a certain number of radians. -newtype Rotate = Rotate Double deriving (Eq, Show, Read) -instance AttrClass Rotate where - renderAttr (Rotate d) = c $ C.rotate d >> return id - --- | @rotateR r@ rotates a diagram clockwise by @r@ radians. -rotateR :: Double -> Diagram -> Diagram -rotateR r = Ann (Attr (Rotate r)) - --- | @rotate f@ rotates a diagram clockwise by fraction @f@ of a --- complete revolution. @rotate f@ is equivalent to @rotateR --- (2*pi*f)@. -rotate :: Double -> Diagram -> Diagram -rotate f = rotateR (2*pi*f) - - --- Translate --------------------------- - --- | Translate a diagram by the given offset. -newtype Translate = Translate Point deriving (Eq, Show, Read) -instance AttrClass Translate where - renderAttr (Translate (x,y)) = c $ C.translate x y >> return id - --- | Translate a diagram by the given relative offsets in the x and y --- directions. Note that the positive x-axis is to the right, while --- the positive y-axis points downwards. -translate :: Double -> Double -> Diagram -> Diagram -translate 0 0 = id -translate dx dy = Ann (Attr (Translate (dx,dy))) - --- | Translate a diagram along the x-axis only. @translateX x@ is --- equivalent to @translate x 0@. -translateX :: Double -> Diagram -> Diagram -translateX dx = translate dx 0 - --- | Translate a diagram along the y-axis only. @translateY y@ is --- equivalent to @translate 0 y@. -translateY :: Double -> Diagram -> Diagram -translateY dy = translate 0 dy - - - --- Scale -------------------------------- - --- | Scale a diagram by the given scaling factors in the x and y axes, --- respectively. -newtype Scale = Scale Point deriving (Eq, Show, Read) -instance AttrClass Scale where - attrSize (Scale k) s = k .*. s - renderAttr (Scale (x,y)) = c $ C.scale x y >> return id - --- | Stretch a diagram by a separate scaling factor for each axis. --- @stretch w h@ scales by a factor of @w@ in the x direction and --- a factor of @h@ in the y direction. -stretch :: Double -> Double -> Diagram -> Diagram -stretch sx sy = Ann (Attr (Scale (sx,sy))) - --- | Scale by the same scaling factor in both dimensions, so the diagram --- retains its aspect ratio. -scale :: Double -> Diagram -> Diagram -scale 1 = id -scale s = stretch s s - --- | Scale a diagram along the x-axis only. @scaleX s@ is equivalent --- to @stretch s 1@. -scaleX :: Double -> Diagram -> Diagram -scaleX sx = stretch sx 1 - --- | Scale a diagram along the y-axis only. @scaleY s@ is equivalent --- to @stretch 1 s@. -scaleY :: Double -> Diagram -> Diagram -scaleY sy = stretch 1 sy - - --- Stroke styles ---------------------------------- - -newtype LCap = LCap C.LineCap -instance AttrClass LCap where - renderAttr (LCap lcap) = c $ C.setLineCap lcap >> return id - --- | Set the line cap style. Valid values for 'LineCap' are --- @LineCapButt@, @LineCapRound@, and @LineCapSquare@. -lineCap :: C.LineCap -> Diagram -> Diagram -lineCap = Ann . Attr . LCap - -newtype LJoin = LJoin C.LineJoin -instance AttrClass LJoin where - renderAttr (LJoin lj) = c $ C.setLineJoin lj >> return id - --- | Set the line join style. Valid values for 'LineJoin' are --- @LineJoinMiter@, @LineJoinRound@, and @LineJoinBevel@. -lineJoin :: C.LineJoin -> Diagram -> Diagram -lineJoin = Ann . Attr . LJoin - -data Dashing = Dashing [Double] Double -instance AttrClass Dashing where - renderAttr (Dashing ds offs) = c $ C.setDash ds offs >> return id - --- | Set the line dashing pattern. -dashing :: [Double] -- ^ a list specifying alternate lengths of on - -- and off portions of the stroke. The empty - -- list indicates no dashing. - -> Double -- ^ an offset into the dash pattern at which the - -- stroke should start - -> Diagram -> Diagram -dashing ds offs = Ann (Attr (Dashing ds offs)) - --- | Apply all the default attributes to a 'Diagram'. -defaultAttributes :: Diagram -> Diagram -defaultAttributes = - case defaultDiaRenderEnv of - (DREnv (SomeColor fillC) (SomeColor strokeC) strokeW) -> - lc strokeC . - lw strokeW . - lineCap C.LineCapButt . - lineJoin C.LineJoinMiter . - dashing [] 0 . - fc fillC diff --git a/Graphics/Rendering/Diagrams/Engine.hs b/Graphics/Rendering/Diagrams/Engine.hs deleted file mode 100644 --- a/Graphics/Rendering/Diagrams/Engine.hs +++ /dev/null @@ -1,254 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Engine --- Copyright : (c) Brent Yorgey 2008 --- License : BSD-style (see LICENSE) --- Maintainer : byorgey@gmail.com --- Stability : experimental --- Portability : portable --- --- The core rendering engine for "Graphics.Rendering.Diagrams", an --- embedded domain-specific language (EDSL) for creating simple --- diagrams. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.Engine - ( - -- * Preprocessing - -- $preproc - - sizeAndPos - - -- * Rendering - -- $render - - -- ** User interface - - , compose - , writePNG, writePS, writePDF, writeSVG - , renderWithBackend - , renderOverlayPNG - , chooseBackend - - , writePagesPS, writePagesPDF - , renderPagesWithBackend - , choosePagesBackend - - -- ** Internals - - , atomic - , render - - ) where - -import Graphics.Rendering.Diagrams.Types - -import qualified Graphics.Rendering.Cairo as C -import Control.Monad.Reader -import Data.List (intersperse) - --- $preproc --- These functions take a user-generated 'Diagram' object and --- preprocess it in preparation for final rendering. The --- preprocessing includes calculating diagram sizes and positioning --- diagrams by the addition of appropriate translate annotations. - --- | Given a 'Diagram', compute its total size, and produce a new --- version of the 'Diagram' with all sub-'Diagram's positioned --- properly. -sizeAndPos :: Diagram -> (Point,Diagram) - --- the empty diagram takes up no space. -sizeAndPos Empty = ((0,0), Empty) - -sizeAndPos d@(Prim (Shape s)) = (shapeSize s, d) - --- ignore the size calculated by the recursive call, and use the given --- size instead. -sizeAndPos (Sized s d) = (s, snd $ sizeAndPos d) - --- attributes may affect the size of a diagram. -sizeAndPos (Ann a@(Attr attr) d) = (attrSize attr s, (Ann a d')) - where (s, d') = sizeAndPos d - -sizeAndPos (Compound (Layout l ds)) = (s, Union ds') - where (s, ds') = layoutSizeAndPos l (fmap sizeAndPos ds) - -sizeAndPos (Union _) = error "sizeAndPos (Union _): This should never happen!" - --- $render --- The rendering code takes a 'Diagram' and turns it into --- actual graphics output, using the Cairo library to perform the low-level --- drawing operations. - --- | Given a target width or height and a user-constructed 'Diagram', --- render it using the Cairo rendering library. Note that 'compose' --- takes care of all the rendering details, including preprocessing --- of the 'Diagram', and scaling/translating the final output so --- that it fits within the given width or height. 'compose' also --- produces the size of the final diagram; the width or height will --- be equal to that specified in the input, and the other dimension --- will be determined by the aspect ratio of the diagram. --- --- The background of the output diagram will be opaque white. --- --- In order to produce a physical output, the output of 'compose' --- must be given as input to an output adapter such as 'writePng'. --- Normally, however, a user of the diagrams library should not need --- to call 'compose' directly. -compose :: SizeSpec -- ^ output width or height - -> Diagram -- ^ 'Diagram' to render - -> (Point, C.Render ()) - -- ^ Output width and height, and Cairo action - -- to render it -compose size d = compose' 1 size d - -compose' :: Double -> SizeSpec -> Diagram -> (Point, C.Render ()) -compose' opacity size d = - - -- Preprocess the diagram, and use the global bounding box size to - -- scale and translate the output so that it fits within the target - -- output width and height. - let ((x,y), d') = sizeAndPos d - (s,sx,sy) = case (size,x,y) of - (Width w,0,0) -> (1,w,w) - (Height h,0,0) -> (1,h,h) - (Width w,0,_) -> (1,w,y) - (Height h,_,0) -> (1,x,h) - (Width w,_,_) -> (w/x, w, y * w/x) - (Height h,_,_) -> (h/y, x * h/y, h) - (Auto, 0,0) -> (1,1,1) - (Auto, 0,_) -> (1,y,y) - (Auto, _,0) -> (1,x,x) - (Auto, _,_) -> (1,x,y) - in (,) (sx, sy) $ do - C.scale s s - C.translate (x/2) (y/2) - - -- Set the output background to opaque white. - C.save - C.setSourceRGBA 1 1 1 opacity - C.paint - C.restore - - -- render the final diagram. - flip runDiaRenderM defaultDiaRenderEnv . render $ d' - --- | Given a rendered diagram, output it to a file in PNG format with --- the given width and height. -writePNG :: String -> Point -> C.Render () -> IO () -writePNG dstfile wh r = usingBackground wh - (\surface -> writeSurfaceToPNG surface dstfile r) - --- | Given a rendered diagram, output it to a file in PNG format with --- the size and background of the PNG image @srcfile@. -overlayPNG :: String -> String -> C.Render () -> IO () -overlayPNG srcfile dstfile r = usingPNG srcfile - (\surface -> writeSurfaceToPNG surface dstfile r) - -writeSurfaceToPNG :: C.Surface -> FilePath -> C.Render () -> IO () -writeSurfaceToPNG surface dstfile r = do - C.renderWith surface r - C.surfaceWriteToPNG surface dstfile - -usingPNG :: FilePath -> (C.Surface -> IO ()) -> IO () -usingPNG srcfile = C.withImageSurfaceFromPNG srcfile -usingBackground :: Point -> (C.Surface -> IO ()) -> IO () -usingBackground (w,h) = C.withImageSurface C.FormatARGB32 (ceiling w) (ceiling h) - -writeSurface :: (String -> Double -> Double -> (C.Surface -> IO a) -> IO a) - -> String - -> Point - -> C.Render a - -> IO a -writeSurface withSurface fileName (w,h) r = - withSurface fileName w h $ \surface -> - C.renderWith surface r - -writePagesSurface :: (String -> Double -> Double -> (C.Surface -> IO ()) -> IO ()) - -> (C.Surface -> Double -> Double -> C.Render ()) - -> String - -> [(Point, C.Render ())] - -> IO () -writePagesSurface withSurface surfaceSetSize fileName pages = - withSurface fileName 0 0 $ \surface -> C.renderWith surface $ - sequence_ $ concat $ intersperse [C.showPage] $ - [[C.save, surfaceSetSize surface w h, r, C.restore] | ((w,h),r) <- pages] - --- | Given a rendered diagram, output it to a file in PostScript --- format with the given width and height. -writePS :: String -> Point -> C.Render () -> IO () -writePS = writeSurface C.withPSSurface - --- | Given a list of rendered diagrams with their height and width, --- output them as separate pages to a file in PostScript format -writePagesPS :: String -> [(Point, C.Render ())] -> IO () -writePagesPS = writePagesSurface C.withPSSurface C.psSurfaceSetSize - --- | Given a rendered diagram, output it to a file in PDF --- format with the given width and height. -writePDF :: String -> Point -> C.Render () -> IO () -writePDF = writeSurface C.withPDFSurface - --- | Given a list of rendered diagrams with their height and width, --- output them as separate pages to a file in DFt format -writePagesPDF :: String -> [(Point, C.Render ())] -> IO () -writePagesPDF = writePagesSurface C.withPDFSurface C.pdfSurfaceSetSize - --- | Given a rendered diagram, output it to a file in SVG --- format with the given width and height. -writeSVG :: String -> Point -> C.Render () -> IO () -writeSVG = writeSurface C.withSVGSurface - --- | Given a file name, an output size specification, and a 'Diagram', --- use a \"backend\" to render the 'Diagram' to an actual physical --- output. -renderWithBackend :: (String -> Point -> C.Render () -> IO ()) -- ^ backend - -> String -- ^ file name - -> SizeSpec -- ^ output size specification - -> Diagram -- ^ the diagram to render - -> IO () -renderWithBackend backend name size dia = backend name wh r - where (wh, r) = compose size dia - --- | Given a file name, an output size specification, and a list of --- 'Diagram's, use a \"backend\" to render the 'Diagram's as separate --- pages to an actual physical output. -renderPagesWithBackend :: (String -> [(Point, C.Render ())] -> IO ()) - -> String - -> SizeSpec - -> [Diagram] - -> IO () -renderPagesWithBackend backend name size dias - = backend name (map (compose size) dias) - -renderOverlayPNG :: FilePath -> FilePath -> Diagram -> IO () -renderOverlayPNG srcfile dstfile dia = overlayPNG srcfile dstfile r - where r = snd $ compose' 0 Auto dia - -chooseBackend :: OutputType -> (String -> Point -> C.Render () -> IO ()) -chooseBackend PNG = writePNG -chooseBackend PS = writePS -chooseBackend PDF = writePDF -chooseBackend SVG = writeSVG - -choosePagesBackend :: OutputType -> (String -> [(Point, C.Render ())] -> IO ()) -choosePagesBackend PS = writePagesPS -choosePagesBackend PDF = writePagesPDF -choosePagesBackend PNG = error "PNG doesn't support multiple pages" -choosePagesBackend SVG = error "SVG doesn't support multiple pages" - --- | Perform a rendering operation atomically, by saving the state and --- restoring it afterwards. -atomic :: DiaRenderM () -> DiaRenderM () -atomic r = (c C.save) >> r >> (c C.restore) - --- | Render a diagram. -render :: Diagram -> DiaRenderM () -render Empty = return () -render (Prim (Shape s)) = renderShape s -render (Ann (Attr a) d) = atomic $ renderAttr a >>= flip local (render d) -render (Union ds) = mapM_ render ds -render (Sized _ d) = render d -render d@(Compound _) = render $ snd $ sizeAndPos d diff --git a/Graphics/Rendering/Diagrams/Layouts.hs b/Graphics/Rendering/Diagrams/Layouts.hs deleted file mode 100644 --- a/Graphics/Rendering/Diagrams/Layouts.hs +++ /dev/null @@ -1,495 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Types --- Copyright : (c) Brent Yorgey 2008 --- License : BSD-style (see LICENSE) --- Maintainer : byorgey@gmail.com --- Stability : experimental --- Portability : portable --- --- Layout definitions for "Graphics.Rendering.Diagrams", an embedded --- domain-specific language (EDSL) for creating simple diagrams. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.Layouts - ( -- * Union - - (##) - , union, unionA - - -- * Lists - - , (<>), (//) - , hcat, vcat - , hcatA, vcatA - , hsep, vsep - , hsepA, vsepA - , hdistrib, vdistrib - , hdistribA, vdistribA - - , position, positionA - , positionAlong, positionAlongA - - , grid, gridA, gridAs - - , VAlignment - , top, vcenter, bottom - , HAlignment - , left, hcenter, right - - -- * Tree - - , tree - - -- * Miscellaneous - - , pad, padA - , showBBox, showBBoxes - , withSize - - ) where - -import Graphics.Rendering.Diagrams.Types -import Graphics.Rendering.Diagrams.Attributes -import Graphics.Rendering.Diagrams.Shapes -import Graphics.Rendering.Diagrams.Paths -import Graphics.Rendering.Diagrams.Engine (sizeAndPos) -import Control.Arrow (first) -import Control.Monad.Cont -import Control.Monad.Identity - -import Data.List (transpose) -import Data.Tree - --- Union ----------------------------------------------- - --- | The union layout, which lays out diagrams superimposed on one --- another. The diagrams can be aligned both vertically and --- horizontally. A union layout with centered alignment in both --- axes is simply the identity layout which does no repositioning of --- subdiagrams. -data UnionLayout = UnionL HAlignment VAlignment -instance LayoutClass UnionLayout [] where - layoutSizeAndPos _ [] = ((0,0), []) - layoutSizeAndPos (UnionL halign valign) pds = ((w,h), positionedDs) - where (sizes, diagrams) = unzip pds - (xs, ys) = unzip sizes - (w,h) = (maximum xs, maximum ys) - xs' = aligns halign w xs - ys' = aligns valign h ys - positionedDs = zipWith3 translate xs' ys' diagrams - --- | Create a 'Diagram' as a union of subdiagrams which will not be --- repositioned. If the subdiagrams overlap, they will appear with --- the first 'Diagram' on the bottom, and the last on top. -union :: [Diagram] -> Diagram -union = unionA hcenter vcenter - --- | Superimpose one diagram atop another. @d1 \#\# d2@ results in a --- diagram in which @d2@ is on top of @d1@ (i.e., @d1@ is drawn --- first, then @d2@). -(##) :: Diagram -> Diagram -> Diagram -d1 ## d2 = union [d1, d2] - --- | Create a 'Diagram' as a union of subdiagrams superimposed on one --- another, aligned vertically and/or horizontally. -unionA :: HAlignment -> VAlignment -> [Diagram] -> Diagram -unionA ha va = Compound . Layout (UnionL ha va) - --- Lists ----------------------------------------------- - --- | The possible ways to arrange a list of diagrams. -data ListType = H -- ^ in a horizontal row, left to right - | V -- ^ in a vertical column, top to bottom - deriving (Eq, Show, Read) - --- | A list of 'Diagram's can be aligned in one of several ways. -data Alignment = TopLeft -- ^ Align along top/left edges, i.e. in - -- the negative direction - | Center -- ^ Align centers - | BottomRight -- ^ Align bottom/right edges, i.e. in - -- the positive direction - deriving (Eq, Show, Read) - --- | Vertical alignment. -type VAlignment = Alignment - --- | Horizontal alignment. -type HAlignment = Alignment - -top, vcenter, bottom :: VAlignment -left, hcenter, right :: HAlignment -top = TopLeft -bottom = BottomRight -left = TopLeft -right = BottomRight -vcenter = Center -hcenter = Center - --- | Compute new coordinates for the centers of the subdiagrams of a --- list, based on the alignment. -aligns :: Alignment -- ^ the alignment to use - -> Double -- ^ the total height (resp. width) we're working with - -> [Double] -- ^ the individual heights (resp. widths) of - -- the diagrams to align - -> [Double] -- ^ the amount to translate each diagram in - -- order to be properly aligned -aligns a h hs = map (align a h) hs - --- | Given a requested alignment, the total width (resp. height) of --- the enclosing bounding box, and the width (resp. height) of a --- diagram, compute the offset needed to properly align the diagram. -align :: Alignment -- ^ the alignment to use - -> Double -- ^ the total height (resp. width) we're working with - -> Double -- ^ the height (resp. widths) of the diagram to - -- align - -> Double -- ^ the offset needed to align the diagram -align a h x = alignOffset a (h - x) - --- | Compute an offset corresponding to a given alignment and width. -alignOffset :: Alignment -> Double -> Double -alignOffset TopLeft x = -x/2 -alignOffset Center _ = 0 -alignOffset BottomRight x = x/2 - - --- | A list of 'Diagram's can be distributed in one of several ways. -data Distribution = Sep Double -- ^ Put a constant separation between - -- each pair of diagrams - | Distrib Alignment Double - -- ^ @Distrib align sep@ represents - -- evenly spaced diagrams, - -- distributed with the @align@ of a - -- diagram placed every @sep@ units. - -- For example, @Distrib TopLeft 50@ - -- means that the top/left of a - -- diagram will occur every 50 - -- units. - deriving (Eq, Show, Read) - --- | A horizontal or vertical list of diagrams, with configurable --- alignment and distribution. -data List = List ListType Alignment Distribution -instance LayoutClass List [] where - layoutSizeAndPos _ [] = ((0,0), []) - layoutSizeAndPos (List typ algn dist) dss = - - -- unzip sizes and diagrams, flipping sizes for a vertical layout - let (sizes, diagrams) = first (map (mswap typ)) $ unzip dss - - -- calculate the total size, given the method of distribution - size = listSize dist sizes - - -- calculate new positions for the subdiagrams, flipping - -- positions back for a vertical layout - pos = map (mswap typ) $ listPosns algn dist size sizes - - -- apply appropriate translates, and flip the final size for a - -- vertical layout - in (mswap typ size, zipWith (uncurry translate) pos diagrams) - --- | Conditionally swap points, so vertical lists can be laid out --- using the same code as horizontal lists, with appropriate swaps --- before and after layout processing. -mswap :: ListType -> Point -> Point -mswap H (x,y) = (x,y) -mswap V (x,y) = (y,x) - --- | Given a method of distribution and the sizes of the subdiagrams --- for a horizontal list, compute the total size of the entire list -listSize :: Distribution -> [Point] -> Point -listSize (Sep sep) ss = (x,y) - where (xs,ys) = unzip ss - x = sum xs + (sep * fromIntegral (length ss - 1)) - y = maximum ys -listSize (Distrib _ sep) ss = (x,y) - where x = sep * fromIntegral (length ss) - y = maximum (map snd ss) - --- | Calculate the final positions for the centers of the subdiagrams --- of a horizontal list, based on the alignment and distribution. -listPosns :: Alignment -- ^ vertical alignment of list elements - -> Distribution -- ^ horizontal distribution - -> Point -- ^ pre-calculated total size of the list - -> [Point] -- ^ sizes of individual elements - -> [Point] -- ^ new coordinates for the center of - -- each list element -listPosns a (Sep sep) (w,h) sizes = zip xs ys - where (ws,hs) = unzip sizes - offsets = scanl (+) 0 ws - offsWSeps = zipWith (+) offsets (zipWith (*) [0..] (repeat sep)) - centers = zipWith (+) (init offsWSeps) (map (/2) ws) - xs = map (subtract (w/2)) centers - ys = aligns a h hs - -listPosns a (Distrib da sep) (w,h) sizes = zip xs ys - where (ws,hs) = unzip sizes - offsets = zipWith (*) [0..] (repeat sep) - centers = zipWith (+) offsets (map (centerOffs da) ws) - centerOffs TopLeft width = width/2 - centerOffs Center _ = sep/2 - centerOffs BottomRight width = sep - width/2 - xs = map (subtract (w/2)) centers - ys = aligns a h hs - --- | Lay out a list of 'Diagram's horizontally from left to right, --- aligned along their top edges. -hcat :: [Diagram] -> Diagram -hcat = hsep 0 - --- | @d1 \<\> d2@ is a 'Diagram' with @d1@ to the left of @d2@, aligned --- along their top edges. -(<>) :: Diagram -> Diagram -> Diagram -d1 <> d2 = hcat [d1, d2] - --- | Lay out a list of 'Diagram's horizontally from left to right, --- with the given vertical alignment ('top', 'vcenter', or 'bottom'). -hcatA :: VAlignment -> [Diagram] -> Diagram -hcatA = hsepA 0 - --- | Lay out a list of 'Diagram's horizontally, aligned along their --- top edges, with a given amount of separation in between each pair. -hsep :: Double -- ^ amount of separation between each pair of diagrams - -> [Diagram] -> Diagram -hsep sep = hsepA sep top - --- | Lay out a list of 'Diagram's horizontally, with the given --- amount of separation in between each pair, using the given --- vertical alignment ('top', 'vcenter', or 'bottom'). -hsepA :: Double -- ^ amount of separation between each pair of diagrams - -> VAlignment -- ^ alignment to use ('top', 'vcenter', or 'bottom') - -> [Diagram] -> Diagram -hsepA = sepA H - --- | Distribute a list of 'Diagram's horizontally according to a --- regular spacing, aligned along their top edges. -hdistrib :: Double -- ^ How far from one diagram to the next? - -> HAlignment -- ^ Distribute according to which parts of - -- the diagrams ('left', 'hcenter', 'right')? - -> [Diagram] -> Diagram -hdistrib sep alignD = hdistribA sep alignD top - --- | Distribute a list of 'Diagram's horizontally according to a --- regular spacing, with the given alignment. -hdistribA :: Double -- ^ How far from one diagram to the next? - -> HAlignment -- ^ Distribute according to which parts of - -- the diagrams ('left', 'hcenter', 'right')? - -> VAlignment -- ^ alignment to use ('top', 'vcenter', 'bottom') - -> [Diagram] -> Diagram -hdistribA = distribA H - --- | Lay out a list of 'Diagram's vertically from top to bottom, --- aligned along their left edges. -vcat :: [Diagram] -> Diagram -vcat = vsep 0 - --- | @d1 \/\/ d2@ is a 'Diagram' with @d1@ above @d2@, aligned --- along their left edges. -(//) :: Diagram -> Diagram -> Diagram -d1 // d2 = vcat [d1, d2] - --- | Lay out a list of 'Diagram's vertically from top to bottom, --- with the given horizontal alignment ('left', 'hcenter', or 'right'). -vcatA :: HAlignment -> [Diagram] -> Diagram -vcatA = vsepA 0 - --- | Lay out a list of 'Diagram's vertically, aligned along their --- left edges, with a given amount of separation in between each pair. -vsep :: Double -- ^ amount of separation between each pair of diagrams - -> [Diagram] -> Diagram -vsep sep = vsepA sep left - --- | Lay out a list of 'Diagram's vertically, with the given --- amount of separation in between each pair, using the given --- horizontal alignment ('left', 'hcenter', or 'right'). - -vsepA :: Double -- ^ amount of separation between each pair of diagrams - -> HAlignment -- ^ alignment to use ('left', 'hcenter', or 'right') - -> [Diagram] -> Diagram -vsepA = sepA V - --- | Distribute a list of 'Diagram's vertically according to a regular --- spacing, aligned along their left edges. -vdistrib :: Double -- ^ How far from one diagram to the next? - -> VAlignment -- ^ Distribute according to which parts of - -- the diagrams ('top', 'vcenter', 'bottom')? - -> [Diagram] -> Diagram -vdistrib sep alignD = vdistribA sep alignD left - --- | Distribute a list of 'Diagram's vertically according to a --- regular spacing, with the given alignment. -vdistribA :: Double -- ^ How far from one diagram to the next? - -> VAlignment -- ^ Distribute according to which parts of - -- the diagrams ('top', 'vcenter', 'bottom')? - -> HAlignment -- ^ alignment to use ('left', 'hcenter', 'right') - -> [Diagram] -> Diagram -vdistribA = distribA V - --- | The mother-combinator for all the @sep@ functions, used --- internally. -sepA :: ListType -> Double -> Alignment -> [Diagram] -> Diagram -sepA lt sep algn = Compound . Layout (List lt algn (Sep sep)) - --- | The mother-combinator for all the @distrib@ functions, used --- internally. -distribA :: ListType -> Double -> Alignment -> Alignment -> [Diagram] -> Diagram -distribA lt sep alignD algn = - Compound . Layout (List lt algn (Distrib alignD sep)) - - --- Explicit subdiagram positioning --------------------- - -data Positioned = Positioned [Point] HAlignment VAlignment -instance LayoutClass Positioned [] where - layoutSizeAndPos _ [] = ((0,0), []) - layoutSizeAndPos (Positioned ps ha va) dss = ((w,h), pds) - where (sizes, diagrams) = unzip dss - (ws, hs) = unzip sizes - (pxs, pys) = unzip ps - - xs' = zipWith (\x w1 -> x - alignOffset ha w1) pxs ws - ys' = zipWith (\y h1 -> y - alignOffset va h1) pys hs - - hws = map (/2) ws - hhs = map (/2) hs - xmax = maximum (zipWith (+) xs' hws) - xmin = minimum (zipWith (-) xs' hws) - w = xmax - xmin - ymax = maximum (zipWith (+) ys' hhs) - ymin = minimum (zipWith (-) ys' hhs) - h = ymax - ymin - - xs'norm = map (subtract (xmin + w/2)) xs' - ys'norm = map (subtract (ymin + h/2)) ys' - - pds = zipWith3 translate xs'norm ys'norm diagrams - --- | Create a diagram from a list of subdiagrams with explicit --- positions in a local coordinate system. Each subdiagram will be --- positioned with its center at the corresponding --- position. @position@ is equivalent to @positionA hcenter --- vcenter@. -position :: [(Point, Diagram)] -> Diagram -position = positionA hcenter vcenter - --- | Create a diagram from a list of subdiagrams with explicit --- positions in a local coordinate system. The alignment options --- specify what part of each subdiagram should be placed on the --- corresponding position. For example, @positionA left top@ will --- position the top left corner of each subdiagram at the --- corresponding point. -positionA :: HAlignment -> VAlignment -> [(Point,Diagram)] -> Diagram -positionA ha va pds = Compound (Layout (Positioned ps ha va) ds) - where (ps, ds) = unzip pds - --- | Create a diagram from a list of subdiagrams and a given path, by --- positioning the subdiagrams at successive vertices of the path. --- If there are more diagrams than path vertices, the extra diagrams --- will be discarded. -positionAlong :: [Diagram] -> Path -> Diagram -positionAlong = positionAlongA hcenter vcenter - --- | A version of 'positionAlong' with explicit alignment. -positionAlongA :: HAlignment -> VAlignment -> [Diagram] -> Path -> Diagram -positionAlongA ha va ds p = positionA ha va $ zip (pathToVertices (0,0) p) ds - --- Tree ------------------------------------------ - --- | Lay out a 'Tree' (from "Data.Tree") of 'Diagram's in a top-down --- fashion. This layout is experimental; future releases of the --- Diagrams library are planned which will be able to automatically --- draw edges between nodes in the tree. -tree :: Double -- ^ separation between layers - -> Double -- ^ separation between siblings - -> Tree Diagram - -> Diagram -tree _ _ (Node d []) = d -tree ls ss (Node d ts) = vsepA ls hcenter [ d, hsep ss (map (tree ls ss) ts) ] - --- Miscellaneous --------------------------------- - -data Padded = Padded Double Double HAlignment VAlignment -instance LayoutClass Padded Identity where - layoutSizeAndPos (Padded dw dh ha va) (Identity ((w,h), d)) - = ((w', h'), [translate (align ha w' w) (align va h' h) d]) - where w' = w + dw - h' = h + dh - --- | Add extra padding to a diagram. @pad w h d@ is a diagram which --- is the same as @d@, but with @w@ units added to the width and @h@ --- units added to the height, with @d@ centered in the available --- space. Thus @pad w h@ is equivalent to @padA w h hcenter vcenter@. -pad :: Double -> Double -> Diagram -> Diagram -pad pw ph d = padA pw ph hcenter vcenter d - --- | Add extra padding to a diagram, aligning the diagram as indicated --- within the avilable space. -padA :: Double -> Double -> HAlignment -> VAlignment -> Diagram -> Diagram -padA pw ph aw ah d = Compound (Layout (Padded pw ph aw ah) (Identity d)) - - - -data ShowBBox = ShowBBox -instance LayoutClass ShowBBox Identity where - layoutSizeAndPos _ (Identity ((w,h), d)) - = ((w,h), [defaultAttributes $ rect w h, d]) - --- | Show a rectangle denoting a diagram's bounding box, in addition --- to the diagram itself. -showBBox :: Diagram -> Diagram -showBBox Empty = Empty -showBBox d = Compound . Layout ShowBBox . Identity $ d - --- | Show the bounding boxes of a diagram and all its subdiagrams. -showBBoxes :: Diagram -> Diagram -showBBoxes Empty = Empty -showBBoxes d@(Prim _) = showBBox d -showBBoxes (Ann a d) = showBBox (Ann a (showBBoxes d)) -showBBoxes (Compound (Layout l ds)) = showBBox (Compound (Layout l (fmap showBBoxes ds))) -showBBoxes (Union ds) = showBBox (Union (map showBBoxes ds)) -showBBoxes (Sized p d) = showBBox (Sized p (showBBoxes d)) - -data FromSize = FromSize (Double -> Double -> Diagram) -instance LayoutClass FromSize Identity where - layoutSizeAndPos (FromSize f) (Identity ((w,h),_)) - = let d = f w h in (fst (sizeAndPos d), [d]) - --- | Create one diagram using the current size of another. --- The new diagram is returned, the old one is discarded. -withSize :: (Double -> Double -> Diagram) -- ^ Function for new diagram - -> Diagram -- ^ Old diagram - -> Diagram -withSize f dia = Compound (Layout (FromSize f) (Identity dia)) - -diagSize :: Diagram -> Cont Diagram (Double, Double) -diagSize d = ContT { runContT = \f -> Identity . flip withSize d $ - \w h -> runIdentity (f (w, h)) } - --- | Align diagrams into a grid, specifying individual alignments for each item. --- Warning: there is currently an exponential performace blowup if you nest grids --- (exponential in how deep the nesting is). -gridAs :: [[(HAlignment, VAlignment)]] -> [[Diagram]] -> Diagram - --- | Align diagrams into a grid with each item aligned as specified. --- Warning: there is currently an exponential performace blowup if you nest grids --- (exponential in how deep the nesting is). -gridA :: HAlignment -> VAlignment -> [[Diagram]] -> Diagram - --- | Align diagrams into a grid, with each item centered horizontally and vertically --- Warning: there is currently an exponential performace blowup if you nest grids. --- (exponential in how deep the nesting is). -grid :: [[Diagram]] -> Diagram - -grid = gridA hcenter vcenter -gridA h v = gridAs (repeat (repeat (h, v))) -gridAs alignss diagss - = flip runCont id $ - do sizess <- mapM (mapM diagSize) diagss - let widths = map (maximum . map fst) (transpose sizess) - heights = map (maximum . map snd) sizess - newsizess = [[(w, h) | w <- widths] | h <- heights] - adjss = zipWith (zipWith (\ (nw, nh) (ow, oh) -> (nw - ow, nh - oh))) newsizess sizess - padTo (width, height) (halign, valign) = padA width height halign valign - return $ vcat $ map hcat $ zipWith3 (zipWith3 padTo) adjss alignss diagss diff --git a/Graphics/Rendering/Diagrams/Paths.hs b/Graphics/Rendering/Diagrams/Paths.hs deleted file mode 100644 --- a/Graphics/Rendering/Diagrams/Paths.hs +++ /dev/null @@ -1,188 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Paths --- Copyright : (c) Brent Yorgey 2008 --- License : BSD-style (see LICENSE) --- Maintainer : byorgey@gmail.com --- Stability : experimental --- Portability : portable --- --- Type definitions and convenience functions for --- "Graphics.Rendering.Diagrams", an embedded domain-specific language --- (EDSL) for creating simple diagrams. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.Paths - ( - emptyPath - - , pathFromVertices, pathFromVectors - , pathToVertices, pathToVectors - , pathConcat - , closed, isClosed - - , rotPath - - , pathSizeAndOffset - , renderPath - - ) where - -import Graphics.Rendering.Diagrams.Types -import qualified Graphics.Rendering.Cairo as C - -import Control.Monad (when) - --- | \"Integrate\" a path given by a starting point and a sequence of --- displacements, resulting in a list of vertex coordinates. -pathInt :: Point -> Path -> [Point] -pathInt s (Path _ vs) = scanl (.+.) s vs - --- | Convert a path into a list of vertices, starting with the given --- vertex. -pathToVertices :: Point -> Path -> [Point] -pathToVertices = pathInt - --- | \"Differentiate\" a list of vertex coordinates to produce an open --- path. Calling 'pathDeriv' on an empty list will result in a --- run-time error. -pathDeriv :: [Point] -> Path -pathDeriv ps = Path Open $ zipWith (.-.) (tail ps) ps - --- | Create an open path from a list of edge displacement vectors. --- For example, @pathFromVectors [(1,1), (3,4)]@ describes the path --- with two segments which first moves one unit in the positive x --- and y directions, and then moves three units in the positive x --- direction and four in the positive y direction. -pathFromVectors :: [Vec] -> Path -pathFromVectors = Path Open - --- | Convert a path to a list of vectors corresponding to the edges of --- the path. -pathToVectors :: Path -> [Vec] -pathToVectors (Path _ vs) = vs - --- | The empty path, i.e. a path with no edges. -emptyPath :: Path -emptyPath = pathFromVectors [] - --- | Create an open path from a list of vertices. For example, --- @pathFromVertices [(1,3), (4,4), (6,5)]@ describes the path with --- two segments which starts at (1,3), has a corner at (4,4), and --- ends at (6,5). Note, however, that the vertices themselves are --- not significant, only the distances between them. That is, --- @pathFromVertices [(0,1), (3,2), (5,3)]@ describes exactly the --- same path. -pathFromVertices :: [Point] -> Path -pathFromVertices [] = emptyPath -pathFromVertices vs = pathDeriv vs - --- | Concatenate two open paths into a single open path consisting of --- the first followed by the second. -pathConcat :: Path -> Path -> Path -pathConcat (Path _ es1) (Path _ es2) = Path Open (es1 ++ es2) - --- | Create a closed path (by connecting the first and last points in --- the path). -closed :: Path -> Path -closed (Path _ vs) = Path Closed vs - --- | Determine whether a 'Path' is closed or open. -isClosed :: Path -> Bool -isClosed (Path Closed _) = True -isClosed _ = False - --- | Rotate a path by a fraction of a circle. @rotPath d@ rotates --- paths by an angle of @d*2*pi@ radians. Note that creating a --- 'Diagram' from a 'Path' (using 'straight' or 'curved' or some --- other such function) and then applying 'rotate' to it is --- different than first applying 'rotPath' to the 'Path' before --- making it into a 'Diagram'. In the latter case, the bounding box --- will be correct, whereas in the former case, the bounding box --- will still correspond to the unrotated version of the path. -rotPath :: Double -> Path -> Path -rotPath d (Path clsd ps) = Path clsd (map rot ps) - where ang = d*2*pi - ca = cos ang - sa = sin ang - rot (x,y) = (x * ca - y * sa, x * sa + y * ca) - --- | Compute the size of a bounding box for the given 'Path', and the --- | offset of the starting vertex from the center. -pathSizeAndOffset :: Path -> (Vec,Point) -pathSizeAndOffset p = case pathInt (0,0) p of - [] -> ((0,0),(0,0)) - ps -> ((xmax - xmin, ymax - ymin), ((-xmax - xmin)/2, (-ymax - ymin)/2)) - where (xs,ys) = unzip ps - xmax = maximum xs - xmin = minimum xs - ymax = maximum ys - ymin = minimum ys - --- | Render a path using a particular style in the Cairo rendering monad. -renderPath :: PathStyle -> Path -> C.Render () -renderPath Straight = renderPathStraight -renderPath (Bezier d) = renderPathBezier d - --- | Render a path using straight line segments. -renderPathStraight :: Path -> C.Render () -renderPathStraight p@(Path clsd vs) = do - let (_,offs) = pathSizeAndOffset p -- not nice to recalculate this, - -- but oh well - - uncurry C.moveTo offs -- move to the start - mapM_ (uncurry C.relLineTo) vs -- draw all the segments - when (clsd==Closed) $ C.closePath -- maybe close the path - --- | Render a path using Bezier curves. The first parameter --- determines what fraction of the path segments will be rounded off --- with curves; the remainder of the segments will be drawn with --- straight lines. -renderPathBezier :: Double -> Path -> C.Render () -renderPathBezier _ (Path _ []) = return () -renderPathBezier d p@(Path clsd segs) | d > 1 = renderPathBezier 1 p - | d < 0 = renderPathBezier 0 p - | otherwise = do - let (_,offs) = pathSizeAndOffset p - segcls = ((-1)*.) . last $ pathInt (0,0) p - isClsd = (clsd == Closed) - - uncurry C.moveTo offs -- move to the first path vertex - - -- move to start of the first straight segment - -- (draw a line if not closed) - uncurry (if' isClsd C.relMoveTo C.relLineTo) ((d/2) *. head segs) - - -- draw (straight, curved) pairs along path - mapM_ (drawCurveSegment d) (zip segs (tail segs)) - - -- if closed path, we still need to draw - -- two more (straight, curved) pairs: - -- one for last segment + closing - -- segment, one for closing segment + - -- first segment - if isClsd - then do - drawCurveSegment d (last segs, segcls) - drawCurveSegment d (segcls, head segs) - else -- otherwise, just finish off the last - -- segment with a straight line - uncurry C.relLineTo ((1 - d/2) *. last segs) - -if' :: Bool -> a -> a -> a -if' True x _ = x -if' False _ x = x - --- | Given a fraction specifying which part of the segments should be --- rounded off, and two segments, draw the straight portion of the --- first segment and the curve between the first and second --- segments, using the shared vertex as a control point. -drawCurveSegment :: Double -> (Vec,Vec) -> C.Render () -drawCurveSegment d (v1, v2) = do - let s = 1 - d - uncurry C.relLineTo $ s *. v1 - - let ctrl@(ctrlx, ctrly) = (d/2) *. v1 - let (endx, endy) = ctrl .+. ((d/2) *. v2) - C.relCurveTo ctrlx ctrly ctrlx ctrly endx endy diff --git a/Graphics/Rendering/Diagrams/Shapes.hs b/Graphics/Rendering/Diagrams/Shapes.hs deleted file mode 100644 --- a/Graphics/Rendering/Diagrams/Shapes.hs +++ /dev/null @@ -1,229 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Shapes --- Copyright : (c) Brent Yorgey 2008 --- License : BSD-style (see LICENSE) --- Maintainer : byorgey@gmail.com --- Stability : experimental --- Portability : portable --- --- Primitive shapes out of which 'Diagram's can be built, implemented --- via instances of 'ShapeClass'. --- ------------------------------------------------------------------------------ -module Graphics.Rendering.Diagrams.Shapes - ( circle - , arc - - , regPolyPath - , regPoly - , rotRegPoly - - , rect - , rectPath - , roundRect - , roundRectF - - , straight - , curved - - , textPath - - , rawCairo - - ) where - -import Graphics.Rendering.Diagrams.Types -import Graphics.Rendering.Diagrams.Attributes (scale) -import Graphics.Rendering.Diagrams.Paths - -import qualified Graphics.Rendering.Cairo as C -import qualified Graphics.Rendering.Cairo.Internal as CI -import Control.Arrow ((&&&)) -import Control.Monad.Reader -import System.IO.Unsafe (unsafePerformIO) -import Control.Exception (bracket) - --- | Draw the shape defined by the current cairo path, using the --- current fill color, stroke color, and stroke width settings. -draw :: DiaRenderM () -draw = do c $ C.save - (rf,gf,bf,af) <- asks (colorToRGBA . envFillColor) - c $ C.setSourceRGBA rf gf bf af - c $ C.fillPreserve - - (rs,gs,bs,as) <- asks (colorToRGBA . envStrokeColor) - c $ C.setSourceRGBA rs gs bs as - sw <- asks envStrokeWidth - c $ fmap dist (C.deviceToUserDistance sw 0) >>= C.setLineWidth - c $ C.stroke - c $ C.restore - where dist (x,y) = sqrt (x*x + y*y) - --- | A unit arc centered at the origin, with a given start and end --- angle in radians. -data Arc = Arc Double Double deriving (Eq, Show, Read) -instance ShapeClass Arc where - shapeSize _ = (2,2) - renderShape (Arc a1 a2) = do - c $ C.arc 0 0 1 a1 a2 - draw - --- | @circle r@ is a circle with radius @r@. -circle :: Double -> Diagram -circle r = arc r 0 1 - --- | @arc r a1 a2@ is a circular arc with radius @r@, starting at --- angle @a1*2*pi@ and proceeding in a direction of increasing angle --- to @a2*2*pi@. -arc :: Double -> Double -> Double -> Diagram -arc r a1 a2 = scale r $ Prim (Shape (Arc (a1*2*pi) (a2*2*pi))) - --- | A path-based shape. -data PathShape = PathShape PathStyle Path deriving (Eq, Show, Read) -instance ShapeClass PathShape where - shapeSize (PathShape _ p) = fst $ pathSizeAndOffset p - renderShape (PathShape style p) = c (renderPath style p) >> draw - --- | @straight@ creates a 'Diagram' from a path, by drawing straight --- lines along the path edges. -straight :: Path -> Diagram -straight = Prim . Shape . PathShape Straight - --- | @curved d p@ is a curved path which follows generally the path --- @p@. The parameter @d@ specifies the amount of corner rounding. --- In particular, @d@ should be a value between 0 and 1, which --- specifies what fraction of the path segments should be rounded --- off with bezier curves, using the path vertices as control --- points. Thus @d = 0@ produces the polygonal path itself, with no --- curved segments; @d = 1@ produces a continuously curving path --- tangent to the midpoints of the path segments; and intermediate --- values of @d@ interpolate between the two. The curved path --- produced will be everywhere differentiable as long as @d > 0@. --- If the path is not closed, the curve will begin and end at the --- first and last path vertices (no rounding will take place at --- these vertices). -curved :: Double -> Path -> Diagram -curved d = Prim . Shape . PathShape (Bezier d) - --- | @regPolyPath n r@ is an open path corresponding to a regular --- polygon, with the first vertex oriented along the positive --- x-axis and proceeding clockwise. -regPolyPath :: Int -> Double -> Path -regPolyPath n r = pathFromVertices verts - where verts = map (((*r) . cos) &&& ((*r) . sin)) - [0,2*pi/nd .. (nd-1)*2*pi/nd] - nd = fromIntegral n - --- | @regPoly n r@ is a regular n-gon, with a circumcircle of radius --- @r@. One vertex is oriented along the positive x-axis. -regPoly :: Int -> Double -> Diagram -regPoly n r = straight . closed $ regPolyPath n r - --- | @rotRegPoly n r a@ is the same as @'regPoly' n r@ but rotated --- through an angle of @a*2*pi@ radians (i.e., @a@ represents a --- fraction of an entire revolution). This is different than --- @'rotate' a $ 'regPoly' n r@; @rotRegPoly@ will adjust the --- bounding box correctly (using 'rotPath'), whereas the --- construction using @rotate@ will still have a bounding box --- corresponding to the unrotated polygon. -rotRegPoly :: Int -> Double -> Double -> Diagram -rotRegPoly n r a = straight . closed . rotPath a $ regPolyPath n r - --- -- | @Rect w@ is a 2w (width) by 2 (height) rectangle, centered at the --- -- origin. --- data Rect = Rect Double deriving (Eq, Show, Read) --- instance ShapeClass Rect where --- shapeSize (Rect w) = (2*w,2) --- renderShape (Rect w) = do --- c $ C.rectangle (-w) (-1) (2*w) 2 --- draw - --- | @rectPath w h@ is a closed path describing a rectangle of width --- @w@ and height @h@. -rectPath :: Double -> Double -> Path -rectPath w h = closed $ pathFromVertices [(0,0), (w,0), (w,h), (0,h)] - --- | @rect w h@ is a rectangle of width @w@ and height @h@. -rect :: Double -> Double -> Diagram -rect w h = straight $ rectPath w h - --- -- | @rect w h@ is a rectangle of width @w@ and height @h@. --- rect :: Double -> Double -> Diagram --- rect w h = scale (h/2) $ Prim (Shape (Rect (w/h))) - --- | @RoundRect w h f@ is a rectangle with rounded corners taking up a --- fraction @f@ of the smaller side. Both dimensions are given to --- avoid unnecessary distortion in the curves when scaling. -data RoundRect = RoundRect Double Double Double deriving (Eq, Show, Read) -instance ShapeClass RoundRect where - shapeSize (RoundRect w h _) = (w,h) - renderShape (RoundRect w h f) = do - let (x,y) = (w/2, h/2) - r = min (w * f) (h * f) - c $ do C.arc (r-x) (r-y) r pi (-pi/2) - C.lineTo (x-r) (-y) - C.arc (x-r) (r-y) r (-pi/2) 0 - C.lineTo (x) (y-r) - C.arc (x-r) (y-r) r 0 (pi/2) - C.lineTo (r-x) (y) - C.arc (r-x) (y-r) r (pi/2) pi - C.closePath - draw - --- | @roundRect w h@ is a rectangle of width @w@ and height @h@ with --- rounded corners having a radius one third the length of the --- shortest edge. -roundRect :: Double -> Double -> Diagram -roundRect w h = Prim . Shape $ RoundRect w h (1/3) - --- | @roundRect w h f@ is a rectangle of width @w@ and height @h@ with --- rounded corners having a radius @f@ times the length of the --- shortest edge. -roundRectF :: Double -> Double -> Double -> Diagram -roundRectF w h f = Prim . Shape $ RoundRect w h f - --- | @Text s t@ is a text string @t@ at size @s@. -data Text = Text Double String deriving (Eq, Show, Read) -instance ShapeClass Text where - shapeSize t = (x,y) - where x = C.textExtentsWidth e + C.textExtentsXbearing e - y = C.fontExtentsHeight f - (f,e) = unsafeExtents t - renderShape (Text s t) = do - c $ do C.setFontSize s - (x,y) <- C.getCurrentPoint - te <- C.textExtents t - fe <- C.fontExtents - C.moveTo - (x - (C.textExtentsWidth te/2) - C.textExtentsXbearing te) - (y + (C.fontExtentsHeight fe/2) - C.fontExtentsDescent fe) - C.textPath t - draw - -{-# NOINLINE unsafeExtents #-} -unsafeExtents :: Text -> (CI.FontExtents, CI.TextExtents) -unsafeExtents (Text s t) = unsafePerformIO $ do - bracket - (CI.create =<< C.createImageSurface C.FormatARGB32 1 1) - (CI.destroy) - (\cxt -> do CI.setFontSize cxt s - te <- CI.textExtents cxt t - fe <- CI.fontExtents cxt - return (fe, te)) - --- | @textPath s t@ is a string of text @t@ at size @s@, --- represented as an outline with separate stroke and fill. -textPath :: Double -> String -> Diagram -textPath s t = Prim (Shape (Text s t)) - -data RawCairo = RawCairo Point (C.Render ()) -instance ShapeClass RawCairo where - shapeSize (RawCairo s _) = s - renderShape (RawCairo _ r) = c r - --- | @rawCairo s r@ is a diagram with bounding box size @s@, rendered --- by executing Cairo 'Render' action @r@. Import --- "Graphics.Rendering.Cairo" to access Cairo operations. -rawCairo :: Point -> C.Render () -> Diagram -rawCairo s r = Prim (Shape (RawCairo s r)) diff --git a/Graphics/Rendering/Diagrams/Types.hs b/Graphics/Rendering/Diagrams/Types.hs deleted file mode 100644 --- a/Graphics/Rendering/Diagrams/Types.hs +++ /dev/null @@ -1,277 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Types --- Copyright : (c) Brent Yorgey 2008 --- License : BSD-style (see LICENSE) --- Maintainer : byorgey@gmail.com --- Stability : experimental --- Portability : portable --- --- Type definitions and convenience functions for --- "Graphics.Rendering.Diagrams", an embedded domain-specific language --- (EDSL) for creating simple diagrams. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.Types - ( - - -- * Primitive types - - Diagram(..) - - , Color(..), SomeColor(..) - , Point, Vec - , (*.), (.+.), (.-.), (.*.) - - , Path(..) - , PathType(..) - , PathStyle(..) - - -- * Shapes, attributes, and layouts - - , ShapeClass(..), Shape(..) - , AttrClass(..), Attr(..) - , LayoutClass(..), Layout(..) - - -- * Rendering - - , DiaRenderEnv(..) - , defaultDiaRenderEnv - , setEnvFillColor, setEnvStrokeColor, setEnvStrokeWidth - , DiaRenderM(..) - , runDiaRenderM - , c - - , SizeSpec(..) - , OutputType(..) - - ) where - -import qualified Graphics.Rendering.Cairo as C -import Control.Monad.Reader -import Data.Colour -import qualified Data.Colour.SRGB as RGB - --- Diagrams ---------------------------------------------------------- - --- | 'Diagram' is the core data type which describes a diagram. --- 'Diagram's may be constructed, transformed, combined, and --- ultimately rendered as an image. -data Diagram = Empty -- ^ The empty diagram - | Prim Shape -- ^ A primitive shape - | Ann Attr Diagram -- ^ An annotated diagram - | Compound Layout -- ^ A compound diagram - | Union [Diagram] -- ^ A fully processed compound - -- diagram, ready for rendering - | Sized Point Diagram - -- ^ An explicitly sized diagram whose bounding box - -- takes up a particular amount of space. - --- Colors ------------------------------------------------------------ - --- | The 'Color' type class encompasses color representations which --- can be used by the Diagrams library; that is, every function in --- the Diagrams library which expects a color can take any type --- which is an instance of 'Color'. Instances are provided for both --- the 'Data.Colour.Colour' and 'Data.Colour.AlphaColour' types from --- the "Data.Colour" library. -class Color c where - colorToRGBA :: c -> (Double,Double,Double,Double) - --- | Existential wrapper for instances of the 'Color' class. -data SomeColor = forall c. Color c => SomeColor c - --- Note: we would like to just be able to say 'instance Color (Colour --- Double)' and so on, but the problem is that the named color --- constants in Data.Colour.Names are polymorphic with type (Floating --- a, Ord a) => Colour a, so trying to pass one of these constants to --- a function like 'lc' gives an error that there is no instance for --- Color (Colour a). Adding a type annotation like 'lc (black :: --- Colour Double)' works, but this is a pain for the user. The --- (admittedly hackish) solution is to make general instances which --- require Floating and Real (so that we can convert to Double with --- fromRational . toRational), and let type defaulting figure out that --- in the expression 'lc black', black should have type Colour Double. - -instance (Floating a, Real a) => Color (Colour a) where - colorToRGBA col = (r,g,b,1) - where c' = RGB.toSRGB . colourConvert $ col - r = RGB.channelRed c' - g = RGB.channelGreen c' - b = RGB.channelBlue c' - -instance (Floating a, Real a) => Color (AlphaColour a) where - colorToRGBA col = (r,g,b,a) - where col' = alphaColourConvert col - a = alphaChannel col' - c' = RGB.toSRGB . alphaToColour $ col' - r = RGB.channelRed c' - g = RGB.channelGreen c' - b = RGB.channelBlue c' - -instance Color SomeColor where - colorToRGBA (SomeColor col) = colorToRGBA col - -alphaToColour :: (Floating a, Ord a, Fractional a) => AlphaColour a -> Colour a -alphaToColour ac | alphaChannel ac == 0 = ac `over` black - | otherwise = darken (recip (alphaChannel ac)) (ac `over` black) - --- Points ------------------------------------------------------------ - --- | Basic 2D points/vectors. -type Point = (Double,Double) -type Vec = Point - --- | Scalar multiplication. -(*.) :: Double -> Point -> Point -s *. (x,y) = (s*x, s*y) - --- | Elementwise addition, subtraction and multiplication for 'Point's. -(.+.), (.-.), (.*.) :: Point -> Point -> Point -(x1,y1) .+. (x2,y2) = (x1 + x2, y1 + y2) -(x1,y1) .*. (x2,y2) = (x1 * x2, y1 * y2) -a .-. b = a .+. ((-1) *. b) - --- Paths ------------------------------------------------------------- - --- | A path can be open (normal) or closed (first and last vertices --- connected automatically). -data PathType = Open | Closed - deriving (Eq, Show, Read) - --- | A path is a series of edges which can be stroked, filled, etc. --- It can be either open (the default) or closed (i.e. the first and --- last vertices are connected). -data Path = Path PathType - [Vec] - deriving (Eq, Show, Read) - --- | The styles in which a path can be rendered. -data PathStyle = Straight | Bezier Double deriving (Eq, Show, Read) - --- Attributes -------------------------------------------------------- - --- | Existential wrapper type for attributes. -data Attr = forall a. AttrClass a => Attr a - --- | Attributes which can be applied as annotations to a 'Diagram', --- and change the way the 'Diagram' is interpreted or rendered. --- Every attribute must be an instance of 'AttrClass'. -class AttrClass a where - - -- | Given an attribute and the size of the diagram to which it is - -- an annotation, return a new size for the diagram. The default - -- implementation is to simply return the size unchanged. - attrSize :: a -> Point -> Point - attrSize _ p = p - - -- | In order to implement this attribute, 'renderAttr' may perform - -- an action in the DiaRenderM monad, and return a function which - -- produces a local modification to the render environment. The - -- change produced by this function will only remain in effect - -- for any sub-diagrams, and the environment will return to its - -- former state afterwards. - renderAttr :: a -> DiaRenderM (DiaRenderEnv -> DiaRenderEnv) - --- Shapes ------------------------------------------------------------ - --- | Existential wrapper type for shapes. -data Shape = forall s. ShapeClass s => Shape s - --- | The primitive shapes which can be used to build up a diagram. --- Every primitive shape must be an instance of 'ShapeClass'. --- --- Given a shape @s@, if @shapeSize s@ evaluates to @(w,h)@, then --- the drawing rendered by @renderShape s@ should fit within a @w@ --- by @h@ rectangle centered at the origin. --- --- You can create your own shape primitives by creating a new data --- type and making it an instance of 'ShapeClass'. If you do so, --- you must be sure that your 'ShapeClass' instance satisfies the --- law described above, on which the rendering engine relies in --- order to compute the proper positions for objects in a diagram. --- Otherwise, instances of your object in a diagram may extend --- outside the boundaries of the rendered image, or inadvertently --- overlap or be overlapped by other diagram elements. Of course, --- you are free to ignore this \"law\" as well; it will cause --- unexpected output at worst, and at best you may find some clever --- way to bend the system to your will. =) --- -class ShapeClass s where - - -- | Calculate the size (the dimensions of a bounding box centered - -- at the origin) of a shape. - shapeSize :: s -> Point - - -- | Calculate a cairo Render action to render a shape. - renderShape :: s -> DiaRenderM () - --- Layouts ----------------------------------------------------------- - --- | An existential wrapper type for layouts. A layout consists of a --- (possibly parameterized) layout type, along with a container of --- 'Diagram's. -data Layout = forall l f. (LayoutClass l f) => Layout l (f Diagram) - --- | All layouts must be instances of 'LayoutClass', along with an --- appropriate container type which must be an instance of Functor. -class (Functor f) => LayoutClass l f where - -- | Given a layout and a container of @(size, diagram)@ pairs (which - -- have already had all subdiagrams appropriately positioned), - -- compute the overall bounding box size for this layout, as well - -- as a list of positioned subdiagrams. - layoutSizeAndPos :: l -> f (Point,Diagram) -> (Point, [Diagram]) - --- Rendering --------------------------------------------------------- - --- | An environment containing additional parameters to be made --- available while rendering, which for one reason or another are --- not or cannot be provided by the cairo 'Render' monad itself. --- For example, cairo only tracks one current color, so we must --- track a fill color and stroke color separately. -data DiaRenderEnv = DREnv { envFillColor :: SomeColor - , envStrokeColor :: SomeColor - , envStrokeWidth :: Double - } - -setEnvFillColor :: Color c => c -> DiaRenderEnv -> DiaRenderEnv -setEnvFillColor col d = d { envFillColor = SomeColor col } - -setEnvStrokeColor :: Color c => c -> DiaRenderEnv -> DiaRenderEnv -setEnvStrokeColor col d = d { envStrokeColor = SomeColor col } - -setEnvStrokeWidth :: Double -> DiaRenderEnv -> DiaRenderEnv -setEnvStrokeWidth w d = d { envStrokeWidth = w } - --- | The default rendering environment: transparent fill with 1-pixel --- black strokes. -defaultDiaRenderEnv :: DiaRenderEnv -defaultDiaRenderEnv = DREnv { envFillColor = SomeColor (transparent :: AlphaColour Double) - , envStrokeColor = SomeColor (black :: Colour Double) - , envStrokeWidth = 1 - } - --- | The custom rendering monad: ReaderT 'DiaRenderEnv' on top of --- cairo's Render monad. -newtype DiaRenderM a = DRM (ReaderT DiaRenderEnv C.Render a) - deriving (Functor, Monad, MonadReader DiaRenderEnv) - --- | Run a 'DiaRenderM' action, given an initial rendering --- environment, to produce a cairo @Render@ action. -runDiaRenderM :: DiaRenderM a -> DiaRenderEnv -> C.Render a -runDiaRenderM (DRM m) e = runReaderT m e - --- | Lift a cairo @Render@ action into a 'DiaRenderM' action. -c :: C.Render a -> DiaRenderM a -c = DRM . lift - --- | A specification of the size of a rendered 'Diagram'. -data SizeSpec = Width Double -- ^ an explicit width; the height is determined automatically - | Height Double -- ^ an explicit height; the width is determined automatically - | Auto -- ^ determine the size automatically - -- (do not scale) - --- | The supported output file types for rendered diagrams. -data OutputType = PNG | PS | PDF | SVG diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,27 +1,30 @@ -Copyright (c) Brent Yorgey 2008-2009 +Copyright (c)2011, Brent Yorgey All rights reserved. Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. -3. Neither the name of the author nor the names of other contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. +modification, are permitted provided that the following conditions are met: -THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -SUCH DAMAGE. + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Brent Yorgey nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,71 +0,0 @@ - -NOTE: This package is DEPRECATED. Instead, please see the -diagrams-core, diagrams-lib, and diagrams-cairo packages. The rest of -the README is retained for historical purposes. - ------------------------------------------------------------------------- - - -Graphics.Rendering.Diagrams provides an embedded domain-specific -language (EDSL) for creating simple graphics in a compositional style. - -For some examples of use, see http://code.haskell.org/diagrams/ . - ------------------------------------------------------------------------- - -To install the Diagrams library: - -1. Get the dependencies - - The diagrams library uses Haskell bindings to the Cairo vector - graphics library. In order to build the diagrams library, you - will first need the following: - - * The Cairo library itself. This is probably available through - your system's package manager and may even already be installed. - On Ubuntu, for example, it is available from the 'libcairo' - package. - - * The Haskell cairo bindings, which are packaged as part of - gtk2hs. Unfortunately, for various technical reasons, gtk2hs is - not cabalized and cannot be downloaded and installed from - Hackage. To get gtk2hs you will need to go to the gtk2hs - website (http://www.haskell.org/gtk2hs/) and follow the - instructions to download and build it. - - * The colour library, which is available from Hackage. If you use - the cabal-install build option described below, the colour - library will be downloaded and installed for you automatically. - -2. Build - - * Option 1: use cabal-install - - If you have cabal-install, *after* installing gtk2hs, you can - install diagrams and the remaining dependencies with - cabal-install: - - cabal install diagrams - - Optionally, you can also pass options such as --user - --prefix=$HOME to install locally. - - * Option 2: manual build - - Once all the dependencies are built and installed, you can build - and install diagrams as follows: - - runhaskell Setup.lhs configure --prefix=$HOME --user - runhaskell Setup.lhs build - runhaskell Setup.lhs install - - (Optionally, you can omit the --prefix and --user arguments to the - configure step, and run the install step with 'sudo' in order to - install the library systemwide.) - -3. Building Haddock documentation (recommended) - - runhaskell Setup.lhs haddock - - Once the documentation has been built, you can access it by - pointing your browser to dist/doc/html/diagrams/index.html. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/diagrams.cabal b/diagrams.cabal --- a/diagrams.cabal +++ b/diagrams.cabal @@ -1,38 +1,18 @@ Name: diagrams -Version: 0.2.2.3 -Stability: unsupported -Description: An embedded domain-specific language (EDSL) for - creating simple diagrams, built on top of the Cairo - rendering engine. NOTE: This package is deprecated, - see the diagrams-core, diagrams-lib, and diagrams-cairo - packages instead. -Homepage: http://code.haskell.org/diagrams -Synopsis: An EDSL for creating simple diagrams +Version: 0.3 +Synopsis: Embedded domain-specific language for declarative vector graphics +Description: Diagrams is an embedded domain-specific langauge for + declarative vector graphics. This package is + just a wrapper that depends on the diagrams-core, + diagrams-lib, and diagrams-cairo packages. +Homepage: http://projects.haskell.org/diagrams License: BSD3 License-file: LICENSE -Extra-source-files: README,CHANGES,example/*.hs Author: Brent Yorgey -Maintainer: byorgey@gmail.com +Maintainer: byorgey@cis.upenn.edu Category: Graphics Build-type: Simple -Cabal-version: >= 1.6 -Tested-with: GHC==6.12.1, GHC==6.10.4, GHC==7.0.1 - -flag testing - description: Testing mode - default: False +Cabal-version: >=1.2 -library - ghc-options: -Wall - if flag(testing) - ghc-options: -Werror - Build-Depends: base >= 2 && < 5, mtl >= 2.0 && < 2.1, - containers >= 0.2 && < 0.5, - cairo >= 0.9 && < 0.13, colour >= 2.2.1 && < 2.4 - Exposed-Modules: Graphics.Rendering.Diagrams, - Graphics.Rendering.Diagrams.Types, - Graphics.Rendering.Diagrams.Paths, - Graphics.Rendering.Diagrams.Shapes, - Graphics.Rendering.Diagrams.Attributes, - Graphics.Rendering.Diagrams.Layouts, - Graphics.Rendering.Diagrams.Engine +Library + Build-depends: diagrams-core, diagrams-lib, diagrams-cairo diff --git a/example/CloudPacker.hs b/example/CloudPacker.hs deleted file mode 100644 --- a/example/CloudPacker.hs +++ /dev/null @@ -1,63 +0,0 @@ -module CloudPacker (diagram) where - --- Cobbled together from snippets and ideas by Chris Done --- http://github.com/chrisdone/wordcloud/ - -import Control.Arrow ((&&&), (***), first) -import Control.Monad (liftM) -import Data.Char (isLetter, toLower) -import Data.List (init, sortBy, foldl') -import Data.Maybe (listToMaybe) -import Data.Ord (comparing) -import qualified Data.Map as M - -import Graphics.Rendering.Diagrams -import Graphics.Rendering.Diagrams.Engine (sizeAndPos) - -type Point = (Int,Int) -type Size = Point -type Rect = (Point,Point) - --- Arrange the text boxes on the page, starting with the --- largest and placing each one in the first gap available. -diagram :: [Diagram] -> Diagram -diagram = arrange . uncurry zip . (f &&& id) - where f = map toPoint . foldl addToLayout [] . map size - -arrange :: [(Point,Diagram)] -> Diagram -arrange = positionA left top . map (first (fromIntegral *** fromIntegral)) - -addToLayout :: [Rect] -> Size -> [Rect] -addToLayout [] sz = let (w,h) = sz in [toRect (-w`div`2,-h`div`2) sz] -addToLayout rs sz = maybe rs (\p -> rs ++ [toRect p sz]) $ listToMaybe $ bestfits sz rs - -bestfits :: Size -> [Rect] -> [Point] -bestfits sz rs = concatMap (\r -> aroundRect sz r rs) rs - -aroundRect :: Size -> Rect -> [Rect] -> [Point] -aroundRect sz r rs = filter valid (potentials sz r) - where valid pt = not (any (overlaps (toRect pt sz)) rs) - -toRect :: Point -> Size -> Rect -toRect (x,y) (w,h) = ((x,y),(x+w,y+h)) -toPoint :: Rect -> Point -toPoint = fst - --- Produces candidates in anti-clockwise order. -potentials :: Size -> Rect -> [Point] -potentials (w,h) ((x1,y1),(x2,y2)) = concat [leftside,rightside,bottomside,topside] - where leftside = init $ map ((,) x) [y..y2] - rightside = init $ map ((,) x2) [y2,y2-1..y] - bottomside = init $ map (flip (,) y2) [x..x2] - topside = init $ map (flip (,) y) [x2,x2-1..x] - (x,y) = (x1 - w, y1 - h) - -overlaps :: Rect -> Rect -> Bool -overlaps r1 r2 = r1 `overlapX` r2 && r1 `overlapY` r2 -overlapX :: Rect -> Rect -> Bool -overlapX ((x1,_),(x1',_)) ((x2,_),(x2',_)) = if x1 < x2 then x1' > x2 else x2' > x1 -overlapY :: Rect -> Rect -> Bool -overlapY ((_,y1),(_,y1')) ((_,y2),(_,y2')) = if y1 < y2 then y1' > y2 else y2' > y1 - -size :: Diagram -> Size -size = (ceiling *** ceiling) . fst . sizeAndPos diff --git a/example/alignment.hs b/example/alignment.hs deleted file mode 100644 --- a/example/alignment.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE ParallelListComp #-} -module Main where - -import Graphics.Rendering.Diagrams -import Data.Colour.SRGB.Linear - -colors = [ rgb r 0 0.5 | r <- [0.2, 0.4 .. 1.0] ] - -circles = [ fc c $ circle r | c <- colors | r <- [5,4..1] ] - -alignments = [ [ (ha,va) | ha <- [left, hcenter, right] ] - | va <- [top, vcenter, bottom] ] - -dia = vsep 2 . - map (hsep 2) . - map (map (\(h,v) -> unionA h v circles)) $ - alignments - -main = do renderAs PNG "alignment.png" (Width 500) dia diff --git a/example/dragon.hs b/example/dragon.hs deleted file mode 100644 --- a/example/dragon.hs +++ /dev/null @@ -1,29 +0,0 @@ -{- Heighway dragon. See http://en.wikipedia.org/wiki/Dragon_curve. -} -module Main where - -import Graphics.Rendering.Diagrams -import Control.Monad.State -import Data.Maybe - -dragonStr :: Int -> String -dragonStr 0 = "FX" -dragonStr n = concatMap rules $ dragonStr (n-1) - where rules 'X' = "X+YF+" - rules 'Y' = "-FX-Y" - rules c = [c] - -strToPath :: String -> Path -strToPath s = pathFromVectors . catMaybes $ evalState c (0,-1) - where c = mapM exec s - exec 'F' = Just `fmap` get - exec '-' = modify left >> return Nothing - exec '+' = modify right >> return Nothing - exec _ = return Nothing - left (x,y) = (-y,x) - right (x,y) = (y,-x) - -dragon :: Int -> Diagram -dragon = lc red . curved 0.8 . strToPath . dragonStr - -main = renderAs PNG "dragon.png" (Height 500) (dragon 14) - diff --git a/example/ferrers.hs b/example/ferrers.hs deleted file mode 100644 --- a/example/ferrers.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Main where - -import Graphics.Rendering.Diagrams -import Graphics.Rendering.Diagrams.Engine -import Graphics.Rendering.Diagrams.Types - -import Data.List -import Data.Function - -partitions :: Int -> [[Int]] -partitions n = partitions' n n - where partitions' 0 _ = [[]] - partitions' n 1 = [replicate n 1] - partitions' n k = do s <- [k,k-1..1] - p <- partitions' (n-s) (min (n-s) s) - return (s:p) - -parts = groupBy ((==) `on` head) . partitions - -ferrersTableaux :: Int -> Diagram -ferrersTableaux = vsep 20 . map (hsep 20 . map ferrers) . parts - -ferrers :: [Int] -> Diagram -ferrers = hsep 3 . map (vsep 3 . flip replicate (circle 10)) - -main = renderAs PNG "ferrers.png" (Height 300) (lw 0 $ fc black $ ferrersTableaux 6) diff --git a/example/fontlist.hs b/example/fontlist.hs deleted file mode 100644 --- a/example/fontlist.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Main where - -import System.Cmd.Utils (pipeLinesFrom) - -import Graphics.Rendering.Diagrams - -import CloudPacker (diagram) - -main = do - (ph, ls) <- pipeLinesFrom "fc-list" [] - let fontnames = map (takeWhile (\c -> c/=':' && c/=',')) ls - renderAs PNG "fontlist.png" Auto $ diagram $ map mkText $ take 30 fontnames - -mkText name = lw 0 $ fc black $ tf name $ textPath 12 name diff --git a/example/ford.hs b/example/ford.hs deleted file mode 100644 --- a/example/ford.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Main where - -import Graphics.Rendering.Diagrams - -import Data.Ratio -import System.Random - -(<+>) :: Rational -> Rational -> Rational -r1 <+> r2 = (numerator r1 + numerator r2) % (denominator r1 + denominator r2) - -farey :: Integer -> [Rational] -farey 0 = [0%1, 1%1] -farey n = filter ((<=n) . denominator) $ insertMediants (farey (n-1)) - -insertMediants :: [Rational] -> [Rational] -insertMediants [] = [] -insertMediants [x] = [x] -insertMediants (x:y:zs) = x : (x <+> y) : insertMediants (y:zs) - -fordCircles :: Integer -> [Diagram] -fordCircles n = map toCircle $ farey n - -toCircle r = translateX r' $ - circle (1 / (2 * d'^2)) - where r' = fromRational r - d' = fromIntegral (denominator r) - -dia :: [Color] -> Diagram -dia colors = view (0,0) (1,1/2) $ - unionA hcenter bottom $ - zipWith fc colors (fordCircles 20) - -randomColors :: [Double] -> [Color] -randomColors (r:g:b:ds) = rgb r g b : randomColors ds - -main :: IO () -main = do - g <- newStdGen - let rs = randoms g - renderAs PNG "ford.png" (Width 500) (dia $ randomColors rs) diff --git a/example/logo.hs b/example/logo.hs deleted file mode 100644 --- a/example/logo.hs +++ /dev/null @@ -1,27 +0,0 @@ -import Graphics.Rendering.Diagrams -import Data.Colour.SRGB - -logo :: Diagram -logo = pad 3 3 $ hsepA 1 bottom [d,i,a,hspace (-1.7),g,r,a,m,s] - -myGreen = sRGB 0 0.8 0 - -d,i,a,g,r,m,s :: Diagram - -d = (fc red $ arc 4 (3/4) (1/4)) ## (fc black $ rect 0.5 8) - -i = fc yellow $ rect 1 5 - -a = lc blue . lw 2 . fc myGreen $ rotRegPoly 3 2.5 (1/12) - -g = fc aliceblue . dashing [0.1,0.1] 0 $ (arc 3 0 (1/2) ## arc 3 (1/4) (3/4)) - -r = curved 1 $ pathFromVertices [(0,6), (0,0), (3,1.5), (0.5, 3), (3,6)] - -m = fc orange . lw 3 . lineJoin LineJoinRound $ halfM <> halfM2 - where halfM = straight . closed $ pathFromVertices [(0,4), (0,0), (2,4)] - halfM2 = straight . closed $ pathFromVertices [(2,4), (2,0), (0,4)] - -s = lw 5 . lc blue $ arc 1.5 (1/4) (7/8) // arc 1.5 (3/4) (3/8) - -main = renderAs PNG "logo.png" (Height 100) logo diff --git a/example/permutations.hs b/example/permutations.hs deleted file mode 100644 --- a/example/permutations.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Main where -import Graphics.Rendering.Diagrams -import Data.Colour.SRGB.Linear - -second f (x,y) = (x,f y) - -select :: [a] -> [(a,[a])] -select [] = [] -select (x:xs) = (x,xs) : map (second (x:)) (select xs) - -permutations :: [a] -> [[a]] -permutations [] = [[]] -permutations xs = do (e, rest) <- select xs - map (e:) $ permutations rest - -dia :: Diagram -dia = arrange $ map colorsToStrip (permutations [red, yellow, blue, green']) - where green' = rgb 0 1 0 - -arrange :: [Diagram] -> Diagram -arrange = hsep 10 . map (vsep 5) . groups - where groups = takeWhile (not . null) . map (take 6) . iterate (drop 6) - -colorsToStrip :: Color c => [c] -> Diagram -colorsToStrip = hcat . map (\c -> fc c $ rect 10 10) - -main = renderAs PNG "permutations.png" (Width 300) dia diff --git a/example/sierpinski.hs b/example/sierpinski.hs deleted file mode 100644 --- a/example/sierpinski.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Main where - -import Graphics.Rendering.Diagrams - -sierpinski :: Int -> Diagram -sierpinski 0 = fc black $ lw 0 $ rotRegPoly 3 1 (-1/4) -sierpinski n = vcatA hcenter [ s - , s <> s] - where s = sierpinski (n-1) - -main = renderAs PNG "sierpinski.png" (Height 300) (sierpinski 6) - diff --git a/example/snellen.hs b/example/snellen.hs deleted file mode 100644 --- a/example/snellen.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Main where - -import Graphics.Rendering.Diagrams - -main = renderAs PNG "snellen.png" (Width 400) snellen - -snellen = vcatA hcenter $ zipWith text sizes letters - -sizes = [36,24,18,12,9,6,5,4,3] -letters = ["A","D F","H Z P","T X U D","Z A D N H","P N T U H X" - ,"U A Z N F D T","N P H T A F X U","X D F H P T Z A N" - ,"F A X T D N H U P Z"] - diff --git a/example/wordcloud.hs b/example/wordcloud.hs deleted file mode 100644 --- a/example/wordcloud.hs +++ /dev/null @@ -1,73 +0,0 @@ -module Main where - --- Cobbled together from snippets and ideas by Chris Done --- http://github.com/chrisdone/wordcloud/ - -import Control.Monad (liftM) -import Data.Char (isLetter, toLower) -import Data.List (sortBy, foldl') -import Data.Ord (comparing) -import qualified Data.Map as M - -import System.Random (getStdGen, randomRs) -import System.Environment (getArgs) - -import Graphics.Rendering.Diagrams -import Data.Colour (withOpacity) -import Data.Colour.SRGB.Linear (rgb) - -import CloudPacker (diagram) - -type Weight = Int -type Word = String -type Histogram = [(Word,Weight)] -type Colour = [Double] - --- Word histograms. --- -histogramByFreq :: [Word] -> String -> Histogram -histogramByFreq badws = list . table where - table = filterByGood badws . histogram . words . map toLetter - list = take 150 . sortBy (flip (comparing snd)) . M.toAscList - -toLetter c | isLetter c = c - | otherwise = ' ' - -histogram = foldl' (flip $ flip (M.insertWith' $ const (+1)) 1) M.empty - -filterByGood badws = M.filterWithKey (\x y -> goodWord x) where - goodWord [_] = False - goodWord w = not $ any (==(map toLower w)) badws -- No articles. - -stopwords = words "import qualified hiding data newtype type deriving instance do if then else case of let where" - - -main = do - args <- getArgs - let input = case args of - "-":_ -> getContents - filename:_ -> readFile filename - _ -> readFile "wordcloud.hs" - weightedwords <- histogramByFreq stopwords `liftM` input - rands <- groupsOf 3 `liftM` randomRs (0,1) `liftM` getStdGen - let sizedwords = mkWords weightedwords rands - renderAs PNG "wordcloud.png" (Width 500) $ diagram sizedwords - - --- Sizing and colouring the text according to the --- weight given in the histogram. -mkWords :: Histogram -> [Colour] -> [Diagram] -mkWords wwds cols = zipWith (mkWord maxweight) wwds cols - where maxweight = snd $ head wwds - -mkColour [r,g,b] a = rgb r g b `withOpacity` max a 0.1 - -mkWord :: Weight -> (Word,Weight) -> Colour -> Diagram -mkWord mx (s,w) col = fc c $ lw 0 $ tf "URW Bookman L" $ textPath sz s - where sz = fromIntegral w * 10 - c = mkColour col (max 0.2 (fromIntegral w/fromIntegral mx)) - -groupsOf :: Int -> [a] -> [[a]] -groupsOf n [] = [] -groupsOf n xs = let (grp, remainder) = splitAt n xs - in grp : groupsOf n remainder