module Graphics.Rendering.Diagrams.Engine
(
sizeAndPos
, compose
, writePNG, writePS, writePDF, writeSVG
, renderWithBackend
, renderOverlayPNG
, chooseBackend
, writePagesPS, writePagesPDF
, renderPagesWithBackend
, choosePagesBackend
, atomic
, render
) where
import Graphics.Rendering.Diagrams.Types
import qualified Graphics.Rendering.Cairo as C
import Control.Monad.Reader
import Data.List (intersperse)
sizeAndPos :: Diagram -> (Point,Diagram)
sizeAndPos Empty = ((0,0), Empty)
sizeAndPos d@(Prim (Shape s)) = (shapeSize s, d)
sizeAndPos (Sized s d) = (s, snd $ sizeAndPos d)
sizeAndPos (Ann a@(Attr attr) d) = (attrSize attr s, (Ann a d'))
where (s, d') = sizeAndPos d
sizeAndPos (Compound (Layout l ds)) = (s, Union ds')
where (s, ds') = layoutSizeAndPos l (fmap sizeAndPos ds)
sizeAndPos (Union _) = error "sizeAndPos (Union _): This should never happen!"
compose :: SizeSpec
-> Diagram
-> (Point, C.Render ())
compose size d = compose' 1 size d
compose' :: Double -> SizeSpec -> Diagram -> (Point, C.Render ())
compose' opacity size d =
let ((x,y), d') = sizeAndPos d
(s,sx,sy) = case (size,x,y) of
(Width w,0,0) -> (1,w,w)
(Height h,0,0) -> (1,h,h)
(Width w,0,_) -> (1,w,y)
(Height h,_,0) -> (1,x,h)
(Width w,_,_) -> (w/x, w, y * w/x)
(Height h,_,_) -> (h/y, x * h/y, h)
(Auto, 0,0) -> (1,1,1)
(Auto, 0,_) -> (1,y,y)
(Auto, _,0) -> (1,x,x)
(Auto, _,_) -> (1,x,y)
in (,) (sx, sy) $ do
C.scale s s
C.translate (x/2) (y/2)
C.save
C.setSourceRGBA 1 1 1 opacity
C.paint
C.restore
flip runDiaRenderM defaultDiaRenderEnv . render $ d'
writePNG :: String -> Point -> C.Render () -> IO ()
writePNG dstfile wh r = usingBackground wh
(\surface -> writeSurfaceToPNG surface dstfile r)
overlayPNG :: String -> String -> C.Render () -> IO ()
overlayPNG srcfile dstfile r = usingPNG srcfile
(\surface -> writeSurfaceToPNG surface dstfile r)
writeSurfaceToPNG :: C.Surface -> FilePath -> C.Render () -> IO ()
writeSurfaceToPNG surface dstfile r = do
C.renderWith surface r
C.surfaceWriteToPNG surface dstfile
usingPNG :: FilePath -> (C.Surface -> IO ()) -> IO ()
usingPNG srcfile = C.withImageSurfaceFromPNG srcfile
usingBackground :: Point -> (C.Surface -> IO ()) -> IO ()
usingBackground (w,h) = C.withImageSurface C.FormatARGB32 (ceiling w) (ceiling h)
writeSurface :: (String -> Double -> Double -> (C.Surface -> IO a) -> IO a)
-> String
-> Point
-> C.Render a
-> IO a
writeSurface withSurface fileName (w,h) r =
withSurface fileName w h $ \surface ->
C.renderWith surface r
writePagesSurface :: (String -> Double -> Double -> (C.Surface -> IO ()) -> IO ())
-> (C.Surface -> Double -> Double -> C.Render ())
-> String
-> [(Point, C.Render ())]
-> IO ()
writePagesSurface withSurface surfaceSetSize fileName pages =
withSurface fileName 0 0 $ \surface -> C.renderWith surface $
sequence_ $ concat $ intersperse [C.showPage] $
[[C.save, surfaceSetSize surface w h, r, C.restore] | ((w,h),r) <- pages]
writePS :: String -> Point -> C.Render () -> IO ()
writePS = writeSurface C.withPSSurface
writePagesPS :: String -> [(Point, C.Render ())] -> IO ()
writePagesPS = writePagesSurface C.withPSSurface C.psSurfaceSetSize
writePDF :: String -> Point -> C.Render () -> IO ()
writePDF = writeSurface C.withPDFSurface
writePagesPDF :: String -> [(Point, C.Render ())] -> IO ()
writePagesPDF = writePagesSurface C.withPDFSurface C.pdfSurfaceSetSize
writeSVG :: String -> Point -> C.Render () -> IO ()
writeSVG = writeSurface C.withSVGSurface
renderWithBackend :: (String -> Point -> C.Render () -> IO ())
-> String
-> SizeSpec
-> Diagram
-> IO ()
renderWithBackend backend name size dia = backend name wh r
where (wh, r) = compose size dia
renderPagesWithBackend :: (String -> [(Point, C.Render ())] -> IO ())
-> String
-> SizeSpec
-> [Diagram]
-> IO ()
renderPagesWithBackend backend name size dias
= backend name (map (compose size) dias)
renderOverlayPNG :: FilePath -> FilePath -> Diagram -> IO ()
renderOverlayPNG srcfile dstfile dia = overlayPNG srcfile dstfile r
where r = snd $ compose' 0 Auto dia
chooseBackend :: OutputType -> (String -> Point -> C.Render () -> IO ())
chooseBackend PNG = writePNG
chooseBackend PS = writePS
chooseBackend PDF = writePDF
chooseBackend SVG = writeSVG
choosePagesBackend :: OutputType -> (String -> [(Point, C.Render ())] -> IO ())
choosePagesBackend PS = writePagesPS
choosePagesBackend PDF = writePagesPDF
choosePagesBackend PNG = error "PNG doesn't support multiple pages"
choosePagesBackend SVG = error "SVG doesn't support multiple pages"
atomic :: DiaRenderM () -> DiaRenderM ()
atomic r = (c C.save) >> r >> (c C.restore)
render :: Diagram -> DiaRenderM ()
render Empty = return ()
render (Prim (Shape s)) = renderShape s
render (Ann (Attr a) d) = atomic $ renderAttr a >>= flip local (render d)
render (Union ds) = mapM_ render ds
render (Sized _ d) = render d
render d@(Compound _) = render $ snd $ sizeAndPos d