module Diagrams.Backend.Cairo
( Cairo(..)
, Options(..)
, OutputFormat(..)
) where
import Graphics.Rendering.Diagrams.Transform
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.State
import Data.Maybe (catMaybes, fromMaybe)
import Data.List (isSuffixOf)
import Data.Monoid
import qualified Data.Foldable as F
import Data.Typeable
data Cairo = Cairo
deriving (Eq,Ord,Read,Show,Typeable)
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)
type RenderM a = StateT () C.Render a
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
{ fileName :: String
, outputFormat :: OutputFormat
}
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
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 = 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 -> 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
]
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
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
, 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
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 . 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 (2*pi)
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
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
instance Renderable Text Cairo where
render _ (Text tr str) = C $ do
lift $ do
C.save
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