module Diagrams.Backend.Cairo
( Cairo(..)
, Options(..)
, OutputFormat(..)
) where
import Graphics.Rendering.Diagrams.Transform
import Diagrams.Prelude
import Diagrams.TwoD.Ellipse
import qualified Graphics.Rendering.Cairo as C
import qualified Graphics.Rendering.Cairo.Matrix as CM
import Control.Monad (when)
import Data.Maybe (catMaybes)
import Data.Monoid
import qualified Data.Foldable as F
data Cairo = Cairo
data OutputFormat =
PNG { pngSize :: (Int, Int)
}
| PS { psSize :: (Double, Double)
}
| PDF { pdfSize :: (Double, Double)
}
| SVG { svgSize :: (Double, Double)
}
instance Monoid (Render Cairo R2) where
mempty = C $ return ()
(C r1) `mappend` (C r2) = C (r1 >> r2)
instance Backend Cairo R2 where
data Render Cairo R2 = C (C.Render ())
type Result Cairo R2 = IO ()
data Options Cairo R2 = CairoOptions
{ fileName :: String
, outputFormat :: OutputFormat
}
withStyle _ s t (C r) = C $ do
C.save
r
cairoTransf t
cairoStyle s
C.stroke
C.restore
doRender _ options (C r) = do
let surfaceF surface = C.renderWith surface r
file = fileName options
case outputFormat options of
PNG (w,h) -> do
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 _ opts d = d' # lw 0.01 # lc black # freeze
# scale s
# translate tr
where d' = reflectY d
(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)
getSize (PS sz) = sz
getSize (PDF sz) = sz
getSize (SVG sz) = sz
renderC :: (Renderable a Cairo, V a ~ R2) => a -> C.Render ()
renderC a = case (render Cairo a) of C r -> r
cairoStyle :: Style -> C.Render ()
cairoStyle s = foldr (>>) (return ())
. catMaybes $ [ handle fColor
, handle lColor
, 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 (FillColor (SomeColor c)) = do
let (r,g,b,a) = colorToRGBA c
C.setSourceRGBA r g b a
C.fillPreserve
lColor (LineColor (SomeColor c)) = do
let (r,g,b,a) = colorToRGBA c
C.setSourceRGBA r g b a
lWidth (LineWidth w) = do
C.setLineWidth w
lCap lcap = do
C.setLineCap (fromLineCap lcap)
lJoin lj = do
C.setLineJoin (fromLineJoin lj)
lDashing (Dashing ds offs) = do
C.setDash ds offs
cairoTransf :: Transformation R2 -> 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
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
instance Renderable Ellipse Cairo where
render _ ell = C $ do
let P (xc,yc) = ellipseCenter ell
(xs,ys) = ellipseScale ell
th = ellipseAngle ell
C.newPath
C.save
C.translate xc yc
C.rotate th
C.scale xs ys
C.arc 0 0 1 0 (2*pi)
C.closePath
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
instance Renderable (Trail R2) Cairo where
render _ (Trail segs c) = C $ do
mapM_ renderC segs
when c $ C.closePath
instance Renderable (Path R2) Cairo where
render _ (Path trs) = C $ C.newPath >> F.mapM_ renderTrail trs
where renderTrail (tr, P p) = do
uncurry C.moveTo p
renderC tr