-- | Cairo backend to Hieroglyph. Future plans include making 'StateModifier' part -- of the base distribution and making 'Frame' the basis for all backends to -- Hieroglyph. The real challenge will be making all implementations /look/ the -- same. -- -- Note in particular that pattern functionality and Pango layouts and font -- rendering engines are not implemented yet. This is both because these -- features are fairly complicated, and because I haven't figured out yet -- how I might make them portable to OpenGL using textures and FTGL. if -- someone wants to take this task on, I'd be pleased as punch. -- -- [@Author@] Jeff Heard -- -- [@Copyright@] © 2008 Renaissance Computing Institute -- -- [@License@] A LICENSE file should be included as part of this distribution -- -- [@Version@] 0.5 -- module Graphics.Rendering.Hieroglyph.Cairo where import Data.Map (Map) import qualified Data.Map as M import System.Mem.Weak import Control.Concurrent import Control.Monad.Trans (liftIO) import Graphics.Rendering.Hieroglyph.Primitives import Graphics.UI.Gtk.Gdk.Pixbuf import qualified Graphics.UI.Gtk.Cairo as Cairo import qualified Graphics.Rendering.Cairo as Cairo import Control.Monad import Control.Monad.IfElse import Data.List (foldl') import Graphics.Rendering.Hieroglyph.UIState -- | Modifies the way that primitives are drawn in subtrees where a 'Setup' marker -- in the parent nodes. All state changes are inherited lie you might think they -- ought to be. All colors are specified like in Cairo, using Doubles in the -- range [0..1]. data StateModifier = ResetClip -- ^ Reset the clipping plane | Translate Double Double -- ^ @Translate x y@ translates all subitems by x and y | Scale Double Double -- ^ @Scale x y@ scales the subitems by x and y | Rotate Double -- ^ @Rotate r@ everything clockwise by r radians | Font String -- ^ Set the font family. See 'Graphics.Rendering.Cairo.selectFontFace' for behaviour. | FontSlant Cairo.FontSlant -- ^ Set the font slant. | FontWeight Cairo.FontWeight -- ^ Set the font weight. | FillRule Cairo.FillRule -- ^ Set the way patterns are filled. Does nothing if you haven't yet set the pattern yourself. | FillRed Double -- ^ Set the fill color's red component without changing anything else | FillGreen Double -- ^ Set the fill color's green component without changing anything else | FillBlue Double -- ^ Set the fill color's blue component without changing anything else | FillAlpha Double -- ^ Set the fill color's alpha component without changing anything else | FillRGB Double Double Double -- ^ @FillRGB r g b@ sets the fill RGB to r g b and the alpha component to 1 | StrokeRGB Double Double Double -- ^ @StrokeRGB r g b@ sets the stroke RGB to r g b and the alpha component to 1 | StrokeRGBA Double Double Double Double -- ^ @StrokeRGBA r g b a@ sets the stroke color | FillRGBA Double Double Double Double -- ^ @FillRGBA r g b a@ sets the fill color | Dash [Double] Double -- ^ @Dash pattern width@ sets the dash pattern for lines (OpenGL will need to use a stipple pattern, I think) | StrokeRed Double -- ^ Set the stroke color's red component without changing anything else | StrokeGreen Double -- ^ Set the stroke color's green component without changing anything else | StrokeBlue Double -- ^ Set the stroke color's blue component without changing anything else | StrokeAlpha Double -- ^ Set the stroke color's alpha component without changing anything else | Antialias Cairo.Antialias -- ^ Set the way antialiasing is performed. This may be non-portable between Cairo and OpenGL without employing a shader | LineCap Cairo.LineCap -- ^ Set the line cap style | LineJoin Cairo.LineJoin -- ^ Set the line join style | LineWidth Double -- ^ Set the width of the line in points | MiterLimit Double -- ^ Set the miter limit for corners | Tolerance Double -- ^ Set the trapezoidal tolerance. This may be irrelevant in OpenGL, but it controls the quality of lines in Cairo. | Operator Cairo.Operator -- ^ Set the way the source is transferred to the surface through the stencil. Emulating this functionality in OpenGL may be difficult. | CurrentPoint Point -- ^ Set the current point that the pen is at. Note that this only sets it, any changes made to the current point by the children are still changes. To ensure that this is the current point, use a 'Pen' draw command. -- | A tree structure that defines a frame. The first argument is either a -- 'Draw' or a 'Setup' command and the list is a list of children. data Object = Group [Object] | Draw Primitive | Context [StateModifier] Object -- | The current state of the renderer. Carried down the tree and modified with 'StateModifier' 'Node's. data RendererState = RendererState { fontfamily :: String -- ^ The font name , fontslant :: Cairo.FontSlant -- ^ The font slant , fontsize :: Double -- ^ The font size in points , fontweight :: Cairo.FontWeight -- ^ The font weight , fillrule :: Cairo.FillRule -- ^ The pattern fill rule , fillred :: Double -- ^ The red component of the fill color in the range [0..1] , fillgreen :: Double -- ^ The green component of the fill color in the range [0..1] , fillblue :: Double -- ^ The blue component of the fill color in the range [0..1] , fillalpha :: Double -- ^ The alpha component of the fill color in the range [0..1] , dash :: Maybe ([Double],Double) -- ^ The shape of the line dashing, if any , strokered :: Double -- ^ The red component of the stroke color in the range [0..1] , strokegreen :: Double -- ^ The red component of the stroke color in the range [0..1] , strokeblue :: Double -- ^ The red component of the stroke color in the range [0..1] , strokealpha :: Double -- ^ The red component of the stroke color in the range [0..1] , antialias :: Cairo.Antialias -- ^ The way things are antialiased , linecap :: Cairo.LineCap -- ^ The way lines are capped , linejoin :: Cairo.LineJoin -- ^ The way lines are joined , linewidth :: Double -- ^ The width of a line in points , miterlimit :: Double -- ^ The miter limit of lines. See Cairo's documentation , tolerance :: Double -- ^ The trapezoidal tolerance. See Cairo's documentation , operator :: Cairo.Operator -- ^ The transfer operator. See Cairo's documentation for more , currentpoint :: Point -- ^ Current base point for the first child's graphics operation , translatex :: Double -- ^ The current translation x component , translatey :: Double -- ^ The current translation y component , scalex :: Double -- ^ The current scale x component , scaley :: Double -- ^ The current scale y component , rotation :: Double } -- ^ The current clockwise rotation in radians. fillStrokeAndClip state isfilled isoutlined isclipped = do when isfilled $ Cairo.setSourceRGBA (fillred state) (fillgreen state) (fillblue state) (fillalpha state) >> if isoutlined then Cairo.fillPreserve else Cairo.fill when isoutlined $ Cairo.setSourceRGBA (strokered state) (strokegreen state) (strokeblue state) (strokealpha state) >> Cairo.stroke when isclipped $ Cairo.clip -- | @renderPrimitive state prim@ draws a single primitive. renderPrimitive :: ImageCache -> RendererState -> Primitive -> Cairo.Render () renderPrimitive _ state (Arc (Point cx cy) radius angle0 angle1 isnegative f o c) = do if isnegative then Cairo.arcNegative cx cy radius angle0 angle1 else Cairo.arc cx cy radius angle0 angle1 fillStrokeAndClip state f o c renderPrimitive _ state (Curve (Point ox oy) segs isclosed f o c) = do Cairo.moveTo ox oy forM_ segs $ \(Point x1 y1,Point x2 y2,Point x3 y3) -> Cairo.curveTo x1 y1 x2 y2 x3 y3 when isclosed (Cairo.lineTo ox oy) fillStrokeAndClip state f o c renderPrimitive _ state (Line (Point ox oy) segs isclosed f o c) = do Cairo.moveTo ox oy mapM (\seg -> case seg of Point x y -> Cairo.lineTo x y) segs when isclosed (Cairo.lineTo ox oy) fillStrokeAndClip state f o c renderPrimitive images state i@(Image filename (Left (Point ox oy)) _) = do pbuf <- loadImage images i w <- liftIO $ pixbufGetWidth pbuf h <- liftIO $ pixbufGetHeight pbuf Cairo.save Cairo.setSourcePixbuf pbuf ox oy Cairo.rectangle ox oy (fromIntegral w) (fromIntegral h) Cairo.fill Cairo.restore renderPrimitive images state i@(Image filename (Right (Rect ox oy w h)) _) = do pbuf <- loadImage images i Cairo.save Cairo.setSourcePixbuf pbuf ox oy Cairo.rectangle ox oy w h Cairo.fill Cairo.restore renderPrimitive _ _ Hidden = return () renderPrimitive _ _ (Pen (Point ox oy)) = Cairo.moveTo ox oy renderPrimitive _ state (Rectangle (Point ox oy) w h f o c) = Cairo.rectangle ox oy w h >> fillStrokeAndClip state f o c renderPrimitive _ state (Text str (Point ox oy) f o c) = Cairo.showText str >> fillStrokeAndClip state f o c renderPrimitive images state (Compound prims f o c) = mapM (renderPrimitive images state . unfoc) prims >> fillStrokeAndClip state f o c where unfoc prim = prim{ filled=False, outlined=False, clipped=False } -- | The initial state of Cairo, encoded as an object. defaultState :: RendererState defaultState = RendererState { fontfamily = "arial" , fontslant = Cairo.FontSlantNormal , fontweight = Cairo.FontWeightNormal , fontsize = 10 , fillrule = Cairo.FillRuleWinding , fillred = 1 , fillgreen = 1 , fillblue = 1 , fillalpha = 1 , dash = Nothing , strokered = 1 , strokegreen = 1 , strokeblue = 1 , strokealpha = 1 , antialias = Cairo.AntialiasDefault , linecap = Cairo.LineCapButt , linejoin = Cairo.LineJoinMiter , linewidth = 1 , miterlimit = 0 , tolerance = 0.1 , operator = Cairo.OperatorOver , currentpoint = origin , translatex = 0 , translatey = 0 , scalex = 1 , scaley = 1 , rotation = 0 } -- | Load the Cairo state machine with a 'RenderState' object. loadStateIntoCairo :: RendererState -> Cairo.Render () loadStateIntoCairo s = do Cairo.selectFontFace (fontfamily s) (fontslant s) (fontweight s) Cairo.setFillRule . fillrule $ s awhen (dash s) $ \(a,b) -> Cairo.setDash a b Cairo.setAntialias . antialias $ s Cairo.setLineCap . linecap $ s Cairo.setLineJoin . linejoin $ s Cairo.setLineWidth . linewidth $ s Cairo.setMiterLimit . miterlimit $ s Cairo.setTolerance . tolerance $ s Cairo.setOperator . operator $ s case currentpoint s of (Point px py) -> Cairo.moveTo px py Cairo.translate (translatex s) (translatey s) Cairo.scale (scalex s) (scaley s) Cairo.rotate (rotation s) changeRenderState :: RendererState -> [StateModifier] -> Cairo.Render RendererState changeRenderState state changes = do let state' = foldl' applyStateChangeToLocalEnv state changes mapM (applyStateChangeToCairo state') changes return state' applyStateChangeToLocalEnv state ResetClip = state applyStateChangeToLocalEnv state (Translate byx byy) = state{ translatex = byx, translatey = byy } applyStateChangeToLocalEnv state (Scale byx byy) = state{ scalex = byx, scaley = byy } applyStateChangeToLocalEnv state (Rotate by) = state{ rotation = by } applyStateChangeToLocalEnv state (Font s) = state{ fontfamily=s } applyStateChangeToLocalEnv state (FontSlant s) = state{ fontslant=s } applyStateChangeToLocalEnv state (FontWeight s) = state{ fontweight=s } applyStateChangeToLocalEnv state (FillRule s) = state{ fillrule=s } applyStateChangeToLocalEnv state (FillRed s) = state{ fillred=s } applyStateChangeToLocalEnv state (FillGreen s) = state{ fillgreen=s } applyStateChangeToLocalEnv state (FillBlue s) = state{ fillblue=s } applyStateChangeToLocalEnv state (FillAlpha s) = state{ fillalpha=s } applyStateChangeToLocalEnv state (Dash a b) = state{ dash=Just (a,b) } applyStateChangeToLocalEnv state (StrokeRed s) = state{ strokered=s } applyStateChangeToLocalEnv state (StrokeGreen s) = state{ strokegreen=s } applyStateChangeToLocalEnv state (StrokeBlue s) = state{ strokeblue=s } applyStateChangeToLocalEnv state (StrokeAlpha s) = state{ strokealpha=s } applyStateChangeToLocalEnv state (Antialias s) = state{ antialias=s } applyStateChangeToLocalEnv state (LineCap s) = state{ linecap=s } applyStateChangeToLocalEnv state (LineJoin s) = state{ linejoin=s } applyStateChangeToLocalEnv state (LineWidth s) = state{ linewidth=s } applyStateChangeToLocalEnv state (MiterLimit s) = state{ miterlimit=s } applyStateChangeToLocalEnv state (Tolerance s) = state{ tolerance=s } applyStateChangeToLocalEnv state (Operator s) = state{ operator=s } applyStateChangeToLocalEnv state (CurrentPoint s) = state{ currentpoint=s } applyStateChangeToLocalEnv state (FillRGB r g b) = state{ fillred = r, fillgreen = g, fillblue = b } applyStateChangeToLocalEnv state (FillRGBA r g b a) = state{ fillred = r, fillgreen = g, fillblue = b , fillalpha = a } applyStateChangeToLocalEnv state (StrokeRGB r g b) = state{ strokered = r, strokegreen=g, strokeblue = b } applyStateChangeToLocalEnv state (StrokeRGBA r g b a) = state{strokered = r, strokegreen=g, strokeblue = b, strokealpha = a } applyStateChangeToCairo state ResetClip = Cairo.resetClip applyStateChangeToCairo state (Translate byx byy) = Cairo.translate byx byy applyStateChangeToCairo state (Scale byx byy) = Cairo.scale byx byy applyStateChangeToCairo state (Rotate by) = Cairo.rotate by applyStateChangeToCairo state (Font s) = Cairo.selectFontFace s (fontslant state) (fontweight state) applyStateChangeToCairo state (FontSlant s) = Cairo.selectFontFace (fontfamily state) s (fontweight state) applyStateChangeToCairo state (FontWeight s) = Cairo.selectFontFace (fontfamily state) (fontslant state) s applyStateChangeToCairo state (FillRule s) = Cairo.setFillRule s applyStateChangeToCairo state (FillRed s) = return () applyStateChangeToCairo state (FillGreen s) = return () applyStateChangeToCairo state (FillBlue s) = return () applyStateChangeToCairo state (FillAlpha s) = return () applyStateChangeToCairo state (Dash a b) = Cairo.setDash a b applyStateChangeToCairo state (StrokeRed s) = return () applyStateChangeToCairo state (StrokeGreen s) = return () applyStateChangeToCairo state (StrokeBlue s) = return () applyStateChangeToCairo state (StrokeAlpha s) = return () applyStateChangeToCairo state (Antialias s) = Cairo.setAntialias s applyStateChangeToCairo state (LineCap s) = Cairo.setLineCap s applyStateChangeToCairo state (LineJoin s) = Cairo.setLineJoin s applyStateChangeToCairo state (LineWidth s) = Cairo.setLineWidth s applyStateChangeToCairo state (MiterLimit s) = Cairo.setMiterLimit s applyStateChangeToCairo state (Tolerance s) = Cairo.setTolerance s applyStateChangeToCairo state (Operator s) = Cairo.setOperator s applyStateChangeToCairo state (CurrentPoint (Point px py)) = Cairo.moveTo px py applyStateChangeToCairo state (FillRGB r g b) = return () applyStateChangeToCairo state (FillRGBA r g b a) = return () applyStateChangeToCairo state (StrokeRGB r g b) = return () applyStateChangeToCairo state (StrokeRGBA r g b a) = return () renderObject :: ImageCache -> Object -> Cairo.Render () renderObject images = renderObjectWithState images defaultState renderObjectWithState :: ImageCache -> RendererState -> Object -> Cairo.Render () renderObjectWithState images state (Group objects) = mapM_ (renderObjectWithState images state) objects renderObjectWithState images state (Draw prim) = renderPrimitive images state prim renderObjectWithState images state (Context setup object) = do Cairo.save state' <- changeRenderState state setup renderObjectWithState images state' object Cairo.restore loadStateIntoCairo state -- | @renderFrameToSurface surface frame@ renders a frame to a particular surface renderObjectToSurfaceWithImageCache :: ImageCache -> Cairo.Surface -> Object -> IO () renderObjectToSurfaceWithImageCache images surf frame = Cairo.renderWith surf (renderObject images frame) renderObjectToSurface :: Cairo.Surface -> Object -> IO () renderObjectToSurface s o = do { i <- initImageCache; renderObjectToSurfaceWithImageCache i s o } -- | @renderframeToPNGWithImageCache filename xres yres frame@ renders a frame to an image file renderObjectToPNGWithImageCache :: ImageCache -> FilePath -> Int -> Int -> Object -> IO () renderObjectToPNGWithImageCache images filename xres yres frame = Cairo.withImageSurface Cairo.FormatARGB32 xres yres $ \s -> renderObjectToSurfaceWithImageCache images s frame >> Cairo.surfaceWriteToPNG s filename renderObjectToPNG f w h o = do { i <- initImageCache ; renderObjectToPNGWithImageCache i f w h o } -- | @renderObjectToPDFWithImageCache filename width height frame@ renders a frame to a PDF file. width and height are in points. renderObjectToPDFWithImageCache :: ImageCache -> FilePath -> Double -> Double -> Object -> IO () renderObjectToPDFWithImageCache images filename width height frame = Cairo.withPDFSurface filename width height $ \s -> renderObjectToSurfaceWithImageCache images s frame renderObjectToPDF f w h o = do { i <- initImageCache ; renderObjectToPDFWithImageCache i f w h o } -- | @renderObjectToPostscriptWithImageCache filename width height frame@ renders a frame to a Postscript file. width and height are in points. renderObjectToPostscriptWithImageCache :: ImageCache -> FilePath -> Double -> Double -> Object -> IO () renderObjectToPostscriptWithImageCache images filename width height frame = Cairo.withPSSurface filename width height $ \s -> renderObjectToSurfaceWithImageCache images s frame renderObjectToPostscript f w h o = do { i <- initImageCache ; renderObjectToPostscriptWithImageCache i f w h o } -- | @renderObjectToSVGWithImageCache filename width height frame@ renders a frame to a SVG file. width and height are in points. renderObjectToSVGWithImageCache :: ImageCache -> FilePath -> Double -> Double -> Object -> IO () renderObjectToSVGWithImageCache images filename width height frame = Cairo.withSVGSurface filename width height $ \s -> renderObjectToSurfaceWithImageCache images s frame renderObjectToSVG f w h o = do { i <- initImageCache ; renderObjectToSVGWithImageCache i f w h o } -- | @loadImage dictRef image@ pulls an image out of the cache's hat. loadImage :: ImageCache -> Primitive -> Cairo.Render (Pixbuf) loadImage dictRef im@(Image filename (Right (Rect x y w h)) aspect) = do liftIO $ modifyMVar dictRef $ \dict -> if (show im) `M.member` dict then do value <- deRefWeak $ dict M.! (show im) pbuf <- case value of Just pb -> return pb Nothing -> pixbufNewFromFileAtScale filename (round w) (round h) aspect return (dict,pbuf) else do pbuf <- pixbufNewFromFileAtScale filename (round w) (round h) aspect wk <- mkWeakPtr pbuf Nothing return ((M.insert (show im) wk dict), pbuf) loadImage dictRef im@(Image filename (Left (Point x y)) _) = do liftIO $ modifyMVar dictRef $ \dict -> if (show im) `M.member` dict then do value <- deRefWeak $ dict M.! (show im) pbuf <- case value of Just pb -> return pb Nothing -> pixbufNewFromFile filename return (dict,pbuf) else do pbuf <- pixbufNewFromFile filename wk <- mkWeakPtr pbuf Nothing return ((M.insert (show im) wk dict), pbuf)