diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -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 diff --git a/diagrams-cairo.cabal b/diagrams-cairo.cabal --- a/diagrams-cairo.cabal +++ b/diagrams-cairo.cabal @@ -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 diff --git a/example/Fractal.hs b/example/Fractal.hs --- a/example/Fractal.hs +++ b/example/Fractal.hs @@ -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) diff --git a/example/Hanoi.hs b/example/Hanoi.hs --- a/example/Hanoi.hs +++ b/example/Hanoi.hs @@ -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 diff --git a/example/Hasse.hs b/example/Hasse.hs --- a/example/Hasse.hs +++ b/example/Hasse.hs @@ -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) diff --git a/example/Logo.hs b/example/Logo.hs new file mode 100644 --- /dev/null +++ b/example/Logo.hs @@ -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) diff --git a/example/Star.hs b/example/Star.hs new file mode 100644 --- /dev/null +++ b/example/Star.hs @@ -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) diff --git a/example/golden.hs b/example/golden.hs --- a/example/golden.hs +++ b/example/golden.hs @@ -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 diff --git a/example/paradox.hs b/example/paradox.hs --- a/example/paradox.hs +++ b/example/paradox.hs @@ -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 diff --git a/example/tic-tac-toe/Maps.hs b/example/tic-tac-toe/Maps.hs --- a/example/tic-tac-toe/Maps.hs +++ b/example/tic-tac-toe/Maps.hs @@ -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 diff --git a/example/triangular-numbers.hs b/example/triangular-numbers.hs --- a/example/triangular-numbers.hs +++ b/example/triangular-numbers.hs @@ -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 diff --git a/src/Diagrams/Backend/Cairo.hs b/src/Diagrams/Backend/Cairo.hs --- a/src/Diagrams/Backend/Cairo.hs +++ b/src/Diagrams/Backend/Cairo.hs @@ -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) +-}