diagrams-cairo 0.2 → 0.3
raw patch · 12 files changed
+273/−114 lines, 12 filesdep +mtldep ~diagrams-coredep ~diagrams-libPVP ok
version bump matches the API change (PVP)
Dependencies added: mtl
Dependency ranges changed: diagrams-core, diagrams-lib
API changes (from Hackage documentation)
+ Diagrams.Backend.Cairo: instance Renderable Image Cairo
+ Diagrams.Backend.Cairo: instance Renderable Text Cairo
Files
- CHANGES +8/−0
- diagrams-cairo.cabal +5/−5
- example/Fractal.hs +0/−2
- example/Hanoi.hs +2/−5
- example/Hasse.hs +11/−14
- example/Logo.hs +56/−0
- example/Star.hs +21/−0
- example/golden.hs +1/−1
- example/paradox.hs +12/−14
- example/tic-tac-toe/Maps.hs +7/−8
- example/triangular-numbers.hs +1/−3
- src/Diagrams/Backend/Cairo.hs +149/−62
CHANGES view
@@ -16,3 +16,11 @@ (e.g. to use to paint a gtk window) can use the second component. * add support for opacity attribute and path clipping++0.3: 18 June 2011++ * Some new/improved examples++ * New features:+ + simple text support+ + simple support for external PNG images
diagrams-cairo.cabal view
@@ -1,5 +1,5 @@ Name: diagrams-cairo-Version: 0.2+Version: 0.3 Synopsis: Cairo backend for diagrams drawing EDSL Description: This package provides a modular backend for rendering diagrams created with the diagrams EDSL using the @@ -8,8 +8,7 @@ License: BSD3 License-file: LICENSE Author: Brent Yorgey-Maintainer: byorgey@cis.upenn.edu-Stability: Experimental+Maintainer: diagrams-discuss@googlegroups.com Category: Graphics Build-type: Simple Cabal-version: >=1.6@@ -25,11 +24,12 @@ Diagrams.Backend.Cairo.CmdLine Hs-source-dirs: src Build-depends: base >= 4.2 && < 4.4,+ mtl >= 2.0 && < 2.1, process >= 1.0 && < 1.1, directory >= 1.0 && < 1.2, old-time >= 1.0 && < 1.1,- diagrams-core >= 0.2 && < 0.3,- diagrams-lib >= 0.2 && < 0.3,+ diagrams-core >= 0.3 && < 0.4,+ diagrams-lib >= 0.3 && < 0.4, cairo >= 0.10.1 && < 0.13, cmdargs >= 0.6 && < 0.8, split >= 0.1.2 && < 0.2
example/Fractal.hs view
@@ -31,6 +31,4 @@ p = polygon with { sides = 5, orientation = OrientToX } # lw 0 -showOrigin d = (circle # fc red # scale (0.05)) `atop` d- main = defaultMain (pad 1.1 $ pentaflake' 4)
example/Hanoi.hs view
@@ -14,8 +14,7 @@ type Move = (Int,Int) renderDisk :: Disk -> D-renderDisk n = square- # scaleX (fromIntegral n + 2)+renderDisk n = rect (fromIntegral n + 2) 1 # lc black # fc (colors !! n) # lw 0.1@@ -24,9 +23,7 @@ renderStack s = disks `atop` post where disks = (vcat . map renderDisk $ s) # alignB- post = square- # scaleY 6- # scaleX 0.8+ post = rect 0.8 6 # lw 0 # fc saddlebrown # alignB
example/Hasse.hs view
@@ -22,20 +22,19 @@ . subsequences $ [1..n] +drawElts n elts = hcat . map (\i -> if i `elem` elts then drawElt i else strutX 1) $ [1..n]+drawElt e = unitSquare # fc (colors !! e) # lw 0.05 # freeze+ drawSet :: Subset -> D drawSet (Subset n elts) = ( drawElts n elts # centerXY- <> square # scaleX (fromIntegral n + 0.5) # scaleY 1.5- # dashing [0.2,0.2] 0- # lw 0.03- # namePoint (boundary (negateV unitY)) "B"- # namePoint (boundary unitY) "T"- # (show elts |>)+ <> rect (fromIntegral n + 0.5) 1.5+ # dashing [0.2,0.2] 0+ # lw 0.03+ # named elts ) # freeze -drawElts n elts = hcat . map (\i -> if i `elem` elts then drawElt i else strutX 1) $ [1..n]-drawElt e = square # fc (colors !! e) # lw 0.05 # freeze-+hasseRow = centerX . hcat' with {sep = 2} . map drawSet hasseDiagram n = setsD # drawConnections where setsD = vcat' with {sep = fromIntegral n} . map hasseRow . reverse $ subsets@@ -45,11 +44,9 @@ , s2 <- subs2 , s1 `isSubset` s2 ] connect (Subset _ elts1) (Subset _ elts2) =- withName (show elts1 ||> "T") $ \p1 ->- withName (show elts2 ||> "B") $ \p2 ->- (<> stroke (fromVertices [p1,p2]) # lw 0.03)+ withANameB elts1 $ \p1 b1 ->+ withANameB elts2 $ \p2 b2 ->+ (<> (boundaryFrom p1 unitY b1 ~~ boundaryFrom p2 unit_Y b2) # lw 0.03) subsets = subsetsBySize n--hasseRow = centerX . hcat' with {sep = 2} . map drawSet main = defaultMain (pad 1.1 $ hasseDiagram 4)
+ example/Logo.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE NoMonomorphismRestriction #-}++import Diagrams.Prelude+import Diagrams.Backend.Cairo.CmdLine++import qualified Data.Colour as C++{-+d = mconcat . map alignBR+ $ [ dBody+ , rect 0.5 6.5 # fc black+ ]++blues = iterate (C.blend 0.1 white) blue+ # take 11 # reverse++dBody = mconcat . reverse . zipWith fc blues . take 11 . iterate (rotateBy (-1/20)) . rotateBy (-1/4) $ halfC++halfC = arc 0 (1/2 :: CircleFrac)+ # scale 1.8+ # stroke+ # lw 0+-}++i = (circle 1 === strutY 0.5 === roundedRect (2,4) 0.4)+ # lw 0.05+ # lc blue+ # fc yellow++sierpinski 1 = polygon with { sides = 3, orientation = OrientToX }+sierpinski n = s === (s ||| s)+ where s = sierpinski (n-1)++a = sierpinski 4+ # fc black+ # scale (1/2)++grid = verts # centerXY <> horiz # centerXY+ where verts = hcat' with {sep=0.5} $ replicate 20 (vrule 10)+ horiz = rotateBy (1/4) verts++g = grid+ # lc gray+ # rotateBy (-1/20)+ # clipBy p+ # withBounds (p :: Path R2)+ where p = polygon with {sides = 4, orientation = OrientToX} # scaleToX 5 # scaleToY 5++m = square 5.5 <>+ text "m"+ # fontSize 6 # italic # font "freeserif" # fc green++logo = (hcat' with {sep = 0.5} . map alignB $ [ i, a, g, m ])+ # centerXY++main = defaultMain (pad 1.1 logo)
+ example/Star.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE NoMonomorphismRestriction, TupleSections #-}++import Diagrams.Prelude+import Diagrams.Backend.Cairo.CmdLine++axes n = h <> v+ where p = fromOffsets . replicate n+ h = stroke' with {vertexNames = [map ("x",) [0..n]]} (p unitX)+ v = stroke' with {vertexNames = [map ("y",) [0..n]]} (p unitY)++connect n i = withAName ("x",i) $ \x ->+ withAName ("y", n - i) $ \y ->+ drawConnect [x,y]+ where drawConnect = atop . fromVertices++pic n = applyAll (map (connect n) [0..n]) (axes n) # centerXY # lw 0.05++d n = half === rotateBy (1/2) half+ where half = rotateBy (1/4) (pic n) ||| pic n++main = defaultMain (pad 1.1 $ d 20 # lc blue)
example/golden.hs view
@@ -8,7 +8,7 @@ sq :: D sq = (lw 1 . stroke $ arc (pi / 2 :: Rad) (pi :: Rad))- `atop` (translate (-0.5, 0.5) . lw 0.5 $ square)+ `atop` (translate (-0.5, 0.5) . lw 0.5 $ unitSquare) phi :: Double phi = (1 + sqrt 5) / 2
example/paradox.hs view
@@ -7,17 +7,15 @@ thick = 0.15 grid x y = frame <> lattice- where s = square # lw 0.02 # freeze- frame = square- # scaleX (fromIntegral x)- # scaleY (fromIntegral y)+ where s = unitSquare # lw 0.02 # freeze+ frame = rect (fromIntegral x) (fromIntegral y) # lw thick # freeze lattice = centerXY . vcat . map hcat . replicate y . replicate x $ s -trap s1 s2 = lw 0 . strokeT . close- $ fromOffsets [(0,-s2), (s2,0), (0,s1)]-tri s1 s2 = lw 0 . strokeT . close- $ fromOffsets [(s1,0), (0,s1+s2)]+trap s1 s2 = fromOffsets [(0,-s2), (s2,0), (0,s1)]+ # close # stroke # lw 0+tri s1 s2 = fromOffsets [(s1,0), (0,s1+s2)]+ # close # stroke # lw 0 paradox n drawDiags = sq ||| strutX s2 ||| rect where f1 = fibs !! n@@ -35,9 +33,9 @@ sq = (if drawDiags then sqDiags else mempty) <> grid (f1+f2) (f1+f2) <> sqShapes- sqDiags = (fromVertices [P (0,s2), P (s2,s1)] <>- fromVertices [P (s2,0), P (s2,s1+s2)] <>- fromVertices [P (s2,0), P (s1+s2,s1+s2)])+ sqDiags = (P (0,s2) ~~ P (s2,s1) <>+ P (s2,0) ~~ P (s2,s1+s2) <>+ P (s2,0) ~~ P (s1+s2,s1+s2)) # stroke # lw thick # freeze@@ -60,9 +58,9 @@ bot = trap1 # alignB ||| rotateBy (-1/4) tri1 # alignB top = rotateBy (1/4) tri2 # alignT ||| trap2 # alignT - rDiags = (fromVertices [P (0,s2), P (2*s2+s1, 0)] <>- fromVertices [P (s2,0), P (s2,s1)] <>- fromVertices [P (s1+s2,s2-s1), P (s1+s2,s2)]+ rDiags = (P (0,s2) ~~ P (2*s2+s1, 0) <>+ P (s2,0) ~~ P (s2,s1) <>+ P (s1+s2,s2-s1) ~~ P (s1+s2,s2) ) # stroke # lw thick
example/tic-tac-toe/Maps.hs view
@@ -18,15 +18,14 @@ type D = Diagram Cairo R2 x, o :: D-x = (stroke $ fromVertices [P (-1,1), P (1,-1)] <> fromVertices [P (1,1), P (-1,-1)])+x = (P (-1,1) ~~ P (1,-1) <> P (1,1) ~~ P (-1,-1)) # lw 0.05 # lineCap LineCapRound # scale 0.4 # freeze # centerXY-o = circle+o = circle 0.4 # lw 0.05- # scale 0.4 # freeze -- | Render a list of lists of diagrams in a grid.@@ -45,7 +44,7 @@ $ [ (r,c) | r <- [0..2], c <- [0..2] ]) `atop`- square # lw 0.02 # scale 3 # freeze+ square 3 # lw 0.02 # freeze -- | Given a solved game tree, where the first move is being made by -- the player for whom the tree is solved, render a map of optimal play.@@ -82,10 +81,10 @@ renderResult :: Result -> D renderResult (Win _ 0 ls) = winLine # freeze where winLine :: D- winLine = stroke (fromVertices (map (P . conv) ls))- # lw 0.2- # lc blue- # lineCap LineCapRound+ winLine = fromVertices (map (P . conv) ls)+ # lw 0.2+ # lc blue+ # lineCap LineCapRound conv (r,c) = (fromIntegral $ c - 1, fromIntegral $ 1 - r) renderResult _ = mempty
example/triangular-numbers.hs view
@@ -19,7 +19,7 @@ edge = fromOffsets . replicate (n-1) $ unitX # scale 3 edges = close (edge <> rotateBy (1/3) edge <> rotateBy (2/3) edge) -dot c = circle+dot c = unitCircle # lw 0 # fc c @@ -73,8 +73,6 @@ law4Dia = exampleRow law4' [2..4] where law4' k = law4 k 3 purple gold---- showOrigin = ((circle # fc red) `atop`) main = defaultMain (pad 1.05 $ vcat' with {sep=5} . map centerXY $ [law1Dia -- , law2Dia, law3Dia, law4Dia
src/Diagrams/Backend/Cairo.hs view
@@ -29,13 +29,18 @@ import Diagrams.Prelude import Diagrams.TwoD.Ellipse+import Diagrams.TwoD.Path (Clip(..))+import Diagrams.TwoD.Text+import Diagrams.TwoD.Image+import Diagrams.TwoD.Adjust (adjustDia2D, adjustSize) import qualified Graphics.Rendering.Cairo as C import qualified Graphics.Rendering.Cairo.Matrix as CM import Control.Applicative ((<$>))-import Control.Monad (when)-import Data.Maybe (catMaybes)+import Control.Monad.State+import Data.Maybe (catMaybes, fromMaybe)+import Data.List (isSuffixOf) import Data.Monoid import qualified Data.Foldable as F@@ -64,8 +69,22 @@ mempty = C $ return () (C r1) `mappend` (C r2) = C (r1 >> r2) +type RenderM a = StateT () C.Render a -- no state for now++-- simple, stupid implementations of save and restore for now, since+-- it suffices to just reset the text alignment to "centered" on+-- restore. But if need be we can switch to a more sophisticated+-- implementation using an "undoable state" monad which lets you save+-- (push state onto a stack) and restore (pop from the stack).++save :: RenderM ()+save = lift C.save++restore :: RenderM ()+restore = lift C.restore+ instance Backend Cairo R2 where- data Render Cairo R2 = C (C.Render ())+ data Render Cairo R2 = C (RenderM ()) type Result Cairo R2 = (IO (), C.Render ()) data Options Cairo R2 = CairoOptions { fileName :: String -- ^ the name of the file you want generated@@ -73,17 +92,19 @@ } withStyle _ s t (C r) = C $ do- C.save- doClip s+ save+ cairoMiscStyle s r- cairoTransf t- cairoStyle s- C.stroke- C.restore+ lift $ do+ cairoTransf t+ cairoStrokeStyle s+ C.stroke+ restore - doRender _ options (C r) = (renderIO, r)- where renderIO = do- let surfaceF s = C.renderWith s r+ doRender _ options (C r) = (renderIO, r')+ where r' = evalStateT r ()+ renderIO = do+ let surfaceF s = C.renderWith s r' file = fileName options case outputFormat options of PNG (w,h) ->@@ -94,65 +115,73 @@ PDF (w,h) -> C.withPDFSurface file w h surfaceF SVG (w,h) -> C.withSVGSurface file w h surfaceF - -- Set the line width to 0.01 and line color to black (in case they- -- were not set), freeze the diagram in its final form, and then do- -- final adjustments to make it fit the requested size.- adjustDia _ opts d = d' # lw 0.01 # lc black # freeze- # scale s- # translate tr- where d' = reflectY d -- adjust for cairo's upside-down coordinate system- (w,h) = getSize $ outputFormat opts- (wd,hd) = size2D d'- xscale = w / wd- yscale = h / hd- s = let s' = min xscale yscale- in if isInfinite s' then 1 else s'- tr = (0.5 *. P (w,h)) .-. (s *. center2D d')-- getSize (PNG (pw,ph)) = (fromIntegral pw, fromIntegral ph)+ adjustDia c opts d = adjustDia2D (getSize . outputFormat) c opts (d # reflectY)+ where getSize (PNG (pw,ph)) = (fromIntegral pw, fromIntegral ph) getSize (PS sz) = sz getSize (PDF sz) = sz getSize (SVG sz) = sz -renderC :: (Renderable a Cairo, V a ~ R2) => a -> C.Render ()+renderC :: (Renderable a Cairo, V a ~ R2) => a -> RenderM () renderC a = case (render Cairo a) of C r -> r -doClip :: Style v -> C.Render ()-doClip s = case getAttr s of- Just (Clip ps) -> mapM_ (\p -> renderC p >> C.clip) ps- Nothing -> return ()+cairoMiscStyle :: Style v -> RenderM ()+cairoMiscStyle s =+ sequence_+ . catMaybes $ [ handle clip+ , handle fSize+ , handleFontFace+ , handle fColor+ ]+ where handle :: AttributeClass a => (a -> RenderM ()) -> Maybe (RenderM ())+ handle f = f `fmap` getAttr s+ clip = mapM_ (\p -> renderC p >> lift C.clip) . getClip+ fSize = lift . C.setFontSize . getFontSize+ fFace = fromMaybe "" $ getFont <$> getAttr s+ fSlant = fromFontSlant . fromMaybe FontSlantNormal+ $ getFontSlant <$> getAttr s+ fWeight = fromFontWeight . fromMaybe FontWeightNormal+ $ getFontWeight <$> getAttr s+ handleFontFace = Just . lift $ C.selectFontFace fFace fSlant fWeight+ fColor c = lift $ setSource (getFillColor c) s -cairoStyle :: Style v -> C.Render ()-cairoStyle s = sequence_- . catMaybes $ [ handle fColor- , handle lColor -- see Note [color order]- , handle lWidth- , handle lCap- , handle lJoin- , handle lDashing- ]+fromFontSlant :: FontSlant -> C.FontSlant+fromFontSlant FontSlantNormal = C.FontSlantNormal+fromFontSlant FontSlantItalic = C.FontSlantItalic+fromFontSlant FontSlantOblique = C.FontSlantOblique++fromFontWeight :: FontWeight -> C.FontWeight+fromFontWeight FontWeightNormal = C.FontWeightNormal+fromFontWeight FontWeightBold = C.FontWeightBold++cairoStrokeStyle :: Style v -> C.Render ()+cairoStrokeStyle s =+ sequence_+ . catMaybes $ [ handle fColor+ , handle lColor -- see Note [color order]+ , handle lWidth+ , handle lCap+ , handle lJoin+ , handle lDashing+ ] where handle :: (AttributeClass a) => (a -> C.Render ()) -> Maybe (C.Render ()) handle f = f `fmap` getAttr s- fColor c = do- let (r,g,b,a) = colorToRGBA . getFillColor $ c- let a' = case getOpacity <$> getAttr s of- Nothing -> a- Just d -> a * d- C.setSourceRGBA r g b a'- C.fillPreserve- lColor c = do- let (r,g,b,a) = colorToRGBA . getLineColor $ c- let a' = case getOpacity <$> getAttr s of- Nothing -> a- Just d -> a * d- C.setSourceRGBA r g b a'+ fColor c = setSource (getFillColor c) s >> C.fillPreserve+ lColor c = setSource (getLineColor c) s lWidth = C.setLineWidth . getLineWidth lCap = C.setLineCap . fromLineCap . getLineCap lJoin = C.setLineJoin . fromLineJoin . getLineJoin lDashing (getDashing -> Dashing ds offs) = C.setDash ds offs -cairoTransf :: Transformation R2 -> C.Render ()+setSource :: Color c => c -> Style v -> C.Render ()+setSource c s = C.setSourceRGBA r g b a'+ where (r,g,b,a) = colorToRGBA c+ a' = case getOpacity <$> getAttr s of+ Nothing -> a+ Just d -> a * d+++cairoTransf :: T2 -> C.Render () cairoTransf t = C.transform m where m = CM.Matrix a1 a2 b1 b2 c1 c2 (a1,a2) = apply t (1,0)@@ -177,7 +206,7 @@ fromLineJoin LineJoinBevel = C.LineJoinBevel instance Renderable Ellipse Cairo where- render _ ell = C $ do+ render _ ell = C . lift $ do let P (xc,yc) = ellipseCenter ell (xs,ys) = ellipseScale ell Rad th = ellipseAngle ell@@ -191,16 +220,74 @@ C.restore instance Renderable (Segment R2) Cairo where- render _ (Linear v) = C $ uncurry C.relLineTo v- render _ (Cubic (x1,y1) (x2,y2) (x3,y3)) = C $ C.relCurveTo x1 y1 x2 y2 x3 y3+ render _ (Linear v) = C . lift $ uncurry C.relLineTo v+ render _ (Cubic (x1,y1) (x2,y2) (x3,y3)) = C . lift $ C.relCurveTo x1 y1 x2 y2 x3 y3 instance Renderable (Trail R2) Cairo where render _ (Trail segs c) = C $ do mapM_ renderC segs- when c C.closePath+ lift $ when c C.closePath instance Renderable (Path R2) Cairo where- render _ (Path trs) = C $ C.newPath >> F.mapM_ renderTrail trs+ render _ (Path trs) = C $ lift C.newPath >> F.mapM_ renderTrail trs where renderTrail (P p, tr) = do- uncurry C.moveTo p+ lift $ uncurry C.moveTo p renderC tr++-- Can only do PNG files at the moment...+instance Renderable Image Cairo where+ render _ (Image file sz tr) = C . lift . when (".png" `isSuffixOf` file) $ do+ C.save+ cairoTransf (tr <> reflectionY)+ pngSurf <- liftIO $ C.imageSurfaceCreateFromPNG file+ w <- C.imageSurfaceGetWidth pngSurf+ h <- C.imageSurfaceGetHeight pngSurf+ let s = (adjustSize sz (fromIntegral w, fromIntegral h))+ cairoTransf s+ C.setSourceSurface pngSurf (-fromIntegral w / 2)+ (-fromIntegral h / 2)+ C.paint+ C.restore++-- see http://www.cairographics.org/tutorial/#L1understandingtext+instance Renderable Text Cairo where+ render _ (Text tr str) = C $ do+ lift $ do+ C.save+ -- XXX should use reflection font matrix here instead?+ cairoTransf (tr <> reflectionY)+ tExt <- C.textExtents str+ let w = C.textExtentsWidth tExt+ h = C.textExtentsHeight tExt+ refX = -w/2 - C.textExtentsXbearing tExt+ refY = -h/2 - C.textExtentsYbearing tExt+ P (newX, newY) = origin+ cairoTransf (moveOriginBy (-newX - refX, newY - refY) mempty)+ C.showText str+ C.restore++{-+-- | A @TextRect@ is a utility object which acts like a rectangle for+-- the purposes of its bounding function and transformations, but+-- also accumulates any transformations performed on it in a+-- separate field. This is useful for learning what transformation+-- we should do to some text in order to align it as requested,+-- since for the purposes of alignment we think of the text as+-- occupying a rectangular region.+data TextRect = TextRect (Bounds R2) T2++mkTextRect :: Double -> Double -> TextRect+mkTextRect w h = TextRect (bounds (rect w h :: Diagram Cairo R2)) mempty++type instance V TextRect = R2++instance Boundable TextRect where+ getBounds (TextRect b _) = b++instance HasOrigin TextRect where+ moveOriginTo p (TextRect b t) = TextRect (moveOriginTo p b)+ (moveOriginTo p t)++instance Transformable TextRect where+ transform t1 (TextRect b t2) = TextRect (transform t1 b) (t1 <> t2)+-}