diagrams-cairo 0.4 → 0.5
raw patch · 25 files changed
+645/−1327 lines, 25 filesdep +filepathdep ~basedep ~cairodep ~cmdargs
Dependencies added: filepath
Dependency ranges changed: base, cairo, cmdargs, diagrams-core, diagrams-lib, gtk, old-time
Files
- CHANGES +52/−17
- LICENSE +3/−1
- README +0/−8
- diagrams-cairo.cabal +21/−9
- example/Apollonius.hs +0/−22
- example/Fractal.hs +0/−33
- example/Fun.hs +0/−25
- example/Hanoi.hs +0/−55
- example/Hasse.hs +0/−54
- example/Hilbert.hs +0/−25
- example/Logo.hs +0/−112
- example/Star.hs +0/−20
- example/cubicSpline.hs +0/−25
- example/golden.hs +0/−31
- example/gray.hs +0/−33
- example/hslogo.hs +0/−116
- example/paradox.hs +0/−73
- example/tic-tac-toe/Maps.hs +0/−98
- example/tic-tac-toe/Solve.hs +0/−143
- example/triangular-numbers.hs +0/−79
- src/Diagrams/Backend/Cairo.hs +25/−318
- src/Diagrams/Backend/Cairo/CmdLine.hs +72/−17
- src/Diagrams/Backend/Cairo/Gtk.hs +23/−13
- src/Diagrams/Backend/Cairo/Internal.hs +296/−0
- src/Diagrams/Backend/Cairo/Text.hs +153/−0
CHANGES view
@@ -1,30 +1,37 @@-0.1: 17 May 2011- * initial preview release+0.5: 9 March 2012 -0.1.1: 18 May 2011- * fix tic-tac-toe example+ * New features -0.1.2: 18 May 2011- * link to new website+ - New Diagrams.Backend.Cairo.Text module by Michael Sloan, with+ functions for creating appropriately sized text objects by+ querying cairo for the size, and related supporting functions. -0.2: 3 June 2011+ - Basic support for animation, by generating frames sampled at+ regular intervals. - * add Typeable and other instances for Cairo type+ - Proper vertical alignment of default text based on font+ parameters (Michael Sloan). - * generalize Result type to (IO (), Render ()), so programs that- don't want to generate a file but just want a Render operation- (e.g. to use to paint a gtk window) can use the second component.+ - Requesting just a width or height now causes the other to be+ computed appropriately. - * add support for opacity attribute and path clipping+ * API changes -0.3: 18 June 2011+ - Move "Diagrams.Backend.Cairo" to+ "Diagrams.Backend.Cairo.Internal" and export everything.+ "Diagrams.Backend.Cairo" now just re-exports selected functions+ from Internal. This allows anyone who wants access to the+ helper/utility functions to import Internal. - * Some new/improved examples+ * Dependency/version changes - * New features:- + simple text support- + simple support for external PNG images+ - relax cmdargs upper bound+ - GHC 7.4.1 compatibility: update base, filepath, old-time upper bounds + * Bug fixes++ - #54: Generate warning for missing image files (Ian Ross).+ 0.4: 22 October 2011 * New features:@@ -37,3 +44,31 @@ * Bug fixes: + Warning for unsupported image types (#41)++0.3: 18 June 2011++ * Some new/improved examples++ * New features:+ + simple text support+ + simple support for external PNG images++0.2: 3 June 2011++ * add Typeable and other instances for Cairo type++ * generalize Result type to (IO (), Render ()), so programs that+ don't want to generate a file but just want a Render operation+ (e.g. to use to paint a gtk window) can use the second component.++ * add support for opacity attribute and path clipping++0.1.2: 18 May 2011+ * link to new website++0.1.1: 18 May 2011+ * fix tic-tac-toe example++0.1: 17 May 2011+ * initial preview release+
LICENSE view
@@ -1,7 +1,9 @@-Copyright 2011 diagrams-cairo team:+Copyright 2011-2012 diagrams-cairo team: Sam Griffin <sam.griffin@gmail.com> John Lato <jwlato@gmail.com>+ Ian Ross <ian@skybluetrades.net>+ Michael Sloan <mgsloan@gmail.com> Luite Stegeman <stegeman@gmail.com> Kanchalai Suveepattananont <ksuvee@seas.upenn.edu> Ryan Yates <fryguybob@gmail.com>
README view
@@ -7,11 +7,3 @@ instructions, tutorials, a user manual, a gallery of example images, and links to the mailing list, IRC channel, developer wiki and bug tracker.--The source repository is mirrored on both patch-tag (darcs) and github-(git):-- http://patch-tag.com/r/byorgey/diagrams-cairo- https://github.com/byorgey/diagrams-cairo--Patches/pull requests welcome in either place.
diagrams-cairo.cabal view
@@ -1,9 +1,15 @@ Name: diagrams-cairo-Version: 0.4+Version: 0.5 Synopsis: Cairo backend for diagrams drawing EDSL Description: A full-featured backend for rendering diagrams using the cairo rendering engine. To get started, see "Diagrams.Backend.Cairo.CmdLine".+ .+ NOTE: the most recent release of gtk2hs does+ not build under GHC 7.4.1. To get diagrams-cairo+ to work under GHC 7.4.1 you'll have to install+ the latest development version of gtk2hs+ (<http://projects.haskell.org/gtk2hs/development/#development>). Homepage: http://projects.haskell.org/diagrams License: BSD3 License-file: LICENSE@@ -13,8 +19,7 @@ Build-type: Simple Cabal-version: >=1.6 Extra-source-files: CHANGES, README-Tested-with: GHC == 6.12.3, GHC >= 7.0.2 && <= 7.0.4, GHC == 7.2.1-Extra-source-files: example/*.hs, example/tic-tac-toe/*.hs+Tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.1 Source-repository head type: darcs location: http://patch-tag.com/r/byorgey/diagrams-cairo@@ -23,22 +28,29 @@ Exposed-modules: Diagrams.Backend.Cairo Diagrams.Backend.Cairo.CmdLine Diagrams.Backend.Cairo.Gtk+ Diagrams.Backend.Cairo.Internal+ Diagrams.Backend.Cairo.Text Hs-source-dirs: src- Build-depends: base >= 4.2 && < 4.5,+ Build-depends: base >= 4.2 && < 4.6, mtl >= 2.0 && < 2.1, process >= 1.0 && < 1.2, directory >= 1.0 && < 1.2,- old-time >= 1.0 && < 1.1,- diagrams-core >= 0.4 && < 0.5,- diagrams-lib >= 0.4 && < 0.5,+ filepath >= 1.1 && < 1.4,+ old-time >= 1.0 && < 1.2,+ diagrams-core >= 0.5 && < 0.6,+ diagrams-lib >= 0.5 && < 0.6, cairo >= 0.10.1 && < 0.13,- cmdargs >= 0.6 && < 0.9,+ cmdargs >= 0.6 && < 0.10, gtk >= 0.12.0 && < 0.13.0, split >= 0.1.2 && < 0.2 if !os(windows) cpp-options: -DCMDLINELOOP Build-depends: unix >= 2.4 && < 2.6 - if impl(ghc >= 7.2.1)+ if impl(ghc >= 7.2.1 && < 7.4) Build-depends: cairo >= 0.12.1, gtk >= 0.12.1++ if impl(ghc >= 7.4.1)+ Build-depends: cairo >= 0.12.3,+ gtk >= 0.12.3
− example/Apollonius.hs
@@ -1,22 +0,0 @@-import Diagrams.Prelude-import Diagrams.Backend.Cairo.CmdLine--import Test.QuickCheck---- Center and signed radius-data Circle = Circle { center :: P2, sRadius :: Double }--descartesR sgn r1 r2 r3 =- (r1 * r2 * r3) /- (r1*r2 + r1*r3 + r2*r3 + sgn * 2 * sqrt(r1*r2*r3*(r1+r2+r3)))--prop_descartes (NonZero r1) (NonZero r2) (NonZero r3) = abs (2*(e1*e1 + e2*e2 + e3*e3 + e4*e4) - (e1+e2+e3+e4)^2) < 1e-10- where [e1,e2,e3,e4] = map (1/) [r1,r2,r3,r4]- r4 = descartesInR r1 r2 r3--descartesOutR = descartesR (-1)-descartesInR = descartesR 1--main = defaultMain (circle (descartesInR 1 1 1) <> circle (descartesOutR 1 1 1) <> circles)--circles = decoratePath (polygon with {sides=3} # scale (2/sqrt 3)) (repeat unitCircle)
− example/Fractal.hs
@@ -1,33 +0,0 @@-import Diagrams.Prelude--import qualified Data.Colour as C-import Diagrams.Backend.Cairo.CmdLine--type D = Diagram Cairo R2--sierpinski :: Int -> D-sierpinski 1 = t-sierpinski n = s- ===- (s ||| s)- where s = sierpinski (n-1)--t = regPoly 3 1- # lw 0- # fc black--colors = iterate (C.blend 0.1 white) blue--pentaflake :: Int -> D-pentaflake 0 = p-pentaflake n = appends (p' # fc (colors !! (n-1)))- (zip vs (repeat (rotateBy (1/2) p')))- where vs = take 5 . iterate (rotateBy (1/5))- . (if odd n then negateV else id) $ unitY- p' = pentaflake (n-1)--pentaflake' n = pentaflake n # fc (colors !! n)--p = regPoly 5 1 # lw 0--main = defaultMain (pad 1.1 $ pentaflake' 4)
− example/Fun.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}--import Diagrams.Prelude-import Diagrams.Backend.Cairo.CmdLine--{--pts = [origin, P (1,0), P (1,1), P (2,1), P (2,2), P (3,2), P (3,3)]--curve = cubicSpline False pts--dot = circle 0.05 # fc black-dots = position (zip pts (repeat dot))--}--circleP = arc (0::Rad) (tau::Rad)--d = stroke $ circleP <> reversePath circleP # scale 0.8--infVertices = map P [ (0,0), (0.3, 0.2), (0.6, 0), (0.3, -0.2)- , (0,0), (-0.3, 0.2), (-0.6, 0), (-0.3, -0.2)- ]--inf = cubicSpline True infVertices # lw 0.05--main = defaultMain ((d # fc grey) <> inf)
− example/Hanoi.hs
@@ -1,55 +0,0 @@-import Diagrams.Prelude--import Diagrams.Backend.Cairo.CmdLine--import Data.List--type D = Diagram Cairo R2--colors = [blue, green, red, yellow, purple]--type Disk = Int-type Stack = [Disk]-type Hanoi = [Stack]-type Move = (Int,Int)--renderDisk :: Disk -> D-renderDisk n = rect (fromIntegral n + 2) 1- # lc black- # fc (colors !! n)- # lw 0.1--renderStack :: Stack -> D-renderStack s = disks `atop` post- where disks = (vcat . map renderDisk $ s)- # alignB- post = rect 0.8 6- # lw 0- # fc saddlebrown- # alignB--renderHanoi :: Hanoi -> D-renderHanoi = hcat' with {catMethod = Distrib, sep = 7} . map renderStack--solveHanoi :: Int -> [Move]-solveHanoi n = solveHanoi' n 0 1 2- where solveHanoi' 0 _ _ _ = []- solveHanoi' n a b c = solveHanoi' (n-1) a c b ++ [(a,c)]- ++ solveHanoi' (n-1) b a c--doMove :: Move -> Hanoi -> Hanoi-doMove (x,y) h = h''- where (d,h') = removeDisk x h- h'' = addDisk y d h'- removeDisk x h = (head (h!!x), modList x tail h)- addDisk y d = modList y (d:)--modList i f l = let (xs,(y:ys)) = splitAt i l in xs ++ (f y : ys)--hanoiSequence :: Int -> [Hanoi]-hanoiSequence n = scanl (flip ($)) [[0..n-1], [], []] (map doMove (solveHanoi n))--renderHanoiSeq :: [Hanoi] -> D-renderHanoiSeq = vcat' with { sep = 2 } . map renderHanoi--main = defaultMain (pad 1.1 $ renderHanoiSeq (hanoiSequence 4) # centerY)
− example/Hasse.hs
@@ -1,54 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}--import Diagrams.Prelude-import Diagrams.Backend.Cairo.CmdLine--import Data.List-import Data.Ord (comparing)-import Data.Function (on)--type D = Diagram Cairo R2--colors = [black, blue, red, yellow, green, orange, purple, brown]--data Subset = Subset Int [Int]--(Subset _ elts1) `isSubset` (Subset _ elts2) = all (`elem` elts2) elts1--subsetsBySize :: Int -> [[Subset]]-subsetsBySize n = map (map (Subset n))- . groupBy ((==) `on` length)- . sortBy (comparing length)- . 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- <> rect (fromIntegral n + 0.5) 1.5- # dashing [0.2,0.2] 0- # lw 0.03- # named elts- )- # freeze--hasseRow = centerX . hcat' with {sep = 2} . map drawSet--hasseDiagram n = setsD # drawConnections- where setsD = vcat' with {sep = fromIntegral n} . map hasseRow . reverse $ subsets- drawConnections = applyAll connections- connections = concat $ zipWith connectSome subsets (tail subsets)- connectSome subs1 subs2 = [ connect s1 s2 | s1 <- subs1- , s2 <- subs2- , s1 `isSubset` s2 ]- connect (Subset _ elts1) (Subset _ elts2) =- withNames [elts1, elts2] $ \[(p1,b1), (p2,b2)] ->- (<> (boundaryFrom p1 unitY b1 ~~ boundaryFrom p2 unit_Y b2) # lw 0.03)- subsets = subsetsBySize n--d1 =|= d2 = d1 === strutY 3 === d2---- main = defaultMain (pad 1.1 $ foldr1 (=|=) (map hasseDiagram [1..4]))-main = defaultMain (pad 1.1 $ hasseDiagram 5)
− example/Hilbert.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}--import Diagrams.Prelude-import Diagrams.Backend.Cairo.CmdLine--hilbert :: [Trail R2]-hilbert = iterate genHilbert mempty- where genHilbert t = let t' = reverseTrail t- in mconcat [ rotateBy (-1/4) t'- , fromOffsets [unitY]- , t- , fromOffsets [unitX]- , t- , fromOffsets [negateV unitY]- , rotateBy (1/4) t'- ]--d = (hilbert !! 6)- # strokeT- # lw 0.2- # fc red- # centerXY- # pad 1.1--main = defaultMain d
− example/Logo.hs
@@ -1,112 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}--import Diagrams.Prelude-import Diagrams.Backend.Cairo.CmdLine-import Diagrams.TwoD.Path--import qualified Data.Colour as C--d = (stroke $- circlePath 2 # alignBR # translateX (-0.5)- <> (hcat' with { sep = 0.2 } . map (vcat' with {sep = 0.2})- $ (replicate 2 (replicate 9 (reversePath $ circlePath 0.3)))) # alignBR)- # fc red- # lw 0--{--dAngle :: Rad-dAngle = tau / 6--dHeight = 5-dWidth = 1--dRad = 1.5--dPath = pathFromTrail . close $- arc dAngle (tau - dAngle) # scale dRad- <> fromOffsets [ (0, -(1 - cos (tau/4 - getRad dAngle)) * dRad)- , (dWidth, 0)- , (0, dHeight)- , (-dWidth, 0)- ]--dotMatrix d path- = mconcat [ if (isInsideWinding p path)- then circle (d / 2 - d/10) # fc red # lw 0 # moveTo p- else mempty- | x <- [ xlo, xlo + d .. xhi ]- , y <- [ ylo, ylo + d .. yhi ]- , let p = P (x,y)- ]- where (xlo, xhi) = extentX path- (ylo, yhi) = extentY path--matrixAng = 1/20--d = dotMatrix 0.09 (dPath # rotateBy matrixAng) # rotateBy (-matrixAng)--}--{--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 { polyType = PolyRegular 3 1 }-sierpinski n = s === (s ||| s)- where s = sierpinski (n-1)--a1 = 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--gbkg = grid- # lc gray- # rotateBy (-1/20)- # clipBy p- # withBounds (p :: Path R2)- where p = square 5--g = (text "G" # fontSize 4 # rotateBy (-1/20)) <> gbkg--r = text "r" # fontSize 5- <> square 1 # lw 0 # scale 5--a2 = text "a" # fontSize 5- <> square 1 # lw 0 # scale 5--m = square 5.5 <>- text "m"- # fontSize 6 # italic # font "freeserif" # fc green--vs = [(5,5), (3,6), (1,5), (1,4), (3,3), (5,2), (4,0), (0,0.5)]-s = (mconcat (map (\v -> translate v (dot blue)) vs) <>- cubicSpline False (map P vs) # lw 0.20)- # scale 0.8--dot c = circle 0.4 # fc c # lw 0--logo = (hcat' with {sep = 0.5} . map alignB $ [ d, i, a1, g, r, a2, m, s ])- # centerXY--main = defaultMain (pad 1.1 logo)
− example/Star.hs
@@ -1,20 +0,0 @@-{-# 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 = withNames [("x",i), ("y", n - i)] $ \[(x,_), (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/cubicSpline.hs
@@ -1,25 +0,0 @@-import Diagrams.Prelude-import Diagrams.Backend.Cairo.CmdLine--import Diagrams.CubicSpline.Internal--import Control.Newtype---poly cs t = foldr mul 0 cs- where mul a b = a + b * t---- Interpolate directly on the spline coefficents-interpolate closed vs = concatMap (\c -> map (poly c) (map fromRational [0.0,0.01..1.0])) cs- where- cs = solveCubicSplineCoefficients closed vs---main = defaultMain (pad 1.1 (mconcat [a,b,c]))- where - vs = map P [(0,10),(2,2),(3.5,8),(4.5,6)]- closed = True- - a = (lc blue . lw 0.05 . stroke . fromVertices) (overF P (interpolate closed) vs)- b = (lc red . lw 0.07 . stroke) (cubicSpline closed vs)- c = (lc green . lw 0.1 . stroke . fromVertices) vs
− example/golden.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-import Diagrams.Prelude-import Diagrams.Backend.Cairo.CmdLine--import Data.VectorSpace--type D = Diagram Cairo R2--sq :: D-sq = (lw 1 . stroke $ arc (pi / 2 :: Rad) (pi :: Rad))- `atop` (translate (-0.5, 0.5) . lw 0.5 $ unitSquare)--phi :: Double-phi = (1 + sqrt 5) / 2--step :: D -> D -> D-step a b = besideAlign (-1,0) (0,1) a b'- where b' = rotate (-pi/2 :: Rad) . scale (1/phi) $ b--besideAlign :: R2 -> R2 -> D -> D -> D-besideAlign u v a b = beside u b' a- where b' = translate (v ^* d) b- (Bounds bb) = bounds b- (Bounds ba) = bounds a- d = (ba v - bb v)--golden :: D-golden = pad 1.05 . freeze . scale 100 $ foldr1 step (replicate 10 sq)--main :: IO ()-main = defaultMain golden
− example/gray.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}--import Diagrams.Prelude hiding (gray)-import Diagrams.Backend.Cairo.CmdLine--import Data.List.Split (chunk)-import Data.Maybe (catMaybes)-import Control.Applicative-import Data.Monoid (mconcat)-import Data.List (transpose)--type D = Diagram Cairo R2--gray 0 = [[]]-gray n = map (False:) g ++ map (True:) (reverse g)- where g = gray (n-1)--rings n = mkRingsDia . map ringOffsets . transpose . gray $ n- where ringOffsets :: [Bool] -> [(CircleFrac, CircleFrac)]- ringOffsets = map l2t . chunk 2 . findEdges . zip [0,1/(2^n)..1]- l2t [x,y] = (x,y)- l2t [x] = (x,2*pi)--findEdges :: Eq a => [(CircleFrac, a)] -> [CircleFrac]-findEdges = catMaybes . (zipWith edge <*> tail)- where edge (_,c1) (a,c2) | c1 /= c2 = Just a- | otherwise = Nothing--mkRingsDia :: [[(CircleFrac, CircleFrac)]] -> D-mkRingsDia = freeze . mconcat . zipWith mkRingDia [2,3..]- where mkRingDia r = lw 1.05 . mconcat . map (stroke . scale r . uncurry arc)--main = defaultMain $ pad 1.1 (rings 10)
− example/hslogo.hs
@@ -1,116 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{- Haskell logo in Diagrams by Ryan Yates.- Based on Metapost version Brian Sniffen.- This was based on a public domain PNG by Jeff Wheeler,- and on logo contest entries by George Pollard, Darrin Thompson, and others.-- (c) 2009 Brian Sniffen, 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 his contributors- may be used to endorse or promote products derived from this software- without specific prior written permission.-- THIS SOFTWARE IS PROVIDED BY THE 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 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. -}--import Diagrams.Prelude hiding (intersection)--import Diagrams.Backend.Cairo-import Diagrams.Backend.Cairo.CmdLine--import Data.VectorSpace-import Data.Colour.SRGB--type D = Diagram Cairo R2--mkPath :: [R2] -> D-mkPath = stroke . close . fromVertices . map P--rangle, lambdabody, lambdaleg, lambda :: Double -> Double -> D--rangle h m = mkPath- [ zeroV, (4*h,4*m*h), (0,8*m*h)- , (3*h,8*m*h), (7*h,4*m*h), (3*h,0)- ]-lambdabody h m = translate (4*h,0) (rangle h m)-lambdaleg h m = translate (4*h,0) path- where path = mkPath [(11*h,0), (8*h,0), (0,8*m*h), (3*h,8*m*h)]--lambda h m = mkPath- [ (4*h,0), (8*h,4*m*h), (4*h,8*m*h), (7*h,8*m*h)- , (15*h,0), (12*h,0), (9.5*h,2.5*m*h), (7*h,0)- ]---- The equal sign is 5 units high: two units thick in each block,--- with one unit thickness of white between. Being centered, that--- puts its outer corners at 3.5, 5.5, 6.5, and 8.5. The right edge--- is at 17 units. The left edge is the standard 1-unit horizontal--- gap from the lambda.--- These gaps are all by horizontal measure---the components are--- closer than 1 unit to each other.-equalsign :: Double -> Double -> Double -> Double -> D-equalsign h m maxx miny = mkPath q- where- maxy = miny + 4/3;- cutoff = ((16*h,0*h), (8*h,8*m*h))- p1 = ((maxx*h,miny*m*h), (0*h,miny*m*h)) `intersection` cutoff;- p2 = ((maxx*h,maxy*m*h), (0*h,maxy*m*h)) `intersection` cutoff;- q = [p1, p2, (maxx*h,maxy*m*h), (maxx*h,miny*m*h)]--stdrangle, stdlambda, stdlambdabody, stdlambdaleg, lowerequal, upperequal :: D--stdrangle = rangle 1 (3/2)-stdlambda = lambda 1 (3/2)-stdlambdabody = lambdabody 1 (3/2)-stdlambdaleg = lambdaleg 1 (3/2)-lowerequal = equalsign 1 (3/2) 17 (7/3)-upperequal = equalsign 1 (3/2) 17 (13/3)--logo :: D-logo = light stdrangle- `atop` lighter stdlambda- `atop` light lowerequal- `atop` light upperequal- where light = fc (sRGB 0.4 0.4 0.4)- lighter = fc (sRGB 0.6 0.6 0.6)--main :: IO ()-main = defaultMain logo---- If we take the given vectors and put them in R^3 as (x,y,0),--- we are resulting in the z component of their cross product.-cross3Z :: (Num t) => (t, t) -> (t, t) -> t-cross3Z (x0,y0) (x1,y1) = x0 * y1 - x1 * y0---- This is just a one off version. A more robust version would--- included data indicating if the lines were parallel or colinear--- among other things.-intersection :: (t ~ Scalar t, Fractional t, VectorSpace t) =>- ((t, t), (t, t)) -> ((t, t), (t, t)) -> (t, t)-intersection (a0,a1) (b0,b1) = a0 ^+^ (va ^* t)- where vb = b1 ^-^ b0- va = a1 ^-^ a0- v = a0 ^-^ b0- d = cross3Z va vb- n = cross3Z vb v- t = n / d
− example/paradox.hs
@@ -1,73 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-import Diagrams.Prelude-import Diagrams.Backend.Cairo.CmdLine--fibs = 0 : 1 : zipWith (+) fibs (tail fibs)--thick = 0.15--grid x y = frame <> lattice- 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 = 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- f2 = fibs !! (n+1)- s1 = fromIntegral f1- s2 = fromIntegral f2-- trap1 = trap s1 s2 # fc yellow- trap2 = trap s1 s2 # fc green- # rotateBy (1/2)-- tri1 = tri s1 s2 # fc red- tri2 = tri s1 s2 # fc blue-- sq = (if drawDiags then sqDiags else mempty)- <> grid (f1+f2) (f1+f2)- <> sqShapes- 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- # centerXY-- sqShapes = (traps # centerY ||| tris # centerY)- # centerXY- traps = trap2 # alignL- # translateY (s1 - s2)- <> trap1- tris = tri1 # alignBL- <> tri2 # rotateBy (1/2)- # alignBL-- rect = (if drawDiags then rDiags else mempty)- <> grid (2*f2 + f1) f2- <> rShapes-- rShapes = (bot # alignTL <> top # alignTL) # centerXY- bot = trap1 # alignB ||| rotateBy (-1/4) tri1 # alignB- top = rotateBy (1/4) tri2 # alignT ||| trap2 # alignT-- 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- # lineCap LineCapRound- # freeze- # centerXY--dia = paradox 4 True--main = defaultMain (pad 1.1 dia)
− example/tic-tac-toe/Maps.hs
@@ -1,98 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}---- Maps of optimal tic-tac-toe play, inspired by similar maps created--- by Randall Munroe, http://xkcd.com/832/--import Diagrams.Prelude hiding (Result)-import Diagrams.Backend.Cairo.CmdLine--import Data.List.Split (chunk) -- cabal install split-import Data.Maybe (fromMaybe, catMaybes)-import qualified Data.Map as M-import Data.Tree-import Control.Arrow (second, (&&&), (***))-import Data.Array (assocs)--import Solve--type D = Diagram Cairo R2--x, o :: D-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 0.4- # lw 0.05- # freeze---- | Render a list of lists of diagrams in a grid.-grid :: Double -> [[D]] -> D-grid s = centerXY- . vcat' with {catMethod = Distrib, sep = s}- . map (hcat' with {catMethod = Distrib, sep = s})---- | Given a mapping from (r,c) locations (in a 3x3 grid) to diagrams,--- render them in a grid, surrounded by a square.-renderGrid :: M.Map Loc D -> D-renderGrid g- = (grid 1- . chunk 3- . map (fromMaybe (phantom x) . flip M.lookup g)- $ [ (r,c) | r <- [0..2], c <- [0..2] ])-- `atop`- 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.-renderSolvedP :: Tree (Game, Result) -> D-renderSolvedP (Node (Game _ p _, _) []) -- cats game, this player does not- = renderPlayer (next p) # scale 3 -- get another move; instead of- -- recursively rendering this game- -- just render an X or an O-renderSolvedP (Node (Game board player1 _, _)- [g'@(Node (Game _ _ (Move _ loc : _), res) conts)])- = renderResult res <> -- Draw a line through a win- renderGrid cur <> -- Draw the optimal move + current moves- renderOtherP g' -- Recursively render responses to other moves-- where cur = M.singleton loc (renderPlayer player1 # lc red) -- the optimal move- <> curMoves board -- current moves--renderSolvedP _ = error "renderSolvedP should be called on solved trees only"---- | Given a solved game tree, where the first move is being made by the--- opponent of the player for whom the tree is solved, render a map of optimal--- play.-renderOtherP :: Tree (Game, Result) -> D-renderOtherP (Node _ conts)- -- just recursively render each game arising from an opponent's move in a grid.- = renderGrid . M.fromList . map (getMove &&& (scale (1/3) . renderSolvedP)) $ conts- where getMove (Node (Game _ _ (Move _ m : _), _) _) = m---- | Extract the current moves from a board.-curMoves :: Board -> M.Map Loc D-curMoves = M.fromList . (map . second) renderPlayer . catMaybes . map strength . assocs---- | Render a line through a win.-renderResult :: Result -> D-renderResult (Win _ 0 ls) = winLine # freeze- where winLine :: D- winLine = fromVertices (map (P . conv) ls)- # lw 0.2- # lc blue- # lineCap LineCapRound- conv (r,c) = (fromIntegral $ c - 1, fromIntegral $ 1 - r)-renderResult _ = mempty--renderPlayer X = x-renderPlayer O = o--xMap = renderSolvedP . solveFor X $ gameTree-oMap = renderOtherP . solveFor O $ gameTree--main = defaultMain (pad 1.1 xMap)- -- defaultMain (pad 1.1 oMap)
− example/tic-tac-toe/Solve.hs
@@ -1,143 +0,0 @@-{-# LANGUAGE PatternGuards, ViewPatterns #-}--module Solve where--import Data.Array-import Data.Tree-import Data.Function (on)-import Data.List (groupBy, maximumBy)-import Data.Maybe (isNothing, isJust)-import Data.Monoid-import Control.Applicative (liftA2)-import Control.Arrow ((&&&))-import Control.Monad (guard)--data Player = X | O- deriving (Show, Eq, Ord)--next X = O-next O = X--data Result = Win Player Int [Loc] -- ^ This player can win in n moves- | Cats -- ^ Tie game- deriving (Show, Eq)--compareResultsFor :: Player -> (Result -> Result -> Ordering)-compareResultsFor X = compare `on` resultToScore- where resultToScore (Win X n _) = (1/(1+fromIntegral n))- resultToScore Cats = 0- resultToScore (Win O n _) = (-1/(1+fromIntegral n))-compareResultsFor O = flip (compareResultsFor X)--type Loc = (Int,Int)-type Board = Array Loc (Maybe Player)--emptyBoard :: Board-emptyBoard = listArray ((0,0), (2,2)) (repeat Nothing)--showBoard :: Board -> String-showBoard = unlines . map showRow . groupBy ((==) `on` (fst . fst)) . assocs- where showRow = concatMap (showPiece . snd)- showPiece Nothing = " "- showPiece (Just p) = show p--data Move = Move Player Loc- deriving Show--makeMove :: Move -> Board -> Board-makeMove (Move p l) b = b // [(l, Just p)]--data Game = Game Board -- ^ The current board state.- Player -- ^ Whose turn is it?- [Move] -- ^ The list of moves so far (most- -- recent first).- deriving Show--initialGame = Game emptyBoard X []---- | The full game tree for tic-tac-toe.-gameTree :: Tree Game-gameTree = unfoldTree (id &&& genMoves) initialGame---- | Generate all possible successor games from the given game.-genMoves :: Game -> [Game]-genMoves (Game board player moves) = newGames- where validLocs = map fst . filter (isNothing . snd) . assocs $ board- newGames = [Game (makeMove m board) (next player) (m:moves)- | p <- validLocs- , let m = Move player p- ]---- | Simple fold for Trees. The Data.Tree module does not provide--- this.-foldTree :: (a -> [b] -> b) -> Tree a -> b-foldTree f (Node a ts) = f a (map (foldTree f) ts)---- | Solve the game for player @p@: prune all but the optimal moves--- for player @p@, and annotate each game with its result (given--- best play).-solveFor :: Player -> Tree Game -> Tree (Game, Result)-solveFor p = foldTree (solveStep p)---- | Given a game and its continuations (including their results),--- solve the game for player p. If it is player p's turn, prune all--- continuations except the optimal one for p. Otherwise, leave all--- continuations. The result of this game is the result of the--- optimal choice if it is p's turn, otherwise the worst possible--- outcome for p.-solveStep :: Player -> Game -> [Tree (Game, Result)] -> Tree (Game, Result)-solveStep p g@(Game brd curPlayer moves) conts- | Just res <- gameOver g = Node (g, res) []-- | curPlayer == p = let c = bestContFor p conts- res = inc . snd . rootLabel $ c- in Node (g, res) [c]- | otherwise = Node (g, bestResultFor (next p) conts) conts--bestContFor :: Player -> [Tree (Game, Result)] -> Tree (Game, Result)-bestContFor p = maximumBy (compareResultsFor p `on` (snd . rootLabel))--bestResultFor :: Player -> [Tree (Game, Result)] -> Result-bestResultFor p = inc . snd . rootLabel . bestContFor p--inc :: Result -> Result-inc (Win p n ls) = Win p (n+1) ls-inc Cats = Cats---- | Check whether the game is over, returning the result if it is.-gameOver :: Game -> Maybe Result-gameOver (Game board _ _)- = getFirst $ mconcat (map (checkWin board) threes) `mappend` checkCats board--checkWin :: Board -> [Loc] -> First Result-checkWin board = First- . (>>= winAsResult) -- Maybe Result- . mapM strength -- Maybe [(Loc, Player)]- . map (id &&& (board!)) -- [(Loc, Maybe Player)]--winAsResult :: [(Loc, Player)] -> Maybe Result-winAsResult (unzip -> (ls,ps))- | Just p <- allEqual ps = Just (Win p 0 ls)-winAsResult _ = Nothing--checkCats :: Board -> First Result-checkCats b | all isJust (elems b) = First (Just Cats)- | otherwise = First Nothing--allEqual :: Eq a => [a] -> Maybe a-allEqual = foldr1 combine . map Just- where combine (Just x) (Just y) | x == y = Just x- | otherwise = Nothing- combine Nothing _ = Nothing- combine _ Nothing = Nothing--strength :: Functor f => (a, f b) -> f (a,b)-strength (a, f) = fmap ((,) a) f--threes :: [[Loc]]-threes = rows ++ cols ++ diags- where rows = [ [ (r,c) | c <- [0..2] ] | r <- [0..2] ]- cols = [ [ (r,c) | r <- [0..2] ] | c <- [0..2] ]- diags = [ [ (i,i) | i <- [0..2] ]- , [ (i,2-i) | i <- [0..2] ]- ]
− example/triangular-numbers.hs
@@ -1,79 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}---- Diagrams created for blog post at--- http://mathlesstraveled.com/2011/04/14/triangular-number-equations-via-pictures-solutions/--import Diagrams.Prelude-import Diagrams.Backend.Cairo.CmdLine--import Data.Colour hiding (atop)--type D = Diagram Cairo R2--tri c n = dots `atop` (strokeT edges # lc c # lw 0.2 # fcA (c `withOpacity` 0.5))- where rows = map (hcat' with { sep = 1 })- . zipWith replicate [n,n-1..1]- . repeat- $ dot c- dots = decorateTrail (rotateBy (1/6) edge) rows- edge = fromOffsets . replicate (n-1) $ unitX # scale 3- edges = close (edge <> rotateBy (1/3) edge <> rotateBy (2/3) edge)--dot c = unitCircle- # lw 0- # fc c--rowSpc = height (rotateBy (1/6) $ strutY 1 :: D)---- @row k n s c@ draws a row of k size-n triangles with color c,--- separated by enough space for @s@ dots.-row k n s c = hcat' with {sep = 1 + 3*s} (replicate k (tri c n))---- 3 T(n) + T(n-1) = T(2n)-law1 n c1 c2 = law3 1 n c1 c2---- 3T(n) + T(n+1) = T(2n+1)-law2 n c1 c2 = top === strutY rowSpc === (base `atop` mid)- where base = row 2 n 1 c1- # centerX- # alignB- mid = row 1 n 0 c1- # reflectY- # centerX- # alignB- top = tri c2 (n+1)- # centerX---- (2k+1)T(n) + T(kn - 1) = T((k+1)n)-law3 k n c1 c2 = top === strutY rowSpc === (mid `atop` base)- where base = row (k+1) n 0 c1 # centerX- # alignB- mid = row k n 0 c1 # reflectY- # centerX- # alignB- # translateY (2 + rowSpc)- top = tri c2 (k*n - 1) # centerX---- T(n) T(k) + T(n-1) T(k-1) = T(nk)-law4 k n c1 c2 = vcat' with {sep = rowSpc} (map tRow [1..k])- where tRow k = (row k n 0 c1 # centerX # alignT)- `atop`- (row (k-1) (n-1) 1 c2 # reflectY # centerX # alignT)--exampleRow f = hcat' with {sep = 4} . map (alignB . f)--law1Dia = exampleRow law1' [2..4]- where law1' n = law1 n blue red--law2Dia = exampleRow law2' [1..3]- where law2' n = law2 n green orange--law3Dia = exampleRow law3' [1..3]- where law3' k = law3 k 2 saddlebrown gray--law4Dia = exampleRow law4' [2..4]- where law4' k = law4 k 3 purple gold--main = defaultMain (pad 1.05 $ vcat' with {sep=5} . map centerXY $- [law1Dia -- , law2Dia, law3Dia, law4Dia- ])
src/Diagrams/Backend/Cairo.hs view
@@ -1,16 +1,8 @@-{-# LANGUAGE TypeFamilies- , MultiParamTypeClasses- , FlexibleInstances- , FlexibleContexts- , ExistentialQuantification- , TypeSynonymInstances- , DeriveDataTypeable- , ViewPatterns- #-}+{-# LANGUAGE TypeFamilies, CPP #-} ----------------------------------------------------------------------------- -- |--- Module : Diagrams.Backend.Cairo.CmdLine+-- Module : Diagrams.Backend.Cairo -- Copyright : (c) 2011 Diagrams-cairo team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com@@ -22,90 +14,29 @@ module Diagrams.Backend.Cairo ( -- * Cairo-supported output formats- OutputFormat(..)+ OutputType(..) -- * Cairo-specific options -- $CairoOptions++-- The below CPP hack is needed because GHC 7.0.x has a bug regarding+-- (re?)export of data family constructors; in particular the below+-- export causes the error "Not in scope: type constructor or class+-- `Options'" even though+-- http://www.haskell.org/haskellwiki/GHC/Type_families#Import_and_export+-- seems to indicate it should be supported. When using 7.0.x one+-- must import Diagrams.Backend.Cairo.Internal in order to bring+-- CairoOptions into scope.+-- GHC 7.4.0 regression?+#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 704 , Options(..)+#endif -- * Backend token , Cairo(..) ) where -import Graphics.Rendering.Diagrams.Transform--import Diagrams.Prelude-import Diagrams.TwoD.Ellipse-import Diagrams.TwoD.Path (Clip(..), getFillRule)-import Diagrams.TwoD.Text-import Diagrams.TwoD.Image-import Diagrams.TwoD.Adjust (adjustDia2D, adjustSize)--import Graphics.UI.Gtk (DrawableClass)-import qualified Graphics.UI.Gtk.Cairo as CG--import qualified Graphics.Rendering.Cairo as C-import qualified Graphics.Rendering.Cairo.Matrix as CM--import Control.Applicative ((<$>))-import Control.Monad.State-import Data.Maybe (catMaybes, fromMaybe)-import Data.List (isSuffixOf)--import qualified Data.Foldable as F--import Data.Typeable---- | This data declaration is simply used as a token to distinguish--- this rendering engine.-data Cairo = Cairo- deriving (Eq,Ord,Read,Show,Typeable)---- | Cairo is able to output to several file formats, which each have--- their own associated properties that affect the output.-data OutputFormat =- -- | Output directly to a Gtk window. See "Diagrams.Backends.Cairo.Gtk".- forall dw. (DrawableClass dw) =>- GTK { gtkWindow :: dw- -- ^ The window on which to draw.-- , gtkSize :: Maybe (Int, Int)- -- ^ The size of the output is given in pixels. If @Nothing@,- -- rescaling should not be performed.-- , gtkBypass :: Bool- -- ^ Should the 'adjustDia' step be bypassed during rendering?- }- -- | PNG is unique, in that it is not a vector format.- | PNG { pngSize :: (Int, Int) -- ^ the size of the output is given in pixels- }- -- | PostScript output.- | PS { psSize :: (Double, Double) -- ^ the size of the output is given in points- }- -- | Portable Document Format (PDF) output.- | PDF { pdfSize :: (Double, Double) -- ^ the size of the output is given in points- }- -- | Scalable Vector Graphics (SVG) output.- | SVG { svgSize :: (Double, Double) -- ^ the size of the output is given in points- }--instance Monoid (Render Cairo R2) where- 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+import Diagrams.Backend.Cairo.Internal -- $CairoOptions --@@ -114,240 +45,16 @@ -- This module defines -- -- > data family Options Cairo R2 = CairoOptions--- > { fileName :: String -- ^ the name of the file you want generated--- > , outputFormat :: OutputFormat -- ^ the output format and associated options--- > }+-- > { cairoFileName :: String -- ^ The name of the file you want generated+-- > , cairoSizeSpec :: SizeSpec2D -- ^ The requested size of the output+-- > , cairoOutputType :: OutputType -- ^ the output format and associated options+-- > } -- -- So, for example, you could call the 'renderDia' function (from -- "Graphics.Rendering.Diagrams.Core") like this: ----- > renderDia Cairo (CairoOptions "foo.png" (PNG (100,100))) myDiagram--instance Backend Cairo R2 where- 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- , outputFormat :: OutputFormat -- ^ the output format and associated options- }-- withStyle _ s t (C r) = C $ do- save- cairoMiscStyle s- r- lift $ do- cairoTransf t- cairoStrokeStyle s- C.stroke- restore-- 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- GTK win _ _ -> CG.renderWithDrawable win r'- PNG (w,h) ->- C.withImageSurface C.FormatARGB32 w h $ \surface -> do- surfaceF surface- C.surfaceWriteToPNG surface file- PS (w,h) -> C.withPSSurface file w h surfaceF- PDF (w,h) -> C.withPDFSurface file w h surfaceF- SVG (w,h) -> C.withSVGSurface file w h surfaceF-- adjustDia c opts d = if bypass (outputFormat opts)- then d- else adjustDia2D (getSize . outputFormat) c opts (d # reflectY)- where getSize (GTK _ (Just (pw,ph)) _) = (fromIntegral pw, fromIntegral ph)- getSize (GTK _ Nothing _) = size2D d- getSize (PNG (pw,ph)) = (fromIntegral pw, fromIntegral ph)- getSize (PS sz) = sz- getSize (PDF sz) = sz- getSize (SVG sz) = sz- bypass (GTK _ _ x) = x- bypass _ = False--renderC :: (Renderable a Cairo, V a ~ R2) => a -> RenderM ()-renderC a = case (render Cairo a) of C r -> r--cairoMiscStyle :: Style v -> RenderM ()-cairoMiscStyle s =- sequence_- . catMaybes $ [ handle clip- , handle fSize- , handleFontFace- , handle fColor- , handle lFillRule- ]- 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- lFillRule = lift . C.setFillRule . fromFillRule . getFillRule--fromFontSlant :: FontSlant -> C.FontSlant-fromFontSlant FontSlantNormal = C.FontSlantNormal-fromFontSlant FontSlantItalic = C.FontSlantItalic-fromFontSlant FontSlantOblique = C.FontSlantOblique--fromFontWeight :: FontWeight -> C.FontWeight-fromFontWeight FontWeightNormal = C.FontWeightNormal-fromFontWeight FontWeightBold = C.FontWeightBold--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 = 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--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)- (b1,b2) = apply t (0,1)- (c1,c2) = transl t--{- ~~~~ Note [color order]-- It's important for the line and fill colors to be handled in the- given order (fill color first, then line color) because of the way- Cairo handles them (both are taken from the sourceRGBA).--}--fromLineCap :: LineCap -> C.LineCap-fromLineCap LineCapButt = C.LineCapButt-fromLineCap LineCapRound = C.LineCapRound-fromLineCap LineCapSquare = C.LineCapSquare--fromLineJoin :: LineJoin -> C.LineJoin-fromLineJoin LineJoinMiter = C.LineJoinMiter-fromLineJoin LineJoinRound = C.LineJoinRound-fromLineJoin LineJoinBevel = C.LineJoinBevel--fromFillRule :: FillRule -> C.FillRule-fromFillRule Winding = C.FillRuleWinding-fromFillRule EvenOdd = C.FillRuleEvenOdd--instance Renderable Ellipse Cairo where- render _ ell = C . lift $ do- let P (xc,yc) = ellipseCenter ell- (xs,ys) = ellipseScale ell- Rad th = ellipseAngle ell- C.newPath- C.save- C.translate xc yc- C.rotate th- C.scale xs ys- C.arc 0 0 1 0 tau- C.closePath- C.restore--instance Renderable (Segment R2) Cairo where- 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- lift $ when c C.closePath--instance Renderable (Path R2) Cairo where- render _ (Path trs) = C $ lift C.newPath >> F.mapM_ renderTrail trs- where renderTrail (P p, tr) = do- 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 $ do- if ".png" `isSuffixOf` file- then do- C.save- cairoTransf (tr <> reflectionY)- pngSurf <- liftIO $ C.imageSurfaceCreateFromPNG file- w <- C.imageSurfaceGetWidth pngSurf- h <- C.imageSurfaceGetHeight pngSurf- cairoTransf $ adjustSize sz (fromIntegral w, fromIntegral h)- C.setSourceSurface pngSurf (-fromIntegral w / 2)- (-fromIntegral h / 2)- C.paint- C.restore- else- liftIO . putStr . unlines $- [ "Warning: Cairo backend can currently only render embedded"- , " images in .png format. Ignoring <" ++ file ++ ">."- ]---- 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)--}+-- > renderDia Cairo (CairoOptions "foo.png" (Width 250) PNG) myDiagram+--+-- /Important note/: a bug in GHC 7.0.x prevents re-exporting this+-- data family. To bring CairoOptions into scope when using GHC 7.0.x+-- you must import "Diagrams.Backend.Cairo.Internal".
src/Diagrams/Backend/Cairo/CmdLine.hs view
@@ -14,24 +14,33 @@ module Diagrams.Backend.Cairo.CmdLine ( defaultMain , multiMain+ , animMain , Cairo ) where -import Diagrams.Prelude hiding (width, height)+import Diagrams.Prelude hiding (width, height, interval) import Diagrams.Backend.Cairo +-- Below hack is needed because GHC 7.0.x has a bug regarding export+-- of data family constructors; see comments in Diagrams.Backend.Cairo+#if __GLASGOW_HASKELL__ < 702 || __GLASGOW_HASKELL__ >= 704+import Diagrams.Backend.Cairo.Internal+#endif+ import System.Console.CmdArgs.Implicit hiding (args) import Prelude hiding (catch) import Data.Maybe (fromMaybe)-import Control.Applicative ((<$>))-import Control.Monad (when)+import Control.Monad (when, forM_) import Data.List.Split +import Text.Printf+ import System.Environment (getArgs, getProgName) import System.Directory (getModificationTime)+import System.FilePath (addExtension, splitExtension) import System.Process (runProcess, waitForProcess) import System.IO (openFile, hClose, IOMode(..), hSetBuffering, BufferMode(..), stdout)@@ -45,10 +54,11 @@ #endif data DiagramOpts = DiagramOpts- { width :: Int- , height :: Int+ { width :: Maybe Int+ , height :: Maybe Int , output :: FilePath , selection :: Maybe String+ , fpu :: Double #ifdef CMDLINELOOP , loop :: Bool , src :: Maybe String@@ -59,13 +69,13 @@ diagramOpts :: String -> Bool -> DiagramOpts diagramOpts prog sel = DiagramOpts- { width = 400+ { width = def &= typ "INT"- &= help "Desired width of the output image (default 400)"+ &= help "Desired width of the output image" - , height = 400- &= typ "INT"- &= help "Desired height of the output image (default 400)"+ , height = def+ &= typ "INT"+ &= help "Desired height of the output image" , output = def &= typFile@@ -74,6 +84,10 @@ , selection = def &= help "Name of the diagram to render" &= (if sel then typ "NAME" else ignore)++ , fpu = 30+ &= typ "FLOAT"+ &= help "Frames per unit time (for animations)" #ifdef CMDLINELOOP , loop = False &= help "Run in a self-recompiling loop"@@ -120,13 +134,24 @@ case splitOn "." (output opts) of [""] -> putStrLn "No output file given." ps | last ps `elem` ["png", "ps", "pdf", "svg"] -> do- let outfmt = case last ps of- "png" -> PNG (width opts, height opts)- "ps" -> PS (fromIntegral $ width opts, fromIntegral $ height opts)- "pdf" -> PDF (fromIntegral $ width opts, fromIntegral $ height opts)- "svg" -> SVG (fromIntegral $ width opts, fromIntegral $ height opts)- _ -> PDF (fromIntegral $ width opts, fromIntegral $ height opts)- fst $ renderDia Cairo (CairoOptions (output opts) outfmt) d+ let outTy = case last ps of+ "png" -> PNG+ "ps" -> PS+ "pdf" -> PDF+ "svg" -> SVG+ _ -> PDF+ sizeSpec = case (width opts, height opts) of+ (Nothing, Nothing) -> Absolute+ (Just w, Nothing) -> Width (fromIntegral w)+ (Nothing, Just h) -> Height (fromIntegral h)+ (Just w, Just h) -> Dims (fromIntegral w)+ (fromIntegral h)+ fst $ renderDia Cairo (CairoOptions+ (output opts)+ sizeSpec+ outTy+ )+ d | otherwise -> putStrLn $ "Unknown file type: " ++ last ps -- | @multiMain@ is like 'defaultMain', except instead of a single@@ -145,6 +170,36 @@ Just sel -> case lookup sel ds of Nothing -> putStrLn $ "Unknown diagram: " ++ sel Just d -> chooseRender opts d++-- | @animMain@ takes an animation and produces a command-line program+-- which will crudely \"render\" the animation by rendering one image+-- for each frame, named by extending the given output file name by+-- consecutive integers. For example if the given output file name+-- is @foo\/blah.png@, the frames will be saved in @foo\/blah001.png@,+-- @foo\/blah002.png@, and so on (the number of padding digits used+-- depends on the total number of frames). It is up to the user to+-- take these images and stitch them together into an actual+-- animation format (using, /e.g./ @ffmpeg@).+--+-- Of course, this is a rather crude method of rendering animations;+-- more sophisticated methods will likely be added in the future.+animMain :: Animation Cairo R2 -> IO ()+animMain anim = do+ prog <- getProgName+ opts <- cmdArgs (diagramOpts prog False)+ let frames = simulate (toRational $ fpu opts) anim+ nDigits = length . show . length $ frames+ forM_ (zip [1..] frames) $ \(i,d) ->+ chooseRender (indexize nDigits i opts) d++-- | @indexize d n@ adds the integer index @n@ to the end of the+-- output file name, padding with zeros if necessary so that it uses+-- at least @d@ digits.+indexize :: Int -> Integer -> DiagramOpts -> DiagramOpts+indexize nDigits i opts = opts { output = output' }+ where fmt = "%0" ++ show nDigits ++ "d"+ output' = addExtension (base ++ printf fmt (i::Integer)) ext+ (base, ext) = splitExtension (output opts) #ifdef CMDLINELOOP waitForChange :: Maybe ClockTime -> DiagramOpts -> String -> [String] -> IO ()
src/Diagrams/Backend/Cairo/Gtk.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Backend.Cairo.Gtk@@ -19,42 +20,51 @@ import Diagrams.Prelude hiding (width, height) import Diagrams.Backend.Cairo +-- Below hack is needed because GHC 7.0.x has a bug regarding export+-- of data family constructors; see comments in Diagrams.Backend.Cairo+#if __GLASGOW_HASKELL__ < 702 || __GLASGOW_HASKELL__ >= 704+import Diagrams.Backend.Cairo.Internal+#endif+ import Graphics.UI.Gtk -- | Convert a Diagram to the backend coordinates.--- +-- -- Provided to Query the diagram with coordinates from a mouse click -- event.--- +-- -- > widget `on` buttonPressEvent $ tryEvent $ do -- > click <- eventClick -- > (x,y) <- eventCoordinates -- > let result = runQuery (query $ toGtkCoords myDiagram) (P (x,y)) -- > do_something_with result--- +-- -- `toGtkCoords` does no rescaling of the diagram, however it is centered in -- the window.-toGtkCoords :: Monoid m => AnnDiagram Cairo R2 m -> AnnDiagram Cairo R2 m-toGtkCoords d =+toGtkCoords :: Monoid' m => QDiagram Cairo R2 m -> QDiagram Cairo R2 m+toGtkCoords d = snd $ adjustDia Cairo- (CairoOptions "" (GTK (undefined :: DrawWindow) Nothing False))+ (CairoOptions "" Absolute (GTK (undefined :: DrawWindow) False)) d -- | Render a diagram to a DrawingArea, rescaling to fit the full area.-defaultRender :: Monoid m => DrawingArea -> AnnDiagram Cairo R2 m -> IO ()+defaultRender :: Monoid' m => DrawingArea -> QDiagram Cairo R2 m -> IO () defaultRender da d = do- sz <- widgetGetSize da+ (w,h) <- widgetGetSize da dw <- widgetGetDrawWindow da- fst $ renderDia Cairo (CairoOptions "" (GTK dw (Just sz) False)) d+ fst $ renderDia Cairo (CairoOptions "" (Dims (fromIntegral w) (fromIntegral h))+ (GTK dw False)+ )+ d -- | Render a diagram to a DrawableClass. No rescaling or transformations -- will be performed.--- +-- -- Typically the diagram will already have been transformed by `toGtkCoords`. renderToGtk ::- (DrawableClass dc, Monoid m)+ (DrawableClass dc, Monoid' m) => dc -- ^ widget to render onto- -> AnnDiagram Cairo R2 m -- ^ Diagram+ -> QDiagram Cairo R2 m -- ^ Diagram -> IO () renderToGtk dc d =- fst $ renderDia Cairo (CairoOptions "" (GTK dc Nothing True)) d+ fst $ renderDia Cairo (CairoOptions "" Absolute (GTK dc True)) d
+ src/Diagrams/Backend/Cairo/Internal.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , FlexibleContexts+ , ExistentialQuantification+ , TypeSynonymInstances+ , DeriveDataTypeable+ , ViewPatterns+ #-}++-----------------------------------------------------------------------------+-- |+-- Module : Diagrams.Backend.Cairo.Internal+-- Copyright : (c) 2011 Diagrams-cairo team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- Implementation of the diagrams Cairo backend. This module exports the+-- internal helper functions, for usage elsewhere.+--+-----------------------------------------------------------------------------+module Diagrams.Backend.Cairo.Internal where++import Graphics.Rendering.Diagrams.Transform++import Diagrams.Prelude+import Diagrams.TwoD.Path (Clip(..), getFillRule)+import Diagrams.TwoD.Text+import Diagrams.TwoD.Image+import Diagrams.TwoD.Adjust (adjustDia2D, adjustSize)++import Graphics.UI.Gtk (DrawableClass)+import qualified Graphics.UI.Gtk.Cairo as CG++import qualified Graphics.Rendering.Cairo as C+import qualified Graphics.Rendering.Cairo.Matrix as CM++import Control.Monad.State+import Data.Maybe (catMaybes, fromMaybe)+import Data.List (isSuffixOf)++import Control.Exception (try)++import qualified Data.Foldable as F++import Data.Typeable++-- | This data declaration is simply used as a token to distinguish+-- this rendering engine.+data Cairo = Cairo+ deriving (Eq,Ord,Read,Show,Typeable)++-- | Output types supported by cairo, including four different file+-- types (PNG, PS, PDF, SVG) as well as Gtk windows.+data OutputType =+ -- | Output directly to a Gtk window. See "Diagrams.Backends.Cairo.Gtk".+ forall dw. (DrawableClass dw) =>+ GTK { gtkWindow :: dw+ -- ^ The window on which to draw.++ , gtkBypass :: Bool+ -- ^ Should the 'adjustDia' step be bypassed during rendering?+ }++ | PNG -- ^ Portable Network Graphics output.+ | PS -- ^ PostScript output+ | PDF -- ^ Portable Document Format output.+ | SVG -- ^ Scalable Vector Graphics output.++instance Monoid (Render Cairo R2) where+ mempty = C $ return ()+ (C rd1) `mappend` (C rd2) = C (rd1 >> rd2)++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 (RenderM ())+ type Result Cairo R2 = (IO (), C.Render ())+ data Options Cairo R2 = CairoOptions+ { cairoFileName :: String -- ^ The name of the file you want generated+ , cairoSizeSpec :: SizeSpec2D -- ^ The requested size of the output+ , cairoOutputType :: OutputType -- ^ the output format and associated options+ }++ withStyle _ s t (C r) = C $ do+ save+ cairoMiscStyle s+ r+ lift $ do+ cairoTransf t+ cairoStrokeStyle s+ C.stroke+ restore++ doRender _ (CairoOptions file size out) (C r) = (renderIO, r')+ where r' = evalStateT r ()+ renderIO = do+ let surfaceF s = C.renderWith s r'++ -- Everything except Dims is arbitrary. The backend+ -- should have first run 'adjustDia' to update the+ -- final size of the diagram with explicit dimensions,+ -- so normally we would only expect to get Dims anyway.+ (w,h) = case size of+ Width w' -> (w',w')+ Height h' -> (h',h')+ Dims w' h' -> (w',h')+ Absolute -> (100,100)++ case out of+ GTK win _ -> CG.renderWithDrawable win r'+ PNG ->+ C.withImageSurface C.FormatARGB32 (round w) (round h) $ \surface -> do+ surfaceF surface+ C.surfaceWriteToPNG surface file+ PS -> C.withPSSurface file w h surfaceF+ PDF -> C.withPDFSurface file w h surfaceF+ SVG -> C.withSVGSurface file w h surfaceF++ adjustDia c opts d = if bypass (cairoOutputType opts)+ then (opts,d)+ else adjustDia2D cairoSizeSpec+ setCairoSizeSpec+ c opts (d # reflectY)+ where setCairoSizeSpec sz o = o { cairoSizeSpec = sz }+ bypass (GTK _ x) = x+ bypass _ = False++renderC :: (Renderable a Cairo, V a ~ R2) => a -> RenderM ()+renderC a = case (render Cairo a) of C r -> r++cairoMiscStyle :: Style v -> RenderM ()+cairoMiscStyle s =+ sequence_+ . catMaybes $ [ handle clip+ , handle fSize+ , handleFontFace+ , handle fColor+ , handle lFillRule+ ]+ 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+ lFillRule = lift . C.setFillRule . fromFillRule . getFillRule++fromFontSlant :: FontSlant -> C.FontSlant+fromFontSlant FontSlantNormal = C.FontSlantNormal+fromFontSlant FontSlantItalic = C.FontSlantItalic+fromFontSlant FontSlantOblique = C.FontSlantOblique++fromFontWeight :: FontWeight -> C.FontWeight+fromFontWeight FontWeightNormal = C.FontWeightNormal+fromFontWeight FontWeightBold = C.FontWeightBold++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 = 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++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+ (unr2 -> (a1,a2)) = apply t unitX+ (unr2 -> (b1,b2)) = apply t unitY+ (unr2 -> (c1,c2)) = transl t++{- ~~~~ Note [color order]++ It's important for the line and fill colors to be handled in the+ given order (fill color first, then line color) because of the way+ Cairo handles them (both are taken from the sourceRGBA).+-}++fromLineCap :: LineCap -> C.LineCap+fromLineCap LineCapButt = C.LineCapButt+fromLineCap LineCapRound = C.LineCapRound+fromLineCap LineCapSquare = C.LineCapSquare++fromLineJoin :: LineJoin -> C.LineJoin+fromLineJoin LineJoinMiter = C.LineJoinMiter+fromLineJoin LineJoinRound = C.LineJoinRound+fromLineJoin LineJoinBevel = C.LineJoinBevel++fromFillRule :: FillRule -> C.FillRule+fromFillRule Winding = C.FillRuleWinding+fromFillRule EvenOdd = C.FillRuleEvenOdd++instance Renderable (Segment R2) Cairo where+ render _ (Linear v) = C . lift $ uncurry C.relLineTo (unr2 v)+ render _ (Cubic (unr2 -> (x1,y1))+ (unr2 -> (x2,y2))+ (unr2 -> (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+ lift $ when c C.closePath++instance Renderable (Path R2) Cairo where+ render _ (Path trs) = C $ lift C.newPath >> F.mapM_ renderTrail trs+ where renderTrail (unp2 -> p, tr) = do+ 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 $ do+ if ".png" `isSuffixOf` file+ then do+ C.save+ cairoTransf (tr <> reflectionY)+ pngSurfChk <- liftIO (try $ C.imageSurfaceCreateFromPNG file+ :: IO (Either IOError C.Surface))+ case pngSurfChk of+ Right pngSurf -> do+ w <- C.imageSurfaceGetWidth pngSurf+ h <- C.imageSurfaceGetHeight pngSurf+ cairoTransf $ adjustSize sz (fromIntegral w, fromIntegral h)+ C.setSourceSurface pngSurf (-fromIntegral w / 2)+ (-fromIntegral h / 2)+ Left _ ->+ liftIO . putStrLn $+ "Warning: can't read image file <" ++ file ++ ">"+ C.paint+ C.restore+ else+ liftIO . putStr . unlines $+ [ "Warning: Cairo backend can currently only render embedded"+ , " images in .png format. Ignoring <" ++ file ++ ">."+ ]++-- see http://www.cairographics.org/tutorial/#L1understandingtext+instance Renderable Text Cairo where+ render _ (Text tr al str) = C $ do+ lift $ do+ C.save+ -- XXX should use reflection font matrix here instead?+ cairoTransf (tr <> reflectionY)+ (refX, refY) <- case al of+ BoxAlignedText xt yt -> do+ tExt <- C.textExtents str+ fExt <- C.fontExtents+ let l = C.textExtentsXbearing tExt+ r = C.textExtentsXadvance tExt+ b = C.fontExtentsDescent fExt+ t = C.fontExtentsAscent fExt+ return (lerp l r xt, lerp (-b) t yt)+ BaselineText -> return (0, 0)+ cairoTransf (moveOriginBy (r2 (refX, -refY)) mempty)+ C.showText str+ C.restore
+ src/Diagrams/Backend/Cairo/Text.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE RankNTypes #-}+-----------------------------------------------------------------------------+-- |+-- Module : Diagrams.Backend.Cairo.Text+-- Copyright : (c) 2011 Diagrams-cairo team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- This module provides convenience functions for querying information from+-- Cairo. In particular, this provides utilities for information about fonts,+-- and creating text primitives with bounds based on the font being used.+--+-----------------------------------------------------------------------------+module Diagrams.Backend.Cairo.Text+ (+ -- * Cairo Utilities+ queryCairo, unsafeCairo+ , StyleParam, cairoWithStyle++ -- * Extents++ -- ** Data Structures++ , TextExtents(..), FontExtents(..)++ -- ** Queries++ , getTextExtents, getFontExtents, getExtents+ , kerningCorrectionIO++ -- * Primitives++ -- | These create diagrams instantiated with extents-based envelopes+ , textLineBoundedIO, textVisualBoundedIO++ -- * Unsafe++ -- | These are convenient unsafe variants of the above operations+ -- postfixed with \"IO\". They should be pretty well-behaved as the+ -- results just depend on the parameters and the font information+ -- (which ought to stay the same during a given execution).++ , kerningCorrection, textLineBounded, textVisualBounded+ ) where++import Diagrams.Backend.Cairo.Internal+import Diagrams.Prelude++import Control.Monad.State+import System.IO.Unsafe++import qualified Graphics.Rendering.Cairo as C++-- | Executes a cairo action on a dummy, zero-size image surface, in order to+-- query things like font information.+queryCairo :: C.Render a -> IO a+queryCairo c = C.withImageSurface C.FormatA1 0 0 (`C.renderWith` c)++-- | Unsafely invokes @queryCairo@.+unsafeCairo :: C.Render a -> a+unsafeCairo = unsafePerformIO . queryCairo++-- | Existential type for mutations on objects that \"have style\". This is+-- used as a parameter to @getTextExtents@ and @getFontExtents@ in order to+-- set font-size and font-face.+type StyleParam = forall a. HasStyle a => a -> a++-- | Executes the given cairo action, with styling applied.+-- This does not do all styling - just attributes that are processed by+-- \"cairoMiscStyle\", which does clip, fill color, fill rule, and,+-- importantly for this module, font face, style, and weight.+cairoWithStyle :: C.Render a -> StyleParam -> C.Render a+cairoWithStyle f style = do+ C.save+ evalStateT (cairoMiscStyle (style mempty)) ()+ result <- f+ C.restore+ return result++-- | A more convenient data structure for the results of a text-extents query.+data TextExtents = TextExtents+ { bearing, textSize, advance :: R2 }++processTextExtents :: C.TextExtents -> TextExtents+processTextExtents (C.TextExtents xb yb w h xa ya)+ = TextExtents (r2 (xb,yb)) (r2 (w,h)) (r2 (xa,ya))++-- | Get the extents of a string of text, given a style to render it with.+getTextExtents :: StyleParam -> String -> C.Render TextExtents+getTextExtents style txt+ = cairoWithStyle (processTextExtents <$> C.textExtents txt) style++-- | A more convenient data structure for the results of a font-extents query.+data FontExtents = FontExtents+ { ascent, descent, height :: Double+ , maxAdvance :: R2+ }++processFontExtents :: C.FontExtents -> FontExtents+processFontExtents (C.FontExtents a d h mx my)+ = FontExtents a d h (r2 (mx,my))++-- | Gets the intrinsic extents of a font.+getFontExtents :: StyleParam -> C.Render FontExtents+getFontExtents style+ = cairoWithStyle (processFontExtents <$> C.fontExtents) style++-- | Gets both the "FontExtents" and "TextExtents" of the string with the a+-- particular style applied. This is more efficient than calling both+-- @getFontExtents@ and @getTextExtents@.+getExtents :: StyleParam -> String -> C.Render (FontExtents, TextExtents)+getExtents style str = cairoWithStyle (do+ fe <- processFontExtents <$> C.fontExtents+ te <- processTextExtents <$> C.textExtents str+ return (fe, te)+ ) style++-- | Queries the amount of horizontal offset that needs to be applied in order to+-- position the second character properly, in the event that it is @hcat@-ed+-- @baselineText@.+kerningCorrectionIO :: StyleParam -> Char -> Char -> IO Double+kerningCorrectionIO style a b = do+ let ax t = fst . unr2 . advance <$> queryCairo (getTextExtents style t)+ l <- ax [a, b]+ la <- ax [a]+ lb <- ax [b]+ return $ l - la - lb++-- | Creates text diagrams with their envelopes set such that using+-- @vcat . map (textLineBounded style)@ stacks them in the way that+-- the font designer intended.+textLineBoundedIO :: StyleParam -> String -> IO (Diagram Cairo R2)+textLineBoundedIO style str = do+ (fe, te) <- queryCairo $ getExtents style str+ let box = fromCorners (p2 (0, negate $ descent fe))+ (p2 (fst . unr2 $ advance te, ascent fe))+ return . setEnvelope (getEnvelope box) $ style (baselineText str)++-- | Creates a text diagram with its envelope set to enclose the glyphs of the text,+-- including leading (though not trailing) whitespace.+textVisualBoundedIO :: StyleParam -> String -> IO (Diagram Cairo R2)+textVisualBoundedIO style str = do+ te <- queryCairo $ getTextExtents style str+ let box = fromCorners (origin .+^ bearing te)+ (origin .+^ bearing te ^+^ (textSize te))+ return . setEnvelope (getEnvelope box) $ style (baselineText str)++kerningCorrection :: StyleParam -> Char -> Char -> Double+kerningCorrection style a = unsafePerformIO . kerningCorrectionIO style a++textLineBounded, textVisualBounded :: StyleParam -> String -> Diagram Cairo R2+textLineBounded style = unsafePerformIO . textLineBoundedIO style+textVisualBounded style = unsafePerformIO . textVisualBoundedIO style