cairo 0.12.5.3 → 0.13.12.0
raw patch · 38 files changed
Files
- Graphics/Rendering/Cairo.hs +412/−46
- Graphics/Rendering/Cairo/Internal/Drawing/Cairo.chs +5/−4
- Graphics/Rendering/Cairo/Internal/Drawing/Paths.chs +174/−2
- Graphics/Rendering/Cairo/Internal/Drawing/Patterns.chs +59/−16
- Graphics/Rendering/Cairo/Internal/Drawing/Text.chs +23/−4
- Graphics/Rendering/Cairo/Internal/Drawing/Transformations.chs +1/−1
- Graphics/Rendering/Cairo/Internal/Surfaces/SVG.chs +5/−0
- Graphics/Rendering/Cairo/Internal/Utilities.chs +15/−4
- Graphics/Rendering/Cairo/Types.chs +62/−22
- Gtk2HsSetup.hs +0/−472
- Setup.hs +6/−8
- SetupMain.hs +0/−13
- SetupWrapper.hs +0/−164
- cairo.cabal +43/−26
- demo/CairoGhci.hs +0/−76
- demo/Clock.hs +0/−407
- demo/Drawing.hs +0/−59
- demo/Drawing2.hs +0/−258
- demo/Graph.hs +0/−98
- demo/Makefile +0/−33
- demo/StarAndRing.hs +0/−111
- demo/Text.hs +0/−71
- demo/gtk2/CairoGhci.hs +76/−0
- demo/gtk2/Clock.hs +407/−0
- demo/gtk2/Drawing.hs +59/−0
- demo/gtk2/Drawing2.hs +258/−0
- demo/gtk2/Graph.hs +98/−0
- demo/gtk2/Makefile +33/−0
- demo/gtk2/StarAndRing.hs +111/−0
- demo/gtk2/Text.hs +71/−0
- demo/gtk3/CairoGhci.hs +76/−0
- demo/gtk3/Clock.hs +327/−0
- demo/gtk3/Drawing.hs +58/−0
- demo/gtk3/Drawing2.hs +261/−0
- demo/gtk3/Graph.hs +102/−0
- demo/gtk3/Makefile +37/−0
- demo/gtk3/StarAndRing.hs +111/−0
- demo/gtk3/Text.hs +71/−0
Graphics/Rendering/Cairo.hs view
@@ -49,7 +49,7 @@ -- PostScript and PDF. Operations in cairo including stroking and filling cubic -- Bezier splines, transforming and compositing translucent images, and -- antialiased text rendering. All drawing operations can be transformed by any--- affine transformation (scale, rotation, shear, etc.) +-- affine transformation (scale, rotation, shear, etc.) -- -- Cairo is free software and is available to be redistributed and\/or modified -- under the terms of either the GNU Lesser General Public License (LGPL)@@ -96,6 +96,7 @@ , getTolerance , clip , clipPreserve+ , clipExtents , resetClip , fill , fillPreserve@@ -126,8 +127,16 @@ , relCurveTo , relLineTo , relMoveTo+ , copyPath+ , copyPathFlat+ , appendPath+ , pathExtents -- ** Patterns+ , createRGBPattern+ , createRGBAPattern+ , createLinearPattern+ , createRadialPattern , withRGBPattern , withRGBAPattern , withPatternForSurface@@ -241,7 +250,11 @@ #ifdef CAIRO_HAS_SVG_SURFACE -- ** SVG surfaces , withSVGSurface+#if CAIRO_CHECK_VERSION(1,16,0)+ , svgSurfaceSetDocumentUnit+ , svgSurfaceGetDocumentUnit #endif+#endif #if CAIRO_CHECK_VERSION(1,10,0) -- * Regions@@ -273,6 +286,7 @@ , liftIO , version , versionString+ , CairoString -- * Types @@ -298,6 +312,9 @@ , HintMetrics(..) , FontOptions , Path+ , PathElement(..)+ , SurfaceType(..)+ , PatternType(..) #if CAIRO_CHECK_VERSION(1,10,0) , RectangleInt(..) , RegionOverlap(..)@@ -308,6 +325,30 @@ , Extend(..) , Filter(..) +#ifdef CAIRO_HAS_SVG_SURFACE+#if CAIRO_CHECK_VERSION(1,16,0)+ , SvgUnit(..)+#endif+#endif++ -- mesh patterns+#if CAIRO_CHECK_VERSION(1,12,0)+ , createMeshPattern+ , meshPatternAddPatchRGB+ , meshPatternAddPatchRGBA+ , meshPatternBeginPatch+ , meshPatternEndPatch+ , meshPatternMoveTo+ , meshPatternLineTo+ , meshPatternCurveTo+ , meshPatternSetControlPoint+ , meshPatternSetCornerColorRGB+ , meshPatternSetCornerColorRGBA+ , meshPatternGetPatchCount+ , meshPatternGetPath+ , meshPatternGetControlPoint+ , meshPatternGetCornerColorRGBA+#endif ) where import Control.Monad (unless, when)@@ -323,17 +364,20 @@ -- internal module of GHC import Data.Array.Base ( MArray, newArray, newArray_, unsafeRead, unsafeWrite, #if __GLASGOW_HASKELL__ < 605- HasBounds, bounds+ HasBounds, bounds #else- getBounds+ getBounds #endif #if __GLASGOW_HASKELL__ >= 608- ,getNumElements+ ,getNumElements #endif )+#ifdef CAIRO_HAS_PNG_FUNCTIONS import Graphics.Rendering.Cairo.Internal (imageSurfaceCreateFromPNG)+#endif import Graphics.Rendering.Cairo.Types+import Graphics.Rendering.Cairo.Internal.Utilities (CairoString(..)) import qualified Graphics.Rendering.Cairo.Internal as Internal import Graphics.Rendering.Cairo.Internal (Render(..), bracketR) @@ -356,7 +400,7 @@ -- default values and with the given surface as a target surface. The target -- surface should be constructed with a backend-specific function such as -- 'withImageSurface' (or any other with\<backend\>Surface variant).--- +-- renderWith :: (MonadIO m) => Surface -- ^ the target surface for the Render context -> Render a@@ -444,7 +488,7 @@ setSourceRGB :: Double -- ^ red component of colour -> Double -- ^ green component of colour- -> Double -- ^ blue compoment of colour+ -> Double -- ^ blue component of colour -> Render () setSourceRGB = liftRender3 Internal.setSourceRGB @@ -524,7 +568,7 @@ -- | Sets the dash pattern to be used by 'stroke'. A dash pattern is specified -- by dashes, a list of positive values. Each value provides the user-space--- length of altenate "on" and "off" portions of the stroke. The offset+-- length of alternate "on" and "off" portions of the stroke. The offset -- specifies an offset into the pattern at which the stroke begins. -- -- If @dashes@ is @[]@ then dashing is disabled.@@ -700,6 +744,12 @@ resetClip :: Render () resetClip = liftRender0 Internal.resetClip +-- | Computes a bounding box in user coordinates covering the area+-- inside the current clip.+--+clipExtents :: Render (Double,Double,Double,Double)+clipExtents = liftRender0 Internal.clipExtents+ -- | A drawing operator that fills the current path according to the current -- fill rule, (each sub-path is implicitly closed before being filled). -- After 'fill', the current path will be cleared from the cairo context.@@ -925,8 +975,8 @@ -- position (@x@, @y@) in user-space coordinates. -- rectangle ::- Double -- ^ @x@ - the X coordinate of the top left corner of the rectangle - -> Double -- ^ @y@ - the Y coordinate of the top left corner of the rectangle + Double -- ^ @x@ - the X coordinate of the top left corner of the rectangle+ -> Double -- ^ @y@ - the Y coordinate of the top left corner of the rectangle -> Double -- ^ @width@ - the width of the rectangle -> Double -- ^ @height@ - the height of the rectangle -> Render ()@@ -935,9 +985,10 @@ -- | Render text at the current path. -- -- * See 'showText' for why you should use Gtk functions.--- +-- textPath ::- String -- ^ -+ CairoString string+ => string -- ^ - -> Render () textPath = liftRender1 Internal.textPath @@ -980,12 +1031,93 @@ -- to moveTo (x + @dx@) (y + @dy@) -- relMoveTo ::- Double -- ^ @dx@ - the X offset- -> Double -- ^ @dy@ - the Y offset+ Double -- ^ @dx@ - the X offset+ -> Double -- ^ @dy@ - the Y offset -> Render () relMoveTo = liftRender2 Internal.relMoveTo +-- | Creates a copy of the current path and returns it to the user.+copyPath :: Render Path+copyPath = liftRender0 Internal.copyPath+++-- | Gets a flattened copy of the current path and returns it to the user.+--+-- This function is like copyPath except that any curves in the path will be+-- approximated with piecewise-linear approximations, accurate to within the current tolerance value.+-- That is, any path elements created by curveTo or relCurveTo will be replaced by a series of lineTo elements.+copyPathFlat :: Render Path+copyPathFlat = liftRender0 Internal.copyPathFlat+++-- | Append the path onto the current path.+--+-- The path may be either the return value from copyPath or copyPathFlat or it may be constructed manually.+appendPath :: Path -- ^ the path to append+ -> Render ()+appendPath = liftRender1 Internal.appendPath++++pathExtents :: Render (Double,Double,Double,Double)+pathExtents = liftRender0 Internal.pathExtents+++++-- | +--+createRGBPattern ::+ MonadIO m =>+ Double -- ^ @r@+ -> Double -- ^ @g@+ -> Double -- ^ @b@+ -> m Pattern+createRGBPattern r g b = liftIO$ Internal.patternCreateRGB r g b+++-- | +--+createRGBAPattern ::+ MonadIO m =>+ Double -- ^ @r@+ -> Double -- ^ @g@+ -> Double -- ^ @b@+ -> Double -- ^ @a@+ -> m Pattern+createRGBAPattern r g b a = liftIO$ Internal.patternCreateRGBA r g b a+++-- | +--+createLinearPattern ::+ MonadIO m =>+ Double -- ^ @x1@+ -> Double -- ^ @y1@+ -> Double -- ^ @x2@+ -> Double -- ^ @y2@+ -> m Pattern+createLinearPattern x1 y1 x2 y2 = liftIO$ Internal.patternCreateLinear x1 y1 x2 y2+++-- | +--+createRadialPattern ::+ MonadIO m =>+ Double -- ^ @x1@+ -> Double -- ^ @y1@+ -> Double -- ^ @r1@+ -> Double -- ^ @x2@+ -> Double -- ^ @y2@+ -> Double -- ^ @r2@+ -> m Pattern+createRadialPattern x1 y1 r1 x2 y2 r2 = liftIO$ Internal.patternCreateRadial x1 y1 r1 x2 y2 r2+++++ -- | Creates a new 'Pattern' corresponding to an opaque color. The color -- components are floating point numbers in the range 0 to 1. If the values -- passed in are outside that range, they will be clamped.@@ -1005,7 +1137,8 @@ withRGBPattern r g b f = bracketR (Internal.patternCreateRGB r g b) (\pattern -> do status <- Internal.patternStatus pattern- liftIO $ Internal.patternDestroy pattern+ -- omitted because patternCreateRGB now returns a foreign ptr with patternDestroy as a finalizer+-- liftIO $ Internal.patternDestroy pattern unless (status == StatusSuccess) $ fail =<< Internal.statusToString status) (\pattern -> f pattern)@@ -1030,7 +1163,7 @@ withRGBAPattern r g b a f = bracketR (Internal.patternCreateRGBA r g b a) (\pattern -> do status <- Internal.patternStatus pattern- liftIO $ Internal.patternDestroy pattern+-- liftIO $ Internal.patternDestroy pattern unless (status == StatusSuccess) $ fail =<< Internal.statusToString status) (\pattern -> f pattern)@@ -1044,7 +1177,7 @@ withPatternForSurface surface f = bracketR (Internal.patternCreateForSurface surface) (\pattern -> do status <- Internal.patternStatus pattern- liftIO $ Internal.patternDestroy pattern+-- liftIO $ Internal.patternDestroy pattern unless (status == StatusSuccess) $ fail =<< Internal.statusToString status) (\pattern -> f pattern)@@ -1059,7 +1192,7 @@ context <- ask bracketR (Internal.popGroup context) (\pattern -> do status <- Internal.patternStatus pattern- liftIO $ Internal.patternDestroy pattern+-- liftIO $ Internal.patternDestroy pattern unless (status == StatusSuccess) $ fail =<< Internal.statusToString status) f@@ -1082,14 +1215,14 @@ withLinearPattern x0 y0 x1 y1 f = bracketR (Internal.patternCreateLinear x0 y0 x1 y1) (\pattern -> do status <- Internal.patternStatus pattern- liftIO $ Internal.patternDestroy pattern+-- liftIO $ Internal.patternDestroy pattern unless (status == StatusSuccess) $ fail =<< Internal.statusToString status) (\pattern -> f pattern) -- | Creates a new radial gradient 'Pattern' between the two circles defined by--- @(x0, y0, c0)@ and @(x1, y1, c0)@. Before using the gradient pattern, a--- number of color stops should be defined using 'patternAddColorStopRGB'+-- @(x0, y0, radius0)@ and @(x1, y1, radius0)@. Before using the gradient pattern,+-- a number of color stops should be defined using 'patternAddColorStopRGB' -- or 'patternAddColorStopRGBA'. -- -- * Note: The coordinates here are in pattern space. For a new pattern,@@ -1099,7 +1232,7 @@ withRadialPattern :: Double -- ^ @cx0@ - x coordinate for the center of the start circle -> Double -- ^ @cy0@ - y coordinate for the center of the start circle- -> Double -- ^ @radius0@ - radius of the start cirle+ -> Double -- ^ @radius0@ - radius of the start circle -> Double -- ^ @cx1@ - x coordinate for the center of the end circle -> Double -- ^ @cy1@ - y coordinate for the center of the end circle -> Double -- ^ @radius1@ - radius of the end circle@@ -1108,7 +1241,7 @@ withRadialPattern cx0 cy0 radius0 cx1 cy1 radius1 f = bracketR (Internal.patternCreateRadial cx0 cy0 radius0 cx1 cy1 radius1) (\pattern -> do status <- Internal.patternStatus pattern- liftIO $ Internal.patternDestroy pattern+-- liftIO $ Internal.patternDestroy pattern unless (status == StatusSuccess) $ fail =<< Internal.statusToString status) (\pattern -> f pattern)@@ -1192,7 +1325,7 @@ patternSetExtend :: MonadIO m => Pattern -- ^ a 'Pattern'- -> Extend -- ^ an 'Extent'+ -> Extend -- ^ an 'Extend' enum -> m () patternSetExtend p e = liftIO $ Internal.patternSetExtend p e @@ -1209,7 +1342,7 @@ patternSetFilter :: MonadIO m => Pattern -- ^ a 'Pattern'- -> Filter -- ^ a 'Filter'+ -> Filter -- ^ a 'Filter' type -> m () patternSetFilter p f = liftIO $ Internal.patternSetFilter p f @@ -1222,6 +1355,220 @@ patternGetFilter p = liftIO $ Internal.patternGetFilter p ++#if CAIRO_CHECK_VERSION(1,12,0)++-- | Create a new mesh pattern.+--+-- Mesh patterns are tensor-product patch meshes (type 7 shadings in PDF).+-- Mesh patterns may also be used to create other types of shadings that are special cases+-- of tensor-product patch meshes such as Coons patch meshes (type 6 shading in PDF) and+-- Gouraud-shaded triangle meshes (type 4 and 5 shadings in PDF).+--+-- Refer to <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-pattern-create-mesh>+-- for a more detailed explanation of their usage, as this library merely provides a wrapper+-- around the underlying C API.+--+createMeshPattern ::+ MonadIO m =>+ m Pattern+createMeshPattern = liftIO$ Internal.patternCreateMesh+++-- | A convenience method that adds a patch to the mesh pattern in a single call.+--+-- It translates the provided path into calls to meshPatternMoveTo, meshPatternLineTo, and+-- meshPatternCurveTo, as appropriate. The control points are set using meshPatternSetControlPoint+-- and the corner colors are set using meshPatternSetCornerColorRGB.+-- The above operations are wrapped in calls to +-- At most the first 4 elements of the provided list will be used.+meshPatternAddPatchRGB ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> Path -- ^ a path to use as the boundary of the mesh pattern+ -> [(Double,Double)] -- ^ a list of control points as @(x,y)@ pairs+ -> [(Double,Double,Double)] -- ^ a list of corner colors, each of the form @(r,g,b)@+ -> m Status+meshPatternAddPatchRGB pat elems controlPoints colors = do+ meshPatternBeginPatch pat+ mapM_ (liftIO . Internal.convertPathElement pat) (take 4 elems)+ sequence_ $ zipWith (\(x,y) n -> meshPatternSetControlPoint pat n x y) (take 4 controlPoints) [0..3]+ sequence_ $ zipWith (\(r,g,b) n -> meshPatternSetCornerColorRGB pat n r g b) (take 4 colors) [0..3]+ meshPatternEndPatch pat+ liftIO$ Internal.patternStatus pat+++-- | as 'meshPatternAddPatchRGB', but the colors contain an alpha channel.+--+-- The corner colors are set using meshPatternSetCornerColorRGBA.+meshPatternAddPatchRGBA ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> Path -- ^ a path to use as the boundary of the mesh pattern+ -> [(Double,Double)] -- ^ a list of control points as @(x,y)@ pairs+ -> [(Double,Double,Double,Double)] -- ^ a list of corner colors, each of the form @(r,g,b,a)@+ -> m Status+meshPatternAddPatchRGBA pat elems controlPoints colors = do+ meshPatternBeginPatch pat+ mapM_ (liftIO . Internal.convertPathElement pat) (take 4 elems)+ sequence_ $ zipWith (\(x,y) n -> meshPatternSetControlPoint pat n x y) (take 4 controlPoints) [0..3]+ sequence_ $ zipWith (\(r,g,b,a) n -> meshPatternSetCornerColorRGBA pat n r g b a) (take 4 colors) [0..3]+ meshPatternEndPatch pat+ liftIO$ Internal.patternStatus pat+++-- | Begin a patch in a mesh pattern.+--+-- Safer, more convenient methods 'meshPatternAddPatchRGB' and 'meshPatternAddPatchRGBA' are provided+-- to avoid the begin/end idiom of the procedural language.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-begin-patch>+meshPatternBeginPatch ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> m ()+meshPatternBeginPatch p = liftIO$ Internal.meshPatternBeginPatch p++-- | Indicates the end of the current patch in a mesh pattern.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-end-patch>+meshPatternEndPatch ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> m ()+meshPatternEndPatch p = liftIO$ Internal.meshPatternEndPatch p+++-- | Define the first point of the current patch in a mesh pattern.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-move-to>+meshPatternMoveTo ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> Double -- ^ the @x@ coordinate of the point+ -> Double -- ^ the @y@ coordinate of the point+ -> m ()+meshPatternMoveTo p x y = liftIO$ Internal.meshPatternMoveTo p x y+++-- | Adds a line to the current patch from the current point to position @(x,y)@ in pattern-space coordinates.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-line-to>+meshPatternLineTo ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> Double -- ^ the @x@ coordinate of the endpoint+ -> Double -- ^ the @y@ coordinate of the endpoint+ -> m ()+meshPatternLineTo p x y = liftIO$ Internal.meshPatternLineTo p x y+++-- | Adds a cubic Bézier spline to the current patch from the current point to position @(x3,y3)@+-- in pattern-space coordinates, using @(x1,y1)@ and @(x2,y2)@ as the control points.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-curve-to>+meshPatternCurveTo ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> Double -- ^ @x1@+ -> Double -- ^ @y1@+ -> Double -- ^ @x2@+ -> Double -- ^ @y2@+ -> Double -- ^ @x3@+ -> Double -- ^ @y3@+ -> m ()+meshPatternCurveTo p x1 y1 x2 y2 x3 y3 = liftIO$ Internal.meshPatternCurveTo p x1 y1 x2 y2 x3 y3+++-- | Set an internal control point of the current mesh patch.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-set-control-point>+meshPatternSetControlPoint ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> Int -- ^ the number of the control point to modify, from 0 to 3+ -> Double -- ^ the @x@ coordinate of the control point+ -> Double -- ^ the @y@ coordinate of the control point+ -> m ()+meshPatternSetControlPoint p n x y = liftIO$ Internal.meshPatternSetControlPoint p n x y+++-- | Sets the color of a corner of the current patch in a mesh pattern.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-set-corner-color-rgb>+meshPatternSetCornerColorRGB ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> Int -- ^ the number of the corner to modify, from 0 to 3+ -> Double -- ^ the @r@ component of a color+ -> Double -- ^ the @g@ component of a color+ -> Double -- ^ the @b@ component of a color+ -> m ()+meshPatternSetCornerColorRGB p n r g b = liftIO$ Internal.meshPatternSetCornerColorRGB p n r g b+++-- | Sets the color of a corner of the current patch in a mesh pattern.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-set-corner-color-rgba>+meshPatternSetCornerColorRGBA ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> Int -- ^ the number of the corner to modify, from 0 to 3+ -> Double -- ^ the @r@ component of a color+ -> Double -- ^ the @g@ component of a color+ -> Double -- ^ the @b@ component of a color+ -> Double -- ^ the @a@ component of a color+ -> m ()+meshPatternSetCornerColorRGBA p n r g b a = liftIO$ Internal.meshPatternSetCornerColorRGBA p n r g b a+++-- | Gets the number of patches specified in the given mesh pattern.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-get-patch-count>+meshPatternGetPatchCount ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to query+ -> m (Status, Int)+meshPatternGetPatchCount p = liftIO$ Internal.meshPatternGetPatchCount p++-- | Gets path defining a specified patch from a mesh pattern.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-get-path>+meshPatternGetPath ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to query+ -> Int -- ^ the zero-indexed patch number+ -> m Path+meshPatternGetPath p n = liftIO$ Internal.meshPatternGetPath p n++-- | Gets the control point @point_num@ of patch @patch_num@ from a mesh pattern.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-get-control-point>+meshPatternGetControlPoint ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to query+ -> Int -- ^ @point_num@+ -> Int -- ^ @patch_num@+ -> m (Status, Double, Double)+meshPatternGetControlPoint p point_num patch_num = liftIO$ Internal.meshPatternGetControlPoint p point_num patch_num+++-- | Gets the color information in corner @corner_num@ of patch @patch_num@ from a mesh pattern.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-get-corner-color-rgba>+meshPatternGetCornerColorRGBA ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to query+ -> Int -- ^ @corner_num@+ -> Int -- ^ @patch_num@+ -> m (Status, Double, Double, Double, Double)+meshPatternGetCornerColorRGBA p corner_num patch_num = liftIO$ Internal.meshPatternGetCornerColorRGBA p corner_num patch_num++#endif++++ -- | Modifies the current transformation matrix (CTM) by translating the -- user-space origin by @(tx, ty)@. This offset is interpreted as a user-space -- coordinate according to the CTM in place before the new call to 'translate'.@@ -1330,7 +1677,8 @@ -- text layout library in addition to cairo. -- selectFontFace ::- String -- ^ @family@ - a font family name+ CairoString string+ => string -- ^ @family@ - a font family name -> FontSlant -- ^ @slant@ - the slant for the font -> FontWeight -- ^ @weight@ - the weight of the font -> Render ()@@ -1370,7 +1718,7 @@ -- setFontOptions :: FontOptions -> Render () setFontOptions = liftRender1 Internal.setFontOptions- + -- | A drawing operator that generates the shape from a string of Unicode -- characters, rendered according to the current font face, font size (font -- matrix), and font options.@@ -1392,7 +1740,8 @@ -- applications. -- showText ::- String -- ^ a string of text+ CairoString string+ => string -- ^ a string of text -> Render () showText = liftRender1 Internal.showText @@ -1415,7 +1764,8 @@ -- 'textExtentsYadvance' values. -- textExtents ::- String -- ^ a string of text+ CairoString string+ => string -- ^ a string of text -> Render TextExtents textExtents = liftRender1 Internal.textExtents @@ -1429,7 +1779,7 @@ -- | Allocates a new font options object copying the option values from @original@. -- fontOptionsCopy ::- MonadIO m => + MonadIO m => FontOptions -- ^ @original@ -> m FontOptions fontOptionsCopy a = liftIO $ Internal.fontOptionsCopy a@@ -1439,9 +1789,9 @@ -- @other@ onto @options@ with the operation of 'OperationOver'. -- fontOptionsMerge ::- MonadIO m => + MonadIO m => FontOptions -- ^ @options@- -> FontOptions -- ^ @other@ + -> FontOptions -- ^ @other@ -> m () fontOptionsMerge a b = liftIO $ Internal.fontOptionsMerge a b @@ -1462,7 +1812,7 @@ fontOptionsSetAntialias :: MonadIO m => FontOptions -> Antialias -> m () fontOptionsSetAntialias a b = liftIO $ Internal.fontOptionsSetAntialias a b --- | Gets the antialising mode for the font options object.+-- | Gets the antialiasing mode for the font options object. -- fontOptionsGetAntialias :: MonadIO m => FontOptions -> m Antialias fontOptionsGetAntialias a = liftIO $ Internal.fontOptionsGetAntialias a@@ -1530,10 +1880,10 @@ -- | Like 'withSimilarSurface' but creates a Surface that is managed by the--- Haskell memory manager rather than only being temporaily allocated. This+-- Haskell memory manager rather than only being temporarily allocated. This -- is more flexible and allows you to create surfaces that persist, which -- can be very useful, for example to cache static elements in an animation.--- +-- -- However you should be careful because surfaces can be expensive resources -- and the Haskell memory manager cannot guarantee when it will release them. -- You can manually release the resources used by a surface with@@ -1554,7 +1904,7 @@ -- surface (like a combination of 'withTargetSurface' and 'withSimilarSurface'). -- -- This is useful for drawing to a temporary surface and then compositing it--- into the main suface. For example, the following code draws to a temporary+-- into the main surface. For example, the following code draws to a temporary -- surface and then uses that as a mask: -- -- > renderWithSimilarSurface ContentAlpha 200 200 $ \tmpSurface -> do@@ -1635,7 +1985,7 @@ -- surface. -- surfaceMarkDirtyRectangle ::- MonadIO m => + MonadIO m => Surface -- ^ a 'Surface' -> Int -- ^ X coordinate of dirty rectangle -> Int -- ^ Y coordinate of dirty rectangle@@ -1656,7 +2006,7 @@ -- surface in a surface pattern. -- surfaceSetDeviceOffset ::- MonadIO m => + MonadIO m => Surface -- ^ a 'Surface' -> Double -- ^ the offset in the X direction, in device units -> Double -- ^ the offset in the Y direction, in device units@@ -1670,13 +2020,13 @@ formatStrideForWidth :: Format -- ^ format of pixels in the surface to create -> Int -- ^ width of the surface, in pixels- -> Int -- ^ the stride (number of bytes necessary to store one line) + -> Int -- ^ the stride (number of bytes necessary to store one line) -- or @-1@ if the format is invalid or the width is too large formatStrideForWidth = Internal.formatStrideForWidth #endif -- | Creates an image surface of the specified format and dimensions.--- The initial contents of the surface is undefined; you must explicitely+-- The initial contents of the surface is undefined; you must explicitly -- clear the buffer, using, for example, 'rectangle' and 'fill' if you want it -- cleared. --@@ -1696,7 +2046,7 @@ (\surface -> f surface) -- | Like 'withImageSurface' but creates a Surface that is managed by the--- Haskell memory manager rather than only being temporaily allocated. This+-- Haskell memory manager rather than only being temporarily allocated. This -- is more flexible and allows you to create surfaces that persist, which -- can be very useful, for example to cache static elements in an animation. --@@ -1800,7 +2150,7 @@ -- number of bytes between rows. -- -- * The returned array is a flat representation of a three dimensional array:--- x-coordiante, y-coordinate and several channels for each color. The+-- x-coordinate, y-coordinate and several channels for each color. The -- format depends on the 'Format' of the surface: -- -- 'FormatARGB32': each pixel is 32 bits with alpha in the upper 8 bits,@@ -1813,7 +2163,7 @@ -- 'FormatA8': each pixel is 8 bits holding an alpha value -- -- 'FormatA1': each pixel is one bit where pixels are packed into 32 bit--- quantities. The ordering depends on the endianes of the platform. On a+-- quantities. The ordering depends on the endianness of the platform. On a -- big-endian machine, the first pixel is in the uppermost bit, on a -- little-endian machine the first pixel is in the least-significant bit. --@@ -1836,7 +2186,7 @@ -- -- * The function will return an error if the surface is not an image -- surface or if 'surfaceFinish' has been called on the surface.--- +-- imageSurfaceGetPixels :: Storable e => Surface -> IO (SurfaceData Int e) imageSurfaceGetPixels pb = do pixPtr <- Internal.imageSurfaceGetData pb@@ -1963,7 +2313,7 @@ -> (Surface -> IO a) -- ^ an action that may use the surface. The surface is -- only valid within in this action. -> IO a-withPSSurface filename width height f = +withPSSurface filename width height f = bracket (Internal.psSurfaceCreate filename width height) (\surface -> do status <- Internal.surfaceStatus surface Internal.surfaceDestroy surface@@ -1993,8 +2343,14 @@ -- withSVGSurface :: FilePath -- ^ @filename@ - a filename for the SVG output (must be writable)- -> Double -- ^ width of the surface, in points (1 point == 1\/72.0 inch)- -> Double -- ^ height of the surface, in points (1 point == 1\/72.0 inch)+ -> Double -- ^ Width of the surface. The default unit is points (1 point == 1\/72.0 inch)+#if CAIRO_CHECK_VERSION(1,16,0)+ -- and can be changed with 'svgSurfaceSetDocumentUnit'.+#endif+ -> Double -- ^ Height of the surface. The default unit is points (1 point == 1\/72.0 inch)+#if CAIRO_CHECK_VERSION(1,16,0)+ -- and can be changed with 'svgSurfaceSetDocumentUnit'.+#endif -> (Surface -> IO a) -- ^ an action that may use the surface. The surface is -- only valid within in this action. -> IO a@@ -2005,6 +2361,16 @@ unless (status == StatusSuccess) $ Internal.statusToString status >>= fail) (\surface -> f surface)++#if CAIRO_CHECK_VERSION(1,16,0)+-- | Use the specified unit for the width and height of the generated SVG file.+svgSurfaceSetDocumentUnit :: MonadIO m => Surface -> SvgUnit -> m ()+svgSurfaceSetDocumentUnit s unit = liftIO $ Internal.svgSurfaceSetDocumentUnit s unit++-- | Get the specified unit for the width and height of the generated SVG file.+svgSurfaceGetDocumentUnit :: MonadIO m => Surface -> m SvgUnit+svgSurfaceGetDocumentUnit s = liftIO $ Internal.svgSurfaceGetDocumentUnit s+#endif #endif #if CAIRO_CHECK_VERSION(1,10,0)
Graphics/Rendering/Cairo/Internal/Drawing/Cairo.chs view
@@ -29,13 +29,13 @@ {#fun get_target as getTarget { unCairo `Cairo' } -> `Surface' mkSurface*#} {#fun push_group as ^ { unCairo `Cairo' } -> `()' #} {#fun push_group_with_content as ^ { unCairo `Cairo', cFromEnum `Content' } -> `()' #}-{#fun pop_group as ^ { unCairo `Cairo' } -> `Pattern' Pattern #}+{#fun pop_group as ^ { unCairo `Cairo' } -> `Pattern' mkPattern* #} {#fun pop_group_to_source as ^ { unCairo `Cairo' } -> `()' #} {#fun set_source_rgb as setSourceRGB { unCairo `Cairo', `Double', `Double', `Double' } -> `()'#} {#fun set_source_rgba as setSourceRGBA { unCairo `Cairo', `Double', `Double', `Double', `Double' } -> `()'#}-{#fun set_source as setSource { unCairo `Cairo', unPattern `Pattern' } -> `()'#}+{#fun set_source as setSource { unCairo `Cairo', withPattern* `Pattern' } -> `()'#} {#fun set_source_surface as setSourceSurface { unCairo `Cairo', withSurface* `Surface', `Double', `Double' } -> `()'#}-{#fun get_source as getSource { unCairo `Cairo' } -> `Pattern' Pattern#}+{#fun get_source as getSource { unCairo `Cairo' } -> `Pattern' clonePattern* #} {#fun set_antialias as setAntialias { unCairo `Cairo', cFromEnum `Antialias' } -> `()'#} {#fun get_antialias as getAntialias { unCairo `Cairo' } -> `Antialias' cToEnum#} setDash context xs offset = withArrayLen (map (cFloatConv) xs) $ \len ptr ->@@ -57,11 +57,12 @@ {#fun clip as clip { unCairo `Cairo' } -> `()'#} {#fun clip_preserve as clipPreserve { unCairo `Cairo' } -> `()'#} {#fun reset_clip as resetClip { unCairo `Cairo' } -> `()'#}+{#fun clip_extents as clipExtents { unCairo `Cairo', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv* } -> `()'#} {#fun fill as fill { unCairo `Cairo' } -> `()'#} {#fun fill_preserve as fillPreserve { unCairo `Cairo' } -> `()'#} {#fun fill_extents as fillExtents { unCairo `Cairo', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv* } -> `()'#} {#fun in_fill as inFill { unCairo `Cairo', `Double', `Double' } -> `Bool' cToBool#}-{#fun mask as mask { unCairo `Cairo', unPattern `Pattern' } -> `()'#}+{#fun mask as mask { unCairo `Cairo', withPattern* `Pattern' } -> `()'#} {#fun mask_surface as maskSurface { unCairo `Cairo', withSurface* `Surface', `Double', `Double' } -> `()'#} {#fun paint as paint { unCairo `Cairo' } -> `()'#} {#fun paint_with_alpha as paintWithAlpha { unCairo `Cairo', `Double' } -> `()'#}
Graphics/Rendering/Cairo/Internal/Drawing/Paths.chs view
@@ -17,11 +17,17 @@ import Foreign import Foreign.C+import Foreign.Marshal.Alloc (mallocBytes,finalizerFree) -import Graphics.Rendering.Cairo.Internal.Utilities (withUTFString)+import Graphics.Rendering.Cairo.Internal.Utilities (CairoString(..)) {#context lib="cairo" prefix="cairo"#} +{#pointer *path_t as CPath newtype#}+unPath :: CPath -> Ptr CPath+unPath (CPath p) = p++ {#fun get_current_point as getCurrentPoint { unCairo `Cairo', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv* } -> `()'#} {#fun new_path as newPath { unCairo `Cairo' } -> `()'#} {#fun close_path as closePath { unCairo `Cairo' } -> `()'#}@@ -31,7 +37,173 @@ {#fun line_to as lineTo { unCairo `Cairo', `Double', `Double' } -> `()'#} {#fun move_to as moveTo { unCairo `Cairo', `Double', `Double' } -> `()'#} {#fun rectangle as rectangle { unCairo `Cairo', `Double', `Double', `Double', `Double' } -> `()'#}-{#fun text_path as textPath { unCairo `Cairo', withUTFString* `String' } -> `()'#}+textPath :: CairoString string => Cairo -> string -> IO ()+textPath c string =+ withUTFString string $ \string' ->+ {# call text_path #}+ c string' {#fun rel_curve_to as relCurveTo { unCairo `Cairo', `Double', `Double', `Double', `Double', `Double', `Double' } -> `()'#} {#fun rel_line_to as relLineTo { unCairo `Cairo', `Double', `Double' } -> `()'#} {#fun rel_move_to as relMoveTo { unCairo `Cairo', `Double', `Double' } -> `()'#}+{#fun copy_path as copyPathC { unCairo `Cairo' } -> `CPath' CPath #}+{#fun copy_path_flat as copyPathFlatC { unCairo `Cairo' } -> `CPath' CPath #}+{#fun append_path as appendPathC { unCairo `Cairo', unPath `CPath' } -> `()' #}+{#fun path_destroy as pathDestroy { unPath `CPath' } -> `()' #}+{#fun path_extents as pathExtents { unCairo `Cairo', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv* } -> `()' #}++{#enum path_data_type_t as PathDataRecordType {underscoreToCase} deriving(Eq,Show)#}++data PathDataRecord+ = PathHeaderRecord PathDataRecordType Int+ | PathPointRecord Double Double+ deriving (Eq,Show)+++copyPath :: Cairo -> IO [PathElement]+copyPath ctx = do+ p <- copyPathC ctx+ xs <- pathToList p+ pathDestroy p+ return xs+++copyPathFlat :: Cairo -> IO [PathElement]+copyPathFlat ctx = do+ p <- copyPathFlatC ctx+ xs <- pathToList p+ pathDestroy p+ return xs+++appendPath :: Cairo -> [PathElement] -> IO ()+appendPath ctx es = do+ path <- mkPathPtr es+ appendPathC ctx path+ deallocPath path+++pathToList :: CPath -> IO [PathElement]+pathToList p = pathToList' <$> pathToList'' p++++pathToList' :: [PathDataRecord] -> [PathElement]+pathToList' [] = []+pathToList' ((PathHeaderRecord htype hlen):rs)+ | hlen >= 1 = let (mine,rest) = splitAt (hlen-1) rs+ in (consElem htype mine) : pathToList' rest+ | otherwise = error "invalid path data (invalid header length)"+pathToList' _ = error "invalid path data (expected header record)"++++pathToList'' :: CPath -> IO [PathDataRecord]+pathToList'' (CPath p) = do+ numdata <- {#get path_t->num_data #} p+ dptr <- {#get path_t->data#} p+ getPathData 0 (cIntConv numdata) (castPtr dptr)++ where size = {#sizeof path_data_t#}+ getPathData :: Int -> Int -> Ptr PathDataRecord -> IO [PathDataRecord]+ getPathData currpos numdata dptr+ | currpos < numdata = do+ let dptr' = dptr `plusPtr` (size*currpos)+ h@(PathHeaderRecord _ hlen) <- peekHeader dptr'+ ds <- peekPoints dptr' hlen+ rest <- getPathData (currpos+hlen) numdata dptr+ return$ h:(ds++rest)+ | otherwise = return []++ peekHeader :: Ptr PathDataRecord -> IO PathDataRecord+ peekHeader p = do+ -- the more intuitive statement+ -- htype <- {#get path_data_t->header.type #} p+ -- generates an error+ -- "CHS module contains errors: The phrase `type' is not allowed here."+ htype <- peekByteOff p 0 :: IO CInt+ hlen <- {#get path_data_t->header.length #} p+ return$ PathHeaderRecord (cToEnum htype) (cIntConv hlen)++ peekPoint :: Ptr PathDataRecord -> IO PathDataRecord+ peekPoint p = do+ x <- {#get path_data_t->point.x #} p+ y <- {#get path_data_t->point.y #} p+ return$ PathPointRecord (cFloatConv x) (cFloatConv y)++ peekPoints :: Ptr PathDataRecord -> Int -> IO [PathDataRecord]+ peekPoints p n = mapM (\i -> peekPoint (p `plusPtr` (size*i))) [1..(n-1)]++++getPts = \(PathPointRecord x y) -> (x,y)+++pokeRecord :: Ptr PathDataRecord -> PathDataRecord -> IO ()+pokeRecord ptr (PathHeaderRecord htype hlen) = do+ pokeByteOff ptr 0 (cFromEnum htype :: CInt) -- the member named 'type' of the header is misunderstood by c2hs (see above)+ {#set path_data_t->header.length #} ptr (cIntConv hlen)++pokeRecord ptr (PathPointRecord x y) = do+ {#set path_data_t->point.x #} ptr (cFloatConv x)+ {#set path_data_t->point.y #} ptr (cFloatConv y)++++++consElem :: PathDataRecordType -> [PathDataRecord] -> PathElement+consElem PathMoveTo ps+ | length ps < 1 = error "invalid path data (not enough points)"+ | otherwise = uncurry MoveTo $ getPts (ps!!0)+consElem PathLineTo ps+ | length ps < 1 = error "invalid path data (not enough points)"+ | otherwise = uncurry LineTo $ getPts (ps!!0)+consElem PathCurveTo ps+ | length ps < 3 = error "invalid path data (not enough points)"+ | otherwise = let ps' = map getPts (take 3 ps)+ in uncurry (uncurry (uncurry CurveTo (ps'!!0)) (ps'!!1)) (ps'!!2)+consElem PathClosePath ps = ClosePath+++consRecs :: PathElement -> [PathDataRecord]+consRecs (MoveTo x y) =+ [ PathHeaderRecord PathMoveTo 2, PathPointRecord x y]+consRecs (LineTo x y) =+ [ PathHeaderRecord PathLineTo 2, PathPointRecord x y]+consRecs (CurveTo x₀ y₀ x₁ y₁ x₂ y₂) =+ [ PathHeaderRecord PathCurveTo 4+ , PathPointRecord x₀ y₀+ , PathPointRecord x₁ y₁+ , PathPointRecord x₂ y₂+ ]+consRecs ClosePath = [PathHeaderRecord PathClosePath 1]++++mkPathPtr :: [PathElement] -> IO CPath+mkPathPtr es = do+ (dptr,numdata) <- mkDataPtr es+ ptr <- mallocBytes {#sizeof path_t#}+ {#set path_t->status #} ptr (cFromEnum StatusSuccess)+ {#set path_t->data #} ptr (castPtr dptr)+ {#set path_t->num_data #} ptr (cIntConv numdata)+ return (CPath ptr)++++mkDataPtr :: [PathElement] -> IO (Ptr PathDataRecord, Int)+mkDataPtr es = do+ let rs = concatMap consRecs es+ len = length rs+ size = {#sizeof path_data_t#}+ dptr <- mallocBytes (len*size) :: IO (Ptr PathDataRecord)+ mapM_ (\(r,i) -> pokeRecord (dptr `plusPtr` (i*size)) r) (zip rs [0..])+ return (dptr,len)+++deallocPath :: CPath -> IO ()+deallocPath (CPath ptr) = do+ dptr <- {#get path_t->data#} ptr+ free dptr+ free ptr+
Graphics/Rendering/Cairo/Internal/Drawing/Patterns.chs view
@@ -14,25 +14,68 @@ module Graphics.Rendering.Cairo.Internal.Drawing.Patterns where {#import Graphics.Rendering.Cairo.Types#}+{#import Graphics.Rendering.Cairo.Internal.Drawing.Paths #} ( CPath(..), pathDestroy, pathToList ) + import Foreign import Foreign.C {#context lib="cairo" prefix="cairo"#} -{#fun pattern_add_color_stop_rgb as patternAddColorStopRGB { unPattern `Pattern', `Double', `Double', `Double', `Double' } -> `()'#}-{#fun pattern_add_color_stop_rgba as patternAddColorStopRGBA { unPattern `Pattern', `Double', `Double', `Double', `Double', `Double' } -> `()'#}-{#fun pattern_create_rgb as patternCreateRGB { `Double', `Double', `Double' } -> `Pattern' Pattern#}-{#fun pattern_create_rgba as patternCreateRGBA { `Double', `Double', `Double', `Double' } -> `Pattern' Pattern#}-{#fun pattern_create_for_surface as patternCreateForSurface { withSurface* `Surface' } -> `Pattern' Pattern#}-{#fun pattern_create_linear as patternCreateLinear { `Double', `Double', `Double', `Double' } -> `Pattern' Pattern#}-{#fun pattern_create_radial as patternCreateRadial { `Double', `Double', `Double', `Double', `Double', `Double' } -> `Pattern' Pattern#}-{#fun pattern_destroy as patternDestroy { unPattern `Pattern' } -> `()'#}-{#fun pattern_reference as patternReference { unPattern `Pattern' } -> `Pattern' Pattern#}-{#fun pattern_status as patternStatus { unPattern `Pattern' } -> `Status' cToEnum#}-{#fun pattern_set_extend as patternSetExtend { unPattern `Pattern', cFromEnum `Extend' } -> `()'#}-{#fun pattern_get_extend as patternGetExtend { unPattern `Pattern' } -> `Extend' cToEnum#}-{#fun pattern_set_filter as patternSetFilter { unPattern `Pattern', cFromEnum `Filter' } -> `()'#}-{#fun pattern_get_filter as patternGetFilter { unPattern `Pattern' } -> `Filter' cToEnum#}-{#fun pattern_set_matrix as patternSetMatrix { unPattern `Pattern', `Matrix' } -> `()'#}-{#fun pattern_get_matrix as patternGetMatrix { unPattern `Pattern', alloca- `Matrix' peek*} -> `()'#}+{#fun pattern_create_rgb as patternCreateRGB { `Double', `Double', `Double' } -> `Pattern' mkPattern* #}+{#fun pattern_create_rgba as patternCreateRGBA { `Double', `Double', `Double', `Double' } -> `Pattern' mkPattern* #}+{#fun pattern_get_rgba as patternGetRGBA { withPattern* `Pattern', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv* } -> `Status' cToEnum #}++{#fun pattern_create_linear as patternCreateLinear { `Double', `Double', `Double', `Double' } -> `Pattern' mkPattern* #}+{#fun pattern_create_radial as patternCreateRadial { `Double', `Double', `Double', `Double', `Double', `Double' } -> `Pattern' mkPattern* #}+{#fun pattern_add_color_stop_rgb as patternAddColorStopRGB { withPattern* `Pattern', `Double', `Double', `Double', `Double' } -> `()' #}+{#fun pattern_add_color_stop_rgba as patternAddColorStopRGBA { withPattern* `Pattern', `Double', `Double', `Double', `Double', `Double' } -> `()'#}+{#fun pattern_get_color_stop_count as patternGetColorStopCount { withPattern* `Pattern', alloca- `Int' peekIntConv* } -> `Status' cToEnum #}+{#fun pattern_get_color_stop_rgba as patternGetColorStopRGBA { withPattern* `Pattern', `Int', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*} -> `Status' cToEnum #}+{#fun pattern_get_linear_points as patternGetLinearPoints { withPattern* `Pattern', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv* } -> `Status' cToEnum #}+{#fun pattern_get_radial_circles as patternGetRadialCircles { withPattern* `Pattern', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv* } -> `Status' cToEnum #}++{#fun pattern_create_for_surface as patternCreateForSurface { withSurface* `Surface' } -> `Pattern' mkPattern* #}++{#fun pattern_status as patternStatus { withPattern* `Pattern' } -> `Status' cToEnum#}+{#fun pattern_get_type as patternGetType { withPattern* `Pattern' } -> `PatternType' cToEnum #}++{#fun pattern_set_extend as patternSetExtend { withPattern* `Pattern', cFromEnum `Extend' } -> `()'#}+{#fun pattern_get_extend as patternGetExtend { withPattern* `Pattern' } -> `Extend' cToEnum#}+{#fun pattern_set_filter as patternSetFilter { withPattern* `Pattern', cFromEnum `Filter' } -> `()'#}+{#fun pattern_get_filter as patternGetFilter { withPattern* `Pattern' } -> `Filter' cToEnum#}+{#fun pattern_set_matrix as patternSetMatrix { withPattern* `Pattern', `Matrix' } -> `()'#}+{#fun pattern_get_matrix as patternGetMatrix { withPattern* `Pattern', alloca- `Matrix' peek*} -> `()'#}+++-- support for mesh patterns / tensor product patches+#if CAIRO_CHECK_VERSION(1,12,0)+{#fun pattern_create_mesh as patternCreateMesh { } -> `Pattern' mkPattern* #}+{#fun mesh_pattern_begin_patch as meshPatternBeginPatch { withPattern* `Pattern' } -> `()' #}+{#fun mesh_pattern_end_patch as meshPatternEndPatch { withPattern* `Pattern' } -> `()' #}+{#fun mesh_pattern_move_to as meshPatternMoveTo { withPattern* `Pattern', `Double', `Double' } -> `()' #}+{#fun mesh_pattern_line_to as meshPatternLineTo { withPattern* `Pattern', `Double', `Double' } -> `()' #}+{#fun mesh_pattern_curve_to as meshPatternCurveTo { withPattern* `Pattern', `Double', `Double', `Double', `Double', `Double', `Double' } -> `()' #}+{#fun mesh_pattern_set_control_point as meshPatternSetControlPoint { withPattern* `Pattern', fromIntegral `Int', `Double', `Double' } -> `()' #}+{#fun mesh_pattern_set_corner_color_rgb as meshPatternSetCornerColorRGB { withPattern* `Pattern', fromIntegral `Int', `Double', `Double', `Double' } -> `()' #}+{#fun mesh_pattern_set_corner_color_rgba as meshPatternSetCornerColorRGBA { withPattern* `Pattern', fromIntegral `Int', `Double', `Double', `Double', `Double'} -> `()' #}+{#fun mesh_pattern_get_patch_count as meshPatternGetPatchCount { withPattern* `Pattern', alloca- `Int' peekIntConv* } -> `Status' cToEnum #}+{#fun mesh_pattern_get_path as meshPatternGetPathC { withPattern* `Pattern', fromIntegral `Int' } -> `CPath' CPath #}+{#fun mesh_pattern_get_control_point as meshPatternGetControlPoint { withPattern* `Pattern', fromIntegral `Int', fromIntegral `Int', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv* } -> `Status' cToEnum #}+{#fun mesh_pattern_get_corner_color_rgba as meshPatternGetCornerColorRGBA { withPattern* `Pattern', fromIntegral `Int', fromIntegral `Int', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv* } -> `Status' cToEnum #}++meshPatternGetPath :: Pattern -> Int -> IO [PathElement]+meshPatternGetPath pat n = do+ path <- meshPatternGetPathC pat n+ xs <- pathToList path+ pathDestroy path+ return xs++convertPathElement :: Pattern -> PathElement -> IO ()+convertPathElement pat (MoveTo x y) = meshPatternMoveTo pat x y+convertPathElement pat (LineTo x y) = meshPatternLineTo pat x y+convertPathElement pat (CurveTo x1 y1 x2 y2 x3 y3) = meshPatternCurveTo pat x1 y1 x2 y2 x3 y3+convertPathElement _ ClosePath = return ()++#endif+
Graphics/Rendering/Cairo/Internal/Drawing/Text.chs view
@@ -15,18 +15,37 @@ {#import Graphics.Rendering.Cairo.Types#} -import Graphics.Rendering.Cairo.Internal.Utilities (withUTFString)+import Graphics.Rendering.Cairo.Internal.Utilities (CairoString(..)) import Foreign import Foreign.C {#context lib="cairo" prefix="cairo"#} -{#fun select_font_face as selectFontFace { unCairo `Cairo', `String', cFromEnum `FontSlant', cFromEnum `FontWeight' } -> `()'#}+selectFontFace :: CairoString string => Cairo -> string -> FontSlant -> FontWeight -> IO ()+selectFontFace c string slant weight =+ withUTFString string $ \string' ->+ {# call select_font_face #}+ c string' (cFromEnum slant) (cFromEnum weight)+ {#fun set_font_size as setFontSize { unCairo `Cairo', `Double' } -> `()'#} {#fun set_font_matrix as setFontMatrix { unCairo `Cairo', `Matrix' } -> `()'#} {#fun get_font_matrix as getFontMatrix { unCairo `Cairo', alloca- `Matrix' peek*} -> `()'#} {#fun set_font_options as setFontOptions { unCairo `Cairo', withFontOptions* `FontOptions' } -> `()'#}-{#fun show_text as showText { unCairo `Cairo', withUTFString* `String' } -> `()'#}++showText :: CairoString string => Cairo -> string -> IO ()+showText c string =+ withUTFString string $ \string' ->+ {# call show_text #}+ c string'+ {#fun font_extents as fontExtents { unCairo `Cairo', alloca- `FontExtents' peek* } -> `()'#}-{#fun text_extents as textExtents { unCairo `Cairo', withUTFString* `String', alloca- `TextExtents' peek* } -> `()'#}++textExtents :: CairoString string => Cairo -> string -> IO TextExtents+textExtents c string =+ withUTFString string $ \string' ->+ alloca $ \result -> do+ {# call text_extents #}+ c string' result+ peek result+
Graphics/Rendering/Cairo/Internal/Drawing/Transformations.chs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Module : Graphics.Rendering.Cairo.Internal.Drawing.Tranformations+-- Module : Graphics.Rendering.Cairo.Internal.Drawing.Transformations -- Copyright : (c) Paolo Martini 2005 -- License : BSD-style (see cairo/COPYRIGHT) --
Graphics/Rendering/Cairo/Internal/Surfaces/SVG.chs view
@@ -25,4 +25,9 @@ {#fun svg_surface_create as svgSurfaceCreate { withCAString* `FilePath', `Double', `Double' } -> `Surface' mkSurface*#} +#if CAIRO_CHECK_VERSION(1,16,0)+{#fun svg_surface_set_document_unit as svgSurfaceSetDocumentUnit { withSurface* `Surface', cFromEnum `SvgUnit' } -> `()'#}+{#fun svg_surface_get_document_unit as svgSurfaceGetDocumentUnit { withSurface* `Surface' } -> `SvgUnit' cToEnum#}+#endif+ #endif
Graphics/Rendering/Cairo/Internal/Utilities.chs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Cairo.Internal.Utilities@@ -15,14 +16,18 @@ {#import Graphics.Rendering.Cairo.Types#} -import Foreign+import Foreign hiding (unsafePerformIO) import Foreign.C-#if __GLASGOW_HASKELL__ >= 707+-- TODO work around cpphs https://ghc.haskell.org/trac/ghc/ticket/13553+#if __GLASGOW_HASKELL__ >= 707 || __GLASGOW_HASKELL__ == 0 import System.IO.Unsafe (unsafePerformIO) #endif import Codec.Binary.UTF8.String import Data.Char (ord, chr)+import Data.Text (Text)+import Data.ByteString (useAsCString)+import qualified Data.Text.Encoding as T (encodeUtf8) {#context lib="cairo" prefix="cairo"#} @@ -30,5 +35,11 @@ {#fun pure version as version {} -> `Int'#} {#fun pure version_string as versionString {} -> `String'#} -withUTFString :: String -> (CString -> IO a) -> IO a-withUTFString = withCAString . encodeString+class CairoString s where+ withUTFString :: s -> (CString -> IO a) -> IO a++instance CairoString [Char] where+ withUTFString = withCAString . encodeString++instance CairoString Text where+ withUTFString s = useAsCString (T.encodeUtf8 s)
Graphics/Rendering/Cairo/Types.chs view
@@ -19,7 +19,7 @@ , Matrix(Matrix), MatrixPtr , Cairo(Cairo), unCairo , Surface(Surface), withSurface, mkSurface, manageSurface- , Pattern(Pattern), unPattern+ , Pattern(Pattern), withPattern, mkPattern, clonePattern , Status(..) , Operator(..) , Antialias(..)@@ -39,7 +39,7 @@ , HintStyle(..) , HintMetrics(..) , FontOptions(..), withFontOptions, mkFontOptions- , Path(..), unPath+ , Path, PathElement(..) #if CAIRO_CHECK_VERSION(1,10,0) , RectangleInt(..) , RegionOverlap(..)@@ -49,6 +49,13 @@ , Format(..) , Extend(..) , Filter(..)+ , SurfaceType(..)+ , PatternType(..)+#ifdef CAIRO_HAS_SVG_SURFACE+#if CAIRO_CHECK_VERSION(1,16,0)+ , SvgUnit(..)+#endif+#endif , cIntConv , cFloatConv@@ -58,6 +65,7 @@ , cFromEnum , peekFloatConv , withFloatConv+ , peekIntConv ) where @@ -92,14 +100,34 @@ foreign import ccall unsafe "&cairo_surface_destroy" surfaceDestroy :: FinalizerPtr Surface ++{#enum cairo_surface_type_t as SurfaceType {underscoreToCase} deriving(Eq,Read,Show) #}+ -- | Patterns can be simple solid colors, various kinds of gradients or -- bitmaps. The current pattern for a 'Render' context is used by the 'stroke', -- 'fill' and paint operations. These operations composite the current pattern -- with the target surface using the currently selected 'Operator'. ---{#pointer *pattern_t as Pattern newtype#}-unPattern (Pattern x) = x+{#pointer *pattern_t as Pattern foreign newtype#}+withPattern (Pattern x) = withForeignPtr x +foreign import ccall unsafe "&cairo_pattern_destroy"+ patternDestroy :: FinalizerPtr Pattern++mkPattern :: Ptr Pattern -> IO Pattern+mkPattern ptr = Pattern <$> newForeignPtr patternDestroy ptr++clonePattern :: Ptr Pattern -> IO Pattern+clonePattern ptr = patternReference ptr >>= mkPattern++{#fun pattern_reference as patternReference { castPtr `Ptr Pattern' } -> `Ptr Pattern' castPtr #}+++++{#enum cairo_pattern_type_t as PatternType {underscoreToCase} deriving(Eq,Read,Show) #}++ -- | Cairo status. -- -- * 'Status' is used to indicate errors that can occur when using@@ -262,7 +290,7 @@ -- with red at the top -- -- ['SubpixelOrderVbgr'] Subpixel elements are arranged vertically--- with blue at the top +-- with blue at the top -- {#enum subpixel_order_t as SubpixelOrder {underscoreToCase} deriving(Eq,Show)#} @@ -320,17 +348,14 @@ fontOptionsDestroy :: FinalizerPtr FontOptions -- XXX: pathToList :: Path -> [PathData]--- +-- -- http://cairographics.org/manual/bindings-path.html--- --- {#enum path_data_type_t as PathDataType {underscoreToCase}#}--- --- type Point = (Double, Double)--- data PathData = PathMoveTo Point--- | PathLineTo Point--- | PathCurveTo Point Point Point--- | PathClose-+--+data PathElement = MoveTo Double Double+ | LineTo Double Double+ | CurveTo Double Double Double Double Double Double+ | ClosePath+ deriving (Eq, Read, Show) -- | A Cairo path. -- -- * A path is a sequence of drawing operations that are accumulated until@@ -338,9 +363,9 @@ -- useful when drawing lines with special join styles and -- 'Graphics.Rendering.Cairo.closePath'. ---{#pointer *path_t as Path newtype#}-unPath (Path x) = x+type Path = [PathElement] + #if CAIRO_CHECK_VERSION(1,10,0) {#pointer *rectangle_int_t as RectangleIntPtr -> RectangleInt#}@@ -391,18 +416,29 @@ {#enum content_t as Content {underscoreToCase} deriving(Eq,Show)#} -data Format = FormatARGB32- | FormatRGB24- | FormatA8- | FormatA1- deriving (Enum,Show,Eq)+{#enum format_t as Format {CAIRO_FORMAT_ARGB32 as FormatARGB32,+ CAIRO_FORMAT_RGB24 as FormatRGB24,+ CAIRO_FORMAT_A8 as FormatA8,+ CAIRO_FORMAT_A1 as FormatA1,+ CAIRO_FORMAT_RGB16_565 as FormatRGB16565,+ CAIRO_FORMAT_RGB30 as FormatRGB30+ } deriving (Eq,Show)+#} + -- | FIXME: We should find out about this. {#enum extend_t as Extend {underscoreToCase} deriving(Eq,Show)#} -- | Specify how filtering is done. {#enum filter_t as Filter {underscoreToCase} deriving(Eq,Show)#} +#ifdef CAIRO_HAS_SVG_SURFACE+#if CAIRO_CHECK_VERSION(1,16,0)+-- | Specify the unit used in SVG surfaces.+{#enum svg_unit_t as SvgUnit {underscoreToCase} deriving(Eq, Show) #}+#endif+#endif+ -- Marshalling functions {-# INLINE cIntConv #-}@@ -440,3 +476,7 @@ {-# INLINE withArrayFloatConv #-} withArrayFloatConv :: (Storable b, RealFloat a, RealFloat b) => [a] -> (Ptr b -> IO b1) -> IO b1 withArrayFloatConv = withArray . map (cFloatConv)++{-# INLINE peekIntConv #-}+peekIntConv :: (Storable a, Integral a, Integral b) => Ptr a -> IO b+peekIntConv = liftM cIntConv . peek
− Gtk2HsSetup.hs
@@ -1,472 +0,0 @@-{-# LANGUAGE CPP, ViewPatterns #-}--#ifndef CABAL_VERSION_CHECK-#error This module has to be compiled via the Setup.hs program which generates the gtk2hs-macros.h file-#endif---- | Build a Gtk2hs package.----module Gtk2HsSetup ( - gtk2hsUserHooks, - getPkgConfigPackages, - checkGtk2hsBuildtools,- typeGenProgram,- signalGenProgram,- c2hsLocal- ) where--import Distribution.Simple-import Distribution.Simple.PreProcess-import Distribution.InstalledPackageInfo ( importDirs,- showInstalledPackageInfo,- libraryDirs,- extraLibraries,- extraGHCiLibraries )-import Distribution.Simple.PackageIndex ( lookupInstalledPackageId )-import Distribution.PackageDescription as PD ( PackageDescription(..),- updatePackageDescription,- BuildInfo(..),- emptyBuildInfo, allBuildInfo,- Library(..),- libModules, hasLibs)-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(withPackageDB, buildDir, localPkgDescr, installedPkgs, withPrograms),- InstallDirs(..),- componentPackageDeps,- absoluteInstallDirs)-import Distribution.Simple.Compiler ( Compiler(..) )-import Distribution.Simple.Program (- Program(..), ConfiguredProgram(..),- rawSystemProgramConf, rawSystemProgramStdoutConf, programName, programPath,- c2hsProgram, pkgConfigProgram, gccProgram, requireProgram, ghcPkgProgram,- simpleProgram, lookupProgram, rawSystemProgramStdout, ProgArg)-import Distribution.ModuleName ( ModuleName, components, toFilePath )-import Distribution.Simple.Utils-import Distribution.Simple.Setup (CopyFlags(..), InstallFlags(..), CopyDest(..),- defaultCopyFlags, ConfigFlags(configVerbosity),- fromFlag, toFlag, RegisterFlags(..), flagToMaybe,- fromFlagOrDefault, defaultRegisterFlags)-import Distribution.Simple.BuildPaths ( autogenModulesDir )-import Distribution.Simple.Install ( install )-import Distribution.Simple.Register ( generateRegistrationInfo, registerPackage )-import Distribution.Text ( simpleParse, display )-import System.FilePath-import System.Exit (exitFailure)-import System.Directory ( doesFileExist, getDirectoryContents, doesDirectoryExist )-import Distribution.Version (Version(..))-import Distribution.Verbosity-import Control.Monad (when, unless, filterM, liftM, forM, forM_)-import Data.Maybe ( isJust, isNothing, fromMaybe, maybeToList, catMaybes )-import Data.List (isPrefixOf, isSuffixOf, nub, minimumBy, stripPrefix, tails )-import Data.Ord as Ord (comparing)-import Data.Char (isAlpha, isNumber)-import qualified Data.Map as M-import qualified Data.Set as S-import qualified Distribution.Simple.LocalBuildInfo as LBI-import Distribution.Simple.Compiler (compilerVersion)--import Control.Applicative ((<$>))--#if CABAL_VERSION_CHECK(1,17,0)-import Distribution.Simple.Program.Find ( defaultProgramSearchPath )-onDefaultSearchPath f a b = f a b defaultProgramSearchPath-libraryConfig lbi = case [clbi | (LBI.CLibName, clbi, _) <- LBI.componentsConfigs lbi] of- [clbi] -> Just clbi- _ -> Nothing-#else-onDefaultSearchPath = id-libraryConfig = LBI.libraryConfig-#endif---- the name of the c2hs pre-compiled header file-precompFile = "precompchs.bin"--gtk2hsUserHooks = simpleUserHooks {- hookedPrograms = [typeGenProgram, signalGenProgram, c2hsLocal],- hookedPreProcessors = [("chs", ourC2hs)],- confHook = \pd cf ->- (fmap adjustLocalBuildInfo (confHook simpleUserHooks pd cf)),- postConf = \args cf pd lbi -> do- genSynthezisedFiles (fromFlag (configVerbosity cf)) pd lbi- postConf simpleUserHooks args cf pd lbi,- buildHook = \pd lbi uh bf -> fixDeps pd >>= \pd ->- buildHook simpleUserHooks pd lbi uh bf,- copyHook = \pd lbi uh flags -> copyHook simpleUserHooks pd lbi uh flags >>- installCHI pd lbi (fromFlag (copyVerbosity flags)) (fromFlag (copyDest flags)),- instHook = \pd lbi uh flags ->-#if defined(mingw32_HOST_OS) || defined(__MINGW32__)- installHook pd lbi uh flags >>- installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest,- regHook = registerHook-#else- instHook simpleUserHooks pd lbi uh flags >>- installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest-#endif- }----------------------------------------------------------------------------------- Lots of stuff for windows ghci support---------------------------------------------------------------------------------getDlls :: [FilePath] -> IO [FilePath]-getDlls dirs = filter ((== ".dll") . takeExtension) . concat <$>- mapM getDirectoryContents dirs--fixLibs :: [FilePath] -> [String] -> [String]-fixLibs dlls = concatMap $ \ lib ->- case filter (isLib lib) dlls of- dlls@(_:_) -> [dropExtension (pickDll dlls)]- _ -> if lib == "z" then [] else [lib]- where- -- If there are several .dll files matching the one we're after then we- -- just have to guess. For example for recent Windows cairo builds we get- -- libcairo-2.dll libcairo-gobject-2.dll libcairo-script-interpreter-2.dll- -- Our heuristic is to pick the one with the shortest name.- -- Yes this is a hack but the proper solution is hard: we would need to- -- parse the .a file and see which .dll file(s) it needed to link to.- pickDll = minimumBy (Ord.comparing length)- isLib lib dll =- case stripPrefix ("lib"++lib) dll of- Just ('.':_) -> True- Just ('-':n:_) | isNumber n -> True- _ -> False- --- The following code is a big copy-and-paste job from the sources of--- Cabal 1.8 just to be able to fix a field in the package file. Yuck.--installHook :: PackageDescription -> LocalBuildInfo- -> UserHooks -> InstallFlags -> IO ()-installHook pkg_descr localbuildinfo _ flags = do- let copyFlags = defaultCopyFlags {- copyDistPref = installDistPref flags,- copyDest = toFlag NoCopyDest,- copyVerbosity = installVerbosity flags- }- install pkg_descr localbuildinfo copyFlags- let registerFlags = defaultRegisterFlags {- regDistPref = installDistPref flags,- regInPlace = installInPlace flags,- regPackageDB = installPackageDB flags,- regVerbosity = installVerbosity flags- }- when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags--registerHook :: PackageDescription -> LocalBuildInfo- -> UserHooks -> RegisterFlags -> IO ()-registerHook pkg_descr localbuildinfo _ flags =- if hasLibs pkg_descr- then register pkg_descr localbuildinfo flags- else setupMessage verbosity- "Package contains no library to register:" (packageId pkg_descr)- where verbosity = fromFlag (regVerbosity flags)--register :: PackageDescription -> LocalBuildInfo- -> RegisterFlags -- ^Install in the user's database?; verbose- -> IO ()-register pkg@(library -> Just lib )- lbi@(libraryConfig -> Just clbi) regFlags- = do-- installedPkgInfoRaw <- generateRegistrationInfo- verbosity pkg lib lbi clbi inplace distPref-- dllsInScope <- getSearchPath >>= (filterM doesDirectoryExist) >>= getDlls- let libs = fixLibs dllsInScope (extraLibraries installedPkgInfoRaw)- installedPkgInfo = installedPkgInfoRaw {- extraGHCiLibraries = libs }-- -- Three different modes:- case () of- _ | modeGenerateRegFile -> die "Generate Reg File not supported"- | modeGenerateRegScript -> die "Generate Reg Script not supported"- | otherwise -> registerPackage verbosity- installedPkgInfo pkg lbi inplace-#if CABAL_VERSION_CHECK(1,10,0)- packageDbs-#else- packageDb-#endif-- where- modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))- modeGenerateRegScript = fromFlag (regGenScript regFlags)- inplace = fromFlag (regInPlace regFlags)- packageDbs = nub $ withPackageDB lbi- ++ maybeToList (flagToMaybe (regPackageDB regFlags))- packageDb = registrationPackageDB packageDbs- distPref = fromFlag (regDistPref regFlags)- verbosity = fromFlag (regVerbosity regFlags)--register _ _ regFlags = notice verbosity "No package to register"- where- verbosity = fromFlag (regVerbosity regFlags)------------------------------------------------------------------------------------ This is a hack for Cabal-1.8, It is not needed in Cabal-1.9.1 or later---------------------------------------------------------------------------------adjustLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo-adjustLocalBuildInfo lbi =- let extra = (Just libBi, [])- libBi = emptyBuildInfo { includeDirs = [ autogenModulesDir lbi- , buildDir lbi ] }- in lbi { localPkgDescr = updatePackageDescription extra (localPkgDescr lbi) }----------------------------------------------------------------------------------- Processing .chs files with our local c2hs.---------------------------------------------------------------------------------ourC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor-ourC2hs bi lbi = PreProcessor {- platformIndependent = False,- runPreProcessor = runC2HS bi lbi-}--runC2HS :: BuildInfo -> LocalBuildInfo ->- (FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO ()-runC2HS bi lbi (inDir, inFile) (outDir, outFile) verbosity = do- -- have the header file name if we don't have the precompiled header yet- header <- case lookup "x-c2hs-header" (customFieldsBI bi) of- Just h -> return h- Nothing -> die ("Need x-c2hs-Header definition in the .cabal Library section "++- "that sets the C header file to process .chs.pp files.")-- -- c2hs will output files in out dir, removing any leading path of the input file.- -- Thus, append the dir of the input file to the output dir.- let (outFileDir, newOutFile) = splitFileName outFile- let newOutDir = outDir </> outFileDir- -- additional .chi files might be needed that other packages have installed;- -- we assume that these are installed in the same place as .hi files- let chiDirs = [ dir |- ipi <- maybe [] (map fst . componentPackageDeps) (libraryConfig lbi),- dir <- maybe [] importDirs (lookupInstalledPackageId (installedPkgs lbi) ipi) ]- (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)- rawSystemProgramConf verbosity c2hsLocal (withPrograms lbi) $- map ("--include=" ++) (outDir:chiDirs)- ++ [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ]- ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi]- ++ ["--output-dir=" ++ newOutDir,- "--output=" ++ newOutFile,- "--precomp=" ++ buildDir lbi </> precompFile,- header, inDir </> inFile]--getCppOptions :: BuildInfo -> LocalBuildInfo -> [String]-getCppOptions bi lbi- = nub $- ["-I" ++ dir | dir <- PD.includeDirs bi]- ++ [opt | opt@('-':c:_) <- PD.cppOptions bi ++ PD.ccOptions bi, c `elem` "DIU"]- ++ ["-D__GLASGOW_HASKELL__="++show (ghcDefine . ghcVersion . compilerId $ LBI.compiler lbi)]- where- ghcDefine (v1:v2:_) = v1 * 100 + v2- ghcDefine _ = __GLASGOW_HASKELL__-- ghcVersion :: CompilerId -> [Int]--- This version is nicer, but we need to know the Cabal version that includes the new CompilerId--- #if CABAL_VERSION_CHECK(1,19,2)--- ghcVersion (CompilerId GHC v _) = versionBranch v--- ghcVersion (CompilerId _ _ (Just c)) = ghcVersion c--- #else--- ghcVersion (CompilerId GHC v) = versionBranch v--- #endif--- ghcVersion _ = []--- This version should work fine for now- ghcVersion = concat . take 1 . map (read . (++"]") . takeWhile (/=']')) . catMaybes- . map (stripPrefix "CompilerId GHC (Version {versionBranch = ") . tails . show--installCHI :: PackageDescription -- ^information from the .cabal file- -> LocalBuildInfo -- ^information from the configure step- -> Verbosity -> CopyDest -- ^flags sent to copy or install- -> IO ()-installCHI pkg@PD.PackageDescription { library = Just lib } lbi verbosity copydest = do- let InstallDirs { libdir = libPref } = absoluteInstallDirs pkg lbi copydest- -- cannot use the recommended 'findModuleFiles' since it fails if there exists- -- a modules that does not have a .chi file- mFiles <- mapM (findFileWithExtension' ["chi"] [buildDir lbi] . toFilePath)- (PD.libModules lib)- - let files = [ f | Just f <- mFiles ]- installOrdinaryFiles verbosity libPref files-- -installCHI _ _ _ _ = return ()----------------------------------------------------------------------------------- Generating the type hierarchy and signal callback .hs files.---------------------------------------------------------------------------------typeGenProgram :: Program-typeGenProgram = simpleProgram "gtk2hsTypeGen"--signalGenProgram :: Program-signalGenProgram = simpleProgram "gtk2hsHookGenerator"--c2hsLocal :: Program-c2hsLocal = (simpleProgram "gtk2hsC2hs") {- programFindVersion = findProgramVersion "--version" $ \str ->- -- Invoking "gtk2hsC2hs --version" gives a string like:- -- C->Haskell Compiler, version 0.13.4 (gtk2hs branch) "Bin IO", 13 Nov 2004- case words str of- (_:_:_:ver:_) -> ver- _ -> ""- }---genSynthezisedFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()-genSynthezisedFiles verb pd lbi = do-- cPkgs <- getPkgConfigPackages verb lbi pd-- let xList = maybe [] (customFieldsBI . libBuildInfo) (library pd)- ++customFieldsPD pd- typeOpts :: String -> [ProgArg]- typeOpts tag = concat [ map (\val -> '-':'-':drop (length tag) field++'=':val) (words content)- | (field,content) <- xList,- tag `isPrefixOf` field,- field /= (tag++"file")]- ++ [ "--tag=" ++ tag- | PackageIdentifier name (Version (major:minor:_) _) <- cPkgs- , let name' = filter isAlpha (display name)- , tag <- name'- : [ name' ++ "-" ++ show major ++ "." ++ show digit- | digit <- [0,2..minor] ]- ]-- signalsOpts :: [ProgArg]- signalsOpts = concat [ map (\val -> '-':'-':drop 10 field++'=':val) (words content)- | (field,content) <- xList,- "x-signals-" `isPrefixOf` field,- field /= "x-signals-file"]-- genFile :: Program -> [ProgArg] -> FilePath -> IO ()- genFile prog args outFile = do- res <- rawSystemProgramStdoutConf verb prog (withPrograms lbi) args- rewriteFile outFile res-- forM_ (filter (\(tag,_) -> "x-types-" `isPrefixOf` tag && "file" `isSuffixOf` tag) xList) $- \(fileTag, f) -> do- let tag = reverse (drop 4 (reverse fileTag))- info verb ("Ensuring that class hierarchy in "++f++" is up-to-date.")- genFile typeGenProgram (typeOpts tag) f-- case lookup "x-signals-file" xList of- Nothing -> return ()- Just f -> do- info verb ("Ensuring that callback hooks in "++f++" are up-to-date.")- genFile signalGenProgram signalsOpts f----FIXME: Cabal should tell us the selected pkg-config package versions in the--- LocalBuildInfo or equivalent.--- In the mean time, ask pkg-config again.--getPkgConfigPackages :: Verbosity -> LocalBuildInfo -> PackageDescription -> IO [PackageId]-getPkgConfigPackages verbosity lbi pkg =- sequence- [ do version <- pkgconfig ["--modversion", display pkgname]- case simpleParse version of- Nothing -> die "parsing output of pkg-config --modversion failed"- Just v -> return (PackageIdentifier pkgname v)- | Dependency pkgname _ <- concatMap pkgconfigDepends (allBuildInfo pkg) ]- where- pkgconfig = rawSystemProgramStdoutConf verbosity- pkgConfigProgram (withPrograms lbi)----------------------------------------------------------------------------------- Dependency calculation amongst .chs files.----------------------------------------------------------------------------------- Given all files of the package, find those that end in .chs and extract the--- .chs files they depend upon. Then return the PackageDescription with these--- files rearranged so that they are built in a sequence that files that are--- needed by other files are built first.-fixDeps :: PackageDescription -> IO PackageDescription-fixDeps pd@PD.PackageDescription {- PD.library = Just lib@PD.Library {- PD.exposedModules = expMods,- PD.libBuildInfo = bi@PD.BuildInfo {- PD.hsSourceDirs = srcDirs,- PD.otherModules = othMods- }}} = do- let findModule m = findFileWithExtension [".chs.pp",".chs"] srcDirs- (joinPath (components m))- mExpFiles <- mapM findModule expMods- mOthFiles <- mapM findModule othMods-- -- tag all exposed files with True so we throw an error if we need to build- -- an exposed module before an internal modules (we cannot express this)- let modDeps = zipWith (ModDep True []) expMods mExpFiles++- zipWith (ModDep False []) othMods mOthFiles- modDeps <- mapM extractDeps modDeps- let (expMods, othMods) = span mdExposed $ sortTopological modDeps- badOther = map (fromMaybe "<no file>" . mdLocation) $- filter (not . mdExposed) expMods- unless (null badOther) $- die ("internal chs modules "++intercalate "," badOther++- " depend on exposed chs modules; cabal needs to build internal modules first")- return pd { PD.library = Just lib {- PD.exposedModules = map mdOriginal expMods,- PD.libBuildInfo = bi { PD.otherModules = map mdOriginal othMods }- }}--data ModDep = ModDep {- mdExposed :: Bool,- mdRequires :: [ModuleName],- mdOriginal :: ModuleName,- mdLocation :: Maybe FilePath-}--instance Show ModDep where- show x = show (mdLocation x)--instance Eq ModDep where- ModDep { mdOriginal = m1 } == ModDep { mdOriginal = m2 } = m1==m2-instance Ord ModDep where- compare ModDep { mdOriginal = m1 } ModDep { mdOriginal = m2 } = compare m1 m2---- Extract the dependencies of this file. This is intentionally rather naive as it--- ignores CPP conditionals. We just require everything which means that the--- existance of a .chs module may not depend on some CPP condition. -extractDeps :: ModDep -> IO ModDep-extractDeps md@ModDep { mdLocation = Nothing } = return md-extractDeps md@ModDep { mdLocation = Just f } = withUTF8FileContents f $ \con -> do- let findImports acc (('{':'#':xs):xxs) = case (dropWhile (' ' ==) xs) of- ('i':'m':'p':'o':'r':'t':' ':ys) ->- case simpleParse (takeWhile ('#' /=) ys) of- Just m -> findImports (m:acc) xxs - Nothing -> die ("cannot parse chs import in "++f++":\n"++- "offending line is {#"++xs)- -- no more imports after the first non-import hook- _ -> return acc- findImports acc (_:xxs) = findImports acc xxs- findImports acc [] = return acc- mods <- findImports [] (lines con)- return md { mdRequires = mods }---- Find a total order of the set of modules that are partially sorted by their--- dependencies on each other. The function returns the sorted list of modules--- together with a list of modules that are required but not supplied by this--- in the input set of modules.-sortTopological :: [ModDep] -> [ModDep]-sortTopological ms = reverse $ fst $ foldl visit ([], S.empty) (map mdOriginal ms)- where- set = M.fromList (map (\m -> (mdOriginal m, m)) ms)- visit (out,visited) m- | m `S.member` visited = (out,visited)- | otherwise = case m `M.lookup` set of- Nothing -> (out, m `S.insert` visited)- Just md -> (md:out', visited')- where- (out',visited') = foldl visit (out, m `S.insert` visited) (mdRequires md)---- Check user whether install gtk2hs-buildtools correctly.-checkGtk2hsBuildtools :: [Program] -> IO ()-checkGtk2hsBuildtools programs = do- programInfos <- mapM (\ prog -> do- location <- onDefaultSearchPath programFindLocation prog normal- return (programName prog, location)- ) programs- let printError name = do- putStrLn $ "Cannot find " ++ name ++ "\n" - ++ "Please install `gtk2hs-buildtools` first and check that the install directory is in your PATH (e.g. HOME/.cabal/bin)."- exitFailure- forM_ programInfos $ \ (name, location) ->- when (isNothing location) (printError name)
Setup.hs view
@@ -1,10 +1,8 @@--- Standard setup file for a Gtk2Hs module.+-- Adjustments specific to this package,+-- all Gtk2Hs-specific boilerplate is kept in+-- gtk2hs-buildtools:Gtk2HsSetup ----- See also:--- * SetupMain.hs : the real Setup script for this package--- * Gtk2HsSetup.hs : Gtk2Hs-specific boilerplate--- * SetupWrapper.hs : wrapper for compat with various ghc/cabal versions--import SetupWrapper ( setupWrapper )+import Gtk2HsSetup ( gtk2hsUserHooks )+import Distribution.Simple ( defaultMainWithHooks ) -main = setupWrapper "SetupMain.hs"+main = defaultMainWithHooks gtk2hsUserHooks
− SetupMain.hs
@@ -1,13 +0,0 @@--- The real Setup file for a Gtk2Hs package (invoked via the SetupWrapper).--- It contains only adjustments specific to this package,--- all Gtk2Hs-specific boilerplate is kept in Gtk2HsSetup.hs--- which should be kept identical across all packages.----import Gtk2HsSetup ( gtk2hsUserHooks, checkGtk2hsBuildtools,- typeGenProgram, signalGenProgram, c2hsLocal)-import Distribution.Simple ( defaultMainWithHooks )--main = do- checkGtk2hsBuildtools [c2hsLocal]- defaultMainWithHooks gtk2hsUserHooks-
− SetupWrapper.hs
@@ -1,164 +0,0 @@--- A wrapper script for Cabal Setup.hs scripts. Allows compiling the real Setup--- conditionally depending on the Cabal version.--module SetupWrapper (setupWrapper) where--import Distribution.Package-import Distribution.Compiler-import Distribution.Simple.Utils-import Distribution.Simple.Program-import Distribution.Simple.Compiler-import Distribution.Simple.BuildPaths (exeExtension)-import Distribution.Simple.Configure (configCompiler)-import Distribution.Simple.GHC (getInstalledPackages)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Version-import Distribution.Verbosity-import Distribution.Text--import System.Environment-import System.Process-import System.Exit-import System.FilePath-import System.Directory-import qualified Control.Exception as Exception-import System.IO.Error (isDoesNotExistError)--import Data.List-import Data.Char-import Control.Monad----- moreRecentFile is implemented in Distribution.Simple.Utils, but only in--- Cabal >= 1.18. For backwards-compatibility, we implement a copy with a new--- name here. Some desirable alternate strategies don't work:--- * We can't use CPP to check which version of Cabal we're up against because--- this is the file that's generating the macros for doing that.--- * We can't use the name moreRecentFiles and use--- import D.S.U hiding (moreRecentFiles)--- because on old GHC's (and according to the Report) hiding a name that--- doesn't exist is an error.-moreRecentFile' :: FilePath -> FilePath -> IO Bool-moreRecentFile' a b = do- exists <- doesFileExist b- if not exists- then return True- else do tb <- getModificationTime b- ta <- getModificationTime a- return (ta > tb)--setupWrapper :: FilePath -> IO ()-setupWrapper setupHsFile = do- args <- getArgs- createDirectoryIfMissingVerbose verbosity True setupDir- compileSetupExecutable- invokeSetupScript args-- where- setupDir = "dist/setup-wrapper"- setupVersionFile = setupDir </> "setup" <.> "version"- setupProgFile = setupDir </> "setup" <.> exeExtension- setupMacroFile = setupDir </> "wrapper-macros.h"-- useCabalVersion = Version [1,8] []- usePackageDB = [GlobalPackageDB, UserPackageDB]- verbosity = normal-- cabalLibVersionToUse comp conf = do- savedVersion <- savedCabalVersion- case savedVersion of- Just version- -> return version- _ -> do version <- installedCabalVersion comp conf- writeFile setupVersionFile (show version ++ "\n")- return version-- savedCabalVersion = do- versionString <- readFile setupVersionFile- `Exception.catch` \e -> if isDoesNotExistError e- then return ""- else Exception.throwIO e- case reads versionString of- [(version,s)] | all isSpace s -> return (Just version)- _ -> return Nothing-- installedCabalVersion comp conf = do- index <- getInstalledPackages verbosity usePackageDB conf-- let cabalDep = Dependency (PackageName "Cabal")- (orLaterVersion useCabalVersion)- case PackageIndex.lookupDependency index cabalDep of- [] -> die $ "The package requires Cabal library version "- ++ display useCabalVersion- ++ " but no suitable version is installed."- pkgs -> return $ bestVersion (map fst pkgs)- where- bestVersion = maximumBy (comparing preference)- preference version = (sameVersion, sameMajorVersion- ,stableVersion, latestVersion)- where- sameVersion = version == cabalVersion- sameMajorVersion = majorVersion version == majorVersion cabalVersion- majorVersion = take 2 . versionBranch- stableVersion = case versionBranch version of- (_:x:_) -> even x- _ -> False- latestVersion = version-- -- | If the Setup.hs is out of date wrt the executable then recompile it.- -- Currently this is GHC only. It should really be generalised.- --- compileSetupExecutable = do- setupHsNewer <- setupHsFile `moreRecentFile'` setupProgFile- cabalVersionNewer <- setupVersionFile `moreRecentFile'` setupProgFile- let outOfDate = setupHsNewer || cabalVersionNewer- when outOfDate $ do- debug verbosity "Setup script is out of date, compiling..."-- (comp, conf) <- configCompiler (Just GHC) Nothing Nothing- defaultProgramConfiguration verbosity- cabalLibVersion <- cabalLibVersionToUse comp conf- let cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion- debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion-- writeFile setupMacroFile (generateVersionMacro cabalLibVersion)-- rawSystemProgramConf verbosity ghcProgram conf $- ["--make", setupHsFile, "-o", setupProgFile]- ++ ghcPackageDbOptions usePackageDB- ++ ["-package", display cabalPkgid- ,"-cpp", "-optP-include", "-optP" ++ setupMacroFile- ,"-odir", setupDir, "-hidir", setupDir]- where-- ghcPackageDbOptions dbstack = case dbstack of- (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs- (GlobalPackageDB:dbs) -> "-no-user-package-conf"- : concatMap specific dbs- _ -> ierror- where- specific (SpecificPackageDB db) = [ "-package-conf", db ]- specific _ = ierror- ierror = error "internal error: unexpected package db stack"-- generateVersionMacro :: Version -> String- generateVersionMacro version =- concat- ["/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n"- ,"#define CABAL_VERSION_CHECK(major1,major2,minor) (\\\n"- ," (major1) < ",major1," || \\\n"- ," (major1) == ",major1," && (major2) < ",major2," || \\\n"- ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"- ,"\n\n"- ]- where- (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)-- invokeSetupScript :: [String] -> IO ()- invokeSetupScript args = do- info verbosity $ unwords (setupProgFile : args)- process <- runProcess (currentDir </> setupProgFile) args- Nothing Nothing- Nothing Nothing Nothing- exitCode <- waitForProcess process- unless (exitCode == ExitSuccess) $ exitWith exitCode
cairo.cabal view
@@ -1,35 +1,42 @@+cabal-version: 2.2 Name: cairo-Version: 0.12.5.3-License: BSD3+Version: 0.13.12.0+License: BSD-3-Clause License-file: COPYRIGHT Copyright: (c) 2001-2010 The Gtk2Hs Team, (c) Paolo Martini 2005, (c) Abraham Egnor 2003, 2004, (c) Aetion Technologies LLC 2004 Author: Axel Simon, Duncan Coutts Maintainer: gtk2hs-users@lists.sourceforge.net Build-Type: Custom-Cabal-Version: >= 1.8 Stability: stable homepage: http://projects.haskell.org/gtk2hs/-bug-reports: http://hackage.haskell.org/trac/gtk2hs/+bug-reports: https://github.com/gtk2hs/gtk2hs/issues Synopsis: Binding to the Cairo library. Description: Cairo is a library to render high quality vector graphics. There exist various backends that allows rendering to Gtk windows, PDF, PS, PNG and SVG documents, amongst others. Category: Graphics-Tested-With: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.1+Tested-With: GHC == 9.12.2, GHC == 9.10.1, GHC == 9.8.4, GHC == 9.6.6, GHC == 9.4.8, GHC == 9.2.8, GHC==9.0.2, GHC==8.10.7 extra-source-files: cairo-gtk2hs.h- SetupWrapper.hs SetupMain.hs Gtk2HsSetup.hs -Data-Dir: demo-Data-Files: cairo-clock-icon.png- CairoGhci.hs- Clock.hs- Drawing2.hs- Drawing.hs- Graph.hs- Makefile- StarAndRing.hs- Text.hs- +Data-Dir: demo+Data-Files: cairo-clock-icon.png+ gtk2/CairoGhci.hs+ gtk2/Clock.hs+ gtk2/Drawing2.hs+ gtk2/Drawing.hs+ gtk2/Graph.hs+ gtk2/Makefile+ gtk2/StarAndRing.hs+ gtk2/Text.hs+ gtk3/CairoGhci.hs+ gtk3/Clock.hs+ gtk3/Drawing2.hs+ gtk3/Drawing.hs+ gtk3/Graph.hs+ gtk3/Makefile+ gtk3/StarAndRing.hs+ gtk3/Text.hs+ Source-Repository head type: git location: https://github.com/gtk2hs/gtk2hs@@ -37,23 +44,30 @@ Flag cairo_pdf Description: Build the PDF backend of Cairo.- + Flag cairo_ps Description: Build the PostScript backend of Cairo. Flag cairo_svg Description: Build the Scalable Vector Graphics (SVG) backend of Cairo.- ++custom-setup+ setup-depends: base >= 4.6 && <5,+ Cabal >= 3.0 && < 3.15,+ gtk2hs-buildtools >= 0.13.2.0 && < 0.14+ Library- build-depends: base >= 4 && < 5,- utf8-string >= 0.2 && < 0.4,- bytestring, mtl, array- build-tools: gtk2hsC2hs >= 0.13.8+ build-depends: base >= 4.8 && < 5,+ utf8-string >= 0.2 && < 1.1,+ text >= 1.0.0.0 && < 2.2,+ array < 0.6,+ bytestring < 0.13,+ mtl < 2.4 exposed-modules: Graphics.Rendering.Cairo Graphics.Rendering.Cairo.Matrix Graphics.Rendering.Cairo.Types- -- this module is only meant to be used by other- -- modules implementing a Cairo interface+ -- this module is only meant to be used by other+ -- modules implementing a Cairo interface Graphics.Rendering.Cairo.Internal other-modules: Graphics.Rendering.Cairo.Internal.Drawing.Cairo@@ -70,7 +84,8 @@ Graphics.Rendering.Cairo.Internal.Surfaces.PS Graphics.Rendering.Cairo.Internal.Surfaces.SVG Graphics.Rendering.Cairo.Internal.Region- extensions: ForeignFunctionInterface+ default-language: Haskell98+ default-extensions: ForeignFunctionInterface Include-dirs: . x-c2hs-Header: cairo-gtk2hs.h pkgconfig-depends: cairo >= 1.2.0@@ -80,3 +95,5 @@ pkgconfig-depends: cairo-ps if flag(cairo_svg) pkgconfig-depends: cairo-svg+ if os(darwin) || os(freebsd)+ cpp-options: -D__attribute__(A)= -D_Nullable= -D_Nonnull= -D_Noreturn=
− demo/CairoGhci.hs
@@ -1,76 +0,0 @@--- Example of an drawing graphics onto a canvas.-import Graphics.UI.Gtk-import Graphics.Rendering.Cairo-import Control.Monad.Trans ( liftIO )-import Graphics.UI.Gtk.Gdk.EventM--run :: Render () -> IO ()-run act = do- initGUI- dia <- dialogNew- dialogAddButton dia stockClose ResponseClose- contain <- dialogGetUpper dia- canvas <- drawingAreaNew- canvas `onSizeRequest` return (Requisition 250 250)- canvas `on` exposeEvent $ tryEvent $ updateCanvas canvas act- boxPackStartDefaults contain canvas- widgetShow canvas- dialogRun dia- widgetDestroy dia- -- Flush all commands that are waiting to be sent to the graphics server.- -- This ensures that the window is actually closed before ghci displays the- -- prompt again.- flush-- where updateCanvas :: DrawingArea -> Render () -> EventM EExpose ()- updateCanvas canvas act = liftIO $ do- win <- widgetGetDrawWindow canvas- renderWithDrawable win act--setRed :: Render ()-setRed = do- setSourceRGB 1 0 0----setFat :: Render ()-setFat = do- setLineWidth 20- setLineCap LineCapRound----drawSquare :: Double -> Double -> Render ()-drawSquare width height = do- (x,y) <- getCurrentPoint- lineTo (x+width) y- lineTo (x+width) (y+height)- lineTo x (y+height)- closePath- stroke----drawHCirc :: Double -> Double -> Double -> Render ()-drawHCirc x y radius = do- arc x y radius 0 pi- stroke----drawStr :: String -> Render ()-drawStr txt = do- lay <- createLayout txt- showLayout lay----drawStr_ :: String -> Render ()-drawStr_ txt = do- lay <- liftIO $ do- ctxt <- cairoCreateContext Nothing- descr <- contextGetFontDescription ctxt- descr `fontDescriptionSetSize` 20- ctxt `contextSetFontDescription` descr- layoutText ctxt txt- showLayout lay
− demo/Clock.hs
@@ -1,407 +0,0 @@--- original author:--- Mirco "MacSlow" Mueller <macslow@bangang.de>------ created:--- 10.1.2006 (or so)------ http://www.gnu.org/licenses/licenses.html#GPL------ ported to Haskell by:--- Duncan Coutts <duncan.coutts@worc.ox.ac.uk>-----import Graphics.Rendering.Cairo-import Graphics.UI.Gtk-import Graphics.UI.Gtk.Gdk.EventM-import System.Time-import Control.Monad (when)-import Data.Maybe (isJust)-import Data.IORef--drawClockBackground :: Bool -> Int -> Int -> Render ()-drawClockBackground quality width height = do- save- scale (fromIntegral width) (fromIntegral height)-- save- setOperator OperatorOver- when quality drawDropShadow- drawClockFace quality- restore-- translate 0.5 0.5- scale 0.4 0.4- setSourceRGB 0.16 0.18 0.19- setLineWidth (1.5/60)- setLineCap LineCapRound- setLineJoin LineJoinRound- drawHourMarks-- restore--drawClockHands :: Bool -> Int -> Int -> Render ()-drawClockHands quality width height = do- save- scale (fromIntegral width) (fromIntegral height)-- translate 0.5 0.5- scale 0.4 0.4- setSourceRGB 0.16 0.18 0.19- setLineWidth (1.5/60)- setLineCap LineCapRound- setLineJoin LineJoinRound-- time <- liftIO (getClockTime >>= toCalendarTime)- let hours = fromIntegral (if ctHour time >= 12- then ctHour time - 12- else ctHour time)- minutes = fromIntegral (ctMin time)- seconds = fromIntegral (ctSec time)-- drawHourHand quality hours minutes seconds- drawMinuteHand quality minutes seconds- drawSecondHand quality seconds-- restore--drawClockForeground :: Bool -> Int -> Int -> Render ()-drawClockForeground quality width height = do- scale (fromIntegral width) (fromIntegral height)-- save- translate 0.5 0.5- scale 0.4 0.4- setSourceRGB 0.16 0.18 0.19- setLineWidth (1.5/60)- setLineCap LineCapRound- setLineJoin LineJoinRound-- when quality drawInnerShadow- when quality drawReflection- drawFrame quality- restore--drawDropShadow =- withRadialPattern 0.55 0.55 0.25 0.5 0.5 0.525 $ \pattern -> do- patternAddColorStopRGBA pattern 0 0 0 0 0.811- patternAddColorStopRGBA pattern 0.64 0.345 0.345 0.345 0.317- patternAddColorStopRGBA pattern 0.84 0.713 0.713 0.713 0.137- patternAddColorStopRGBA pattern 1 1 1 1 0- patternSetFilter pattern FilterFast- setSource pattern- arc 0.5 0.5 (142/150) 0 (pi*2)- fill--drawClockFace True =- withLinearPattern 0.5 0 0.5 1 $ \pattern -> do- patternAddColorStopRGB pattern 0 0.91 0.96 0.93- patternAddColorStopRGB pattern 1 0.65 0.68 0.68- patternSetFilter pattern FilterFast- setSource pattern- translate 0.5 0.5- arc 0 0 (60/150) 0 (pi*2)- fill-drawClockFace False = do- setSourceRGB 0.78 0.82 0.805- translate 0.5 0.5- arc 0 0 (60/150) 0 (pi*2)- fill--drawHourMarks = do- save- forM_ [1..12] $ \_ -> do- rotate (pi/6)- moveTo (4.5/6) 0- lineTo (5.0/6) 0- stroke- restore--forM_ = flip mapM_--drawHourHand quality hours minutes seconds = do- save- rotate (-pi/2)- setLineCap LineCapSquare- setLineJoin LineJoinMiter- rotate ( (pi/6) * hours- + (pi/360) * minutes- + (pi/21600) * seconds)-- -- hour hand's shadow- when quality $ do- setLineWidth (1.75/60)- setOperator OperatorAtop- setSourceRGBA 0.16 0.18 0.19 0.125- moveTo (-2/15 + 0.025) 0.025- lineTo (7/15 + 0.025) 0.025- stroke-- -- the hand itself- setLineWidth (1/60)- setOperator OperatorOver- setSourceRGB 0.16 0.18 0.19- moveTo (-2/15) 0- lineTo (7/15) 0- stroke- restore--drawMinuteHand quality minutes seconds = do- save- rotate (-pi/2)- setLineCap LineCapSquare- setLineJoin LineJoinMiter- rotate ( (pi/30) * minutes- + (pi/1800) * seconds)-- -- minute hand's shadow- when quality $ do- setLineWidth (1.75/60)- setOperator OperatorAtop- setSourceRGBA 0.16 0.18 0.19 0.125- moveTo (-16/75 - 0.025) (-0.025)- lineTo (2/3 - 0.025) (-0.025)- stroke-- -- the minute hand itself- setLineWidth (1/60)- setOperator OperatorOver- setSourceRGB 0.16 0.18 0.19- moveTo (-16/75) 0- lineTo (2/3) 0- stroke- restore--drawSecondHand quality seconds = do- save- rotate (-pi/2)- setLineCap LineCapSquare- setLineJoin LineJoinMiter- rotate (seconds * pi/30);-- -- shadow of second hand-part- when quality $ do- setOperator OperatorAtop- setSourceRGBA 0.16 0.18 0.19 0.125- setLineWidth (1.3125 / 60)- moveTo (-1.5/5 + 0.025) 0.025- lineTo (3/5 + 0.025) 0.025- stroke-- -- second hand- setOperator OperatorOver- setSourceRGB 0.39 0.58 0.77- setLineWidth (0.75/60)- moveTo (-1.5/5) 0- lineTo (3/5) 0- stroke-- arc 0 0 (1/20) 0 (pi*2)- fill- arc (63/100) 0 (1/35) 0 (pi*2)- stroke- setLineWidth (1/100)- moveTo (10/15) 0- lineTo (12/15) 0- stroke- setSourceRGB 0.31 0.31 0.31- arc 0 0 (1/25) 0 (pi*2)- fill- restore--drawInnerShadow = do- save- setOperator OperatorOver- arc 0 0 (142/150) 0 (pi*2)- clip- withRadialPattern 0.3 0.3 0.1 0 0 0.95 $ \pattern -> do- patternAddColorStopRGBA pattern 0 1 1 1 0- patternAddColorStopRGBA pattern 0.64 0.713 0.713 0.713 0.137- patternAddColorStopRGBA pattern 0.84 0.345 0.345 0.345 0.317- patternAddColorStopRGBA pattern 1 0 0 0 0.811- patternSetFilter pattern FilterFast- setSource pattern- arc 0 0 (142/150) 0 (pi*2)- fill- restore--drawReflection = do- save- arc 0 0 (142/150) 0 (pi*2)- clip- rotate (-75 * pi/180)- setSourceRGBA 0.87 0.9 0.95 0.25- moveTo (-1) (-1)- lineTo 1 (-1)- lineTo 1 1- curveTo 1 0.15 (-0.15) (-1) (-1) (-1)- fill- moveTo (-1) (-1)- lineTo (-1) 1- lineTo 1 1- curveTo (-0.5) 1 (-1) 0.5 (-1) (-1)- fill- restore--drawFrame True = do- save- withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do- patternAddColorStopRGB pattern 0 0.4 0.4 0.4- patternAddColorStopRGB pattern 0.2 0.95 0.95 0.95- patternSetFilter pattern FilterFast- setSource pattern- setLineWidth (10/75)- arc 0 0 (142/150) 0 (pi*2)- stroke-- withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do- patternAddColorStopRGB pattern 0 0.9 0.9 0.9- patternAddColorStopRGB pattern 0.2 0.35 0.35 0.35- patternSetFilter pattern FilterFast- setSource pattern- setLineWidth (10/75)- arc 0 0 (150/150) 0 (pi*2)- stroke- restore-drawFrame False = do- save- setSourceRGB 0 0 0- setLineWidth (10/75)- arc 0 0 1 0 (pi*2)- stroke- restore--initialSize :: Int-initialSize = 256--main = do- initGUI-- window <- windowNew- windowSetDecorated window False- windowSetResizable window True- windowSetPosition window WinPosCenterAlways-- widgetSetAppPaintable window True- windowSetIconFromFile window "cairo-clock-icon.png"- windowSetTitle window "Gtk2Hs Cairo Clock"- windowSetDefaultSize window initialSize initialSize- windowSetGeometryHints window (Just window)- (Just (32, 32)) (Just (512, 512))- Nothing Nothing (Just (1,1))-- let setAlpha widget = do- screen <- widgetGetScreen widget- colormap <- screenGetRGBAColormap screen- maybe (return ()) (widgetSetColormap widget) colormap- setAlpha window --TODO: also call setAlpha on alpha screen change-- window `on` keyPressEvent $ tryEvent $ do- "Escape" <- eventKeyName- liftIO mainQuit-- window `on` buttonPressEvent $ tryEvent $ do- LeftButton <- eventButton- time <- eventTime- (x,y) <- eventRootCoordinates- liftIO $ windowBeginMoveDrag window LeftButton (round x) (round y) time-- window `on` buttonPressEvent $ tryEvent $ do- MiddleButton <- eventButton- time <- eventTime- (x,y) <- eventRootCoordinates- liftIO $ windowBeginResizeDrag window WindowEdgeSouthEast MiddleButton- (round x) (round y) time-- timeoutAdd (widgetQueueDraw window >> return True) 1000-- backgroundRef <- newIORef (Just undefined)- foregroundRef <- newIORef (Just undefined)-- let redrawStaticLayers = do- (width, height) <- widgetGetSize window- drawWin <- widgetGetDrawWindow window- background <- createImageSurface FormatARGB32 width height- foreground <- createImageSurface FormatARGB32 width height- let clear = do- save- setOperator OperatorClear- paint- restore- renderWith background $ do- clear- drawClockBackground True width height- renderWith foreground $ do- clear- drawClockForeground True width height- writeIORef backgroundRef (Just background)- writeIORef foregroundRef (Just foreground)-- onRealize window redrawStaticLayers-- sizeRef <- newIORef (initialSize, initialSize)- timeoutHandlerRef <- newIORef Nothing- window `on` configureEvent $ do- (w,h) <- eventSize- liftIO $ do- size <- readIORef sizeRef- writeIORef sizeRef (w,h)- when (size /= (w,h)) $ do-- background <- readIORef backgroundRef- foreground <- readIORef foregroundRef- maybe (return ()) surfaceFinish background- maybe (return ()) surfaceFinish foreground-- writeIORef backgroundRef Nothing- writeIORef foregroundRef Nothing-- timeoutHandler <- readIORef timeoutHandlerRef- maybe (return ()) timeoutRemove timeoutHandler-- handler <- timeoutAddFull (do- writeIORef timeoutHandlerRef Nothing- redrawStaticLayers- widgetQueueDraw window- return False- ) priorityDefaultIdle 300- writeIORef timeoutHandlerRef (Just handler)-- return False-- window `on` exposeEvent $ do- drawWin <- eventWindow- exposeRegion <- eventRegion- liftIO $ do- (width, height) <- drawableGetSize drawWin-- background <- readIORef backgroundRef- foreground <- readIORef foregroundRef-- renderWithDrawable drawWin $ do- region exposeRegion- clip-- save- setOperator OperatorSource- setSourceRGBA 0 0 0 0- paint- restore-- case background of- Nothing -> drawClockBackground False width height- Just background -> do- setSourceSurface background 0 0- paint-- drawClockHands (isJust background) width height-- case foreground of- Nothing -> drawClockForeground False width height- Just foreground -> do- setSourceSurface foreground 0 0- paint-- return True-- widgetShowAll window- mainGUI
− demo/Drawing.hs
@@ -1,59 +0,0 @@--- Example of an drawing graphics onto a canvas.-import Graphics.UI.Gtk-import Graphics.Rendering.Cairo-import Graphics.UI.Gtk.Gdk.EventM--main = do- initGUI- dia <- dialogNew- dialogAddButton dia stockOk ResponseOk- contain <- dialogGetUpper dia- canvas <- drawingAreaNew- canvas `on` sizeRequest $ return (Requisition 40 40)- ctxt <- cairoCreateContext Nothing- text <- layoutEmpty ctxt- text `layoutSetText` "Hello World."- canvas `on` exposeEvent $ updateCanvas text- boxPackStartDefaults contain canvas- widgetShow canvas- dialogRun dia- return ()--updateCanvas :: PangoLayout -> EventM EExpose Bool-updateCanvas text = do- win <- eventWindow- liftIO $ do- (width',height') <- drawableGetSize win- let width = realToFrac width'- height = realToFrac height'-- -- Draw using the cairo api- renderWithDrawable win $ do- setSourceRGB 1 0 0- setLineWidth 20- setLineCap LineCapRound- setLineJoin LineJoinRound-- moveTo 30 30- lineTo (width-30) (height-30)- lineTo (width-30) 30- lineTo 30 (height-30)- stroke-- setSourceRGB 1 1 0- setLineWidth 4-- save- translate (width / 2) (height / 2)- scale (width / 2) (height / 2)- arc 0 0 1 (135 * pi/180) (225 * pi/180)- restore- stroke-- setSourceRGB 0 0 0- moveTo 30 (realToFrac height / 4)- rotate (pi/4)- showLayout text--- return True
− demo/Drawing2.hs
@@ -1,258 +0,0 @@------ Author: Johan Bockgård <bojohan@dd.chalmers.se>------ This code is in the public domain.-----import qualified Graphics.UI.Gtk as G-import qualified Graphics.Rendering.Cairo as C-import qualified Graphics.Rendering.Cairo.Matrix as M---windowWidth, windowHeight :: Int-windowWidth = 500-windowHeight = 500---- Write image to file-writePng :: IO ()-writePng =- C.withImageSurface C.FormatARGB32 width height $ \ result -> do- C.renderWith result $ example width height- C.surfaceWriteToPNG result "Draw.png"- where width = windowWidth- height = windowHeight---- Display image in window-main = do- G.initGUI- window <- G.windowNew- canvas <- G.drawingAreaNew- -- fix size- -- G.windowSetResizable window False- G.widgetSetSizeRequest window windowWidth windowHeight- -- press any key to quit- G.onKeyPress window $ const (do G.widgetDestroy window; return True)- G.onDestroy window G.mainQuit- G.onExpose canvas $ const (updateCanvas canvas)- G.set window [G.containerChild G.:= canvas]- G.widgetShowAll window- G.mainGUI--updateCanvas :: G.DrawingArea -> IO Bool-updateCanvas canvas = do- win <- G.widgetGetDrawWindow canvas- (width, height) <- G.widgetGetSize canvas- G.renderWithDrawable win $- example width height- return True--------------------------------------------------------------------foreach :: (Monad m) => [a] -> (a -> m b) -> m [b]-foreach = flip mapM--keepState render = do- C.save- render- C.restore--drawCircle x y r = do- C.arc x y r 0 (2 * pi)- fillStroke--drawRectangle x y w h = do- C.rectangle x y w h- fillStroke--stroke =- keepState $ do- C.setSourceRGBA 0 0 0 0.7- C.stroke--fillStroke = do- C.fillPreserve- stroke---------------------------------------------------------------------- Example--example width height = do- prologue width height- example1---- Set up stuff-prologue wWidth wHeight = do- let width = 10- height = 10- xmax = width / 2- xmin = - xmax- ymax = height / 2- ymin = - ymax- scaleX = realToFrac wWidth / width- scaleY = realToFrac wHeight / height-- -- style and color- C.setLineCap C.LineCapRound- C.setLineJoin C.LineJoinRound- C.setLineWidth $ 1 / max scaleX scaleY- C.setSourceRGBA 0.5 0.7 0.5 0.5-- -- Set up user coordinates- C.scale scaleX scaleY- -- center origin- C.translate (width / 2) (height / 2)- -- positive y-axis upwards- let flipY = M.Matrix 1 0 0 (-1) 0 0- C.transform flipY-- grid xmin xmax ymin ymax----- Grid and axes-grid xmin xmax ymin ymax =- keepState $ do- C.setSourceRGBA 0 0 0 0.7- -- axes- C.moveTo 0 ymin; C.lineTo 0 ymax; C.stroke- C.moveTo xmin 0; C.lineTo xmax 0; C.stroke- -- grid- C.setDash [0.01, 0.99] 0- foreach [xmin .. xmax] $ \ x ->- do C.moveTo x ymin- C.lineTo x ymax- C.stroke--example1 = do- -- circles- drawCircle 0 0 1- drawCircle 2 2 3- -- a bunch of rectangles- keepState $- foreach [1 .. 5] $ \ _ ->- do drawRectangle 0 1 2 3- C.rotate (pi/8)- -- some cute stuff- thought- apple- snake--thought =- keepState $ do- C.scale 0.04 0.04- C.translate (200) (380)- C.rotate pi- C.setSourceRGBA 0.5 0.5 1 0.7- C.setLineWidth 1- image- fillStroke- where- m = C.moveTo- c = C.curveTo- z = C.closePath- image = do- m 184 327- c 176 327 170 332 168 339- c 166 333 160 329 153 329- c 147 329 141 333 138 339- c 137 339 136 338 134 338- c 125 338 118 345 118 354- c 118 363 125 371 134 371- c 137 371 140 370 142 368- c 142 368 142 368 142 369- c 142 377 149 385 158 385- c 162 385 166 383 168 381- c 171 386 176 390 183 390- c 188 390 193 387 196 383- c 198 384 201 385 204 385- c 212 385 220 378 220 369- c 222 371 225 372 228 372- c 237 372 244 364 244 355- c 244 346 237 339 228 339- c 227 339 226 339 225 340- c 223 332 217 327 209 327- c 204 327 199 330 196 333- c 193 330 189 327 184 327- z- m 164 387- c 158 387 153 391 153 397- c 153 402 158 407 164 407- c 170 407 174 402 174 397- c 174 391 170 387 164 387- z- m 152 408- c 149 408 146 411 146 414- c 146 417 149 420 152 420- c 155 420 158 417 158 414- c 158 411 155 408 152 408- z- m 143 422- c 141 422 139 424 139 426- c 139 428 141 429 143 429- c 144 429 146 428 146 426- c 146 424 144 422 143 422- z--apple =- keepState $ do- C.scale 0.05 0.05- C.translate (1110) (220)- C.rotate pi- C.setLineWidth 0.5- C.setSourceRGBA 0 0 0 0.7- image1- fillStroke- C.setSourceRGBA 1 0 0 0.7- image2- fillStroke- where- m = C.moveTo- c = C.curveTo- z = C.closePath- l = C.lineTo- image1 = do- m 1149 245- l 1156 244- l 1155 252- l 1149 245- z- image2 = do- m 1151 249- c 1145 249 1140 254 1140 261- c 1140 268 1145 273 1151 273- c 1152 273 1153 273 1154 272- c 1156 273 1157 273 1158 273- c 1164 273 1169 268 1169 261- c 1169 254 1164 249 1158 249- c 1157 249 1156 249 1154 250- c 1153 249 1152 249 1151 249- z--snake =- keepState $ do- C.scale 0.04 0.04- C.translate (150) (220)- C.rotate pi- C.setLineWidth 0.5- C.setSourceRGBA 0.1 0.1 0 0.7- image- fillStroke- where- m = C.moveTo- c = C.curveTo- z = C.closePath- l = C.lineTo- image = do- m 146 320- c 143 308 130 314 123 319- c 115 324 108 311 100 314- c 93 317 92 319 81 318- c 76 318 60 309 60 320- c 60 328 73 321 82 323- c 94 326 98 317 106 320- c 113 323 120 330 128 323- c 133 318 142 312 146 320- l 146 320- z------------------------------------------------------------------
− demo/Graph.hs
@@ -1,98 +0,0 @@------ Author: Michael Sloan <mgsloan@gmail.com>------ This code is in the public domain.------ Based off Johan Bockgård's Drawing2.hs-----import qualified Graphics.UI.Gtk as G-import qualified Graphics.Rendering.Cairo as C-import qualified Graphics.Rendering.Cairo.Matrix as M--f x = sin (x*5) / (x*5)--main = graph f--graph :: (Double -> Double) -> IO ()-graph f = do- G.initGUI- window <- G.windowNew- canvas <- G.drawingAreaNew- G.windowSetResizable window False- G.widgetSetSizeRequest window 600 600- -- press any key to quit- G.onKeyPress window $ const (do G.widgetDestroy window; return True)- G.onDestroy window G.mainQuit- G.onExpose canvas $ const $ render f canvas- G.set window [G.containerChild G.:= canvas]- G.widgetShowAll window- G.mainGUI--render :: (Double -> Double) -> G.DrawingArea -> IO Bool-render f canvas = do- win <- G.widgetGetDrawWindow canvas- (width, height) <- G.widgetGetSize canvas- G.renderWithDrawable win $ (prologue width height >> renderG f)- return True--foreach :: (Monad m) => [a] -> (a -> m b) -> m [b]-foreach = flip mapM--deriv :: (Double -> Double) -> Double -> Double-deriv f x = ((f $ x + 0.05) - (f $ x - 0.05)) * 10--gen :: Double -> Double -> (Double -> Double) -> [Double]-gen v t f | v > t = []-gen v t f = v : (gen (f v) t f)--skipBy f = foldr (\x c -> if f x then c else x : c) []--falloff x = 0.25 * (x + 1.5) / ((x+0.5)^5 + 1)--renderG :: (Double -> Double) -> C.Render ()-renderG f = do- C.moveTo (-5) (f (-5))- sequence_ $ map (\d -> C.lineTo d $ f d) $ skipBy (isInfinite . f) [-4.9,-4.8..5]- --Adaptive attempt (falloff func is what really needs work)- --sequence_ $ map (\d -> C.lineTo d $ f d) $ skipBy (isInfinite . f) $ tail $ gen (-5) 5 (\x -> x + (falloff $ abs $ deriv (deriv f) x))- C.stroke---- Set up stuff-prologue wWidth wHeight = do- let width = 10- height = 10- xmax = width / 2- xmin = - xmax- ymax = height / 2- ymin = - ymax- scaleX = realToFrac wWidth / width- scaleY = realToFrac wHeight / height-- -- style and color- C.setLineCap C.LineCapRound- C.setLineJoin C.LineJoinRound- C.setLineWidth $ 1 / max scaleX scaleY-- -- Set up user coordinates- C.scale scaleX scaleY- -- center origin- C.translate (width / 2) (height / 2)- -- positive y-axis upwards- let flipY = M.Matrix 1 0 0 (-1) 0 0- C.transform flipY- C.setSourceRGBA 0 0 0 1- grid xmin xmax ymin ymax---- Grid and axes-grid xmin xmax ymin ymax = do- -- axes- C.moveTo 0 ymin; C.lineTo 0 ymax; C.stroke- C.moveTo xmin 0; C.lineTo xmax 0; C.stroke- -- grid- C.setDash [0.01, 0.99] 0- foreach [xmin .. xmax] $ \ x ->- do C.moveTo x ymin- C.lineTo x ymax- C.stroke- C.setDash [] 0
− demo/Makefile
@@ -1,33 +0,0 @@--PROGS = drawing drawing2 starandring text clock graph sdldrawing-SOURCES = Drawing.hs Drawing2.hs StarAndRing.hs Text.hs Clock.hs Graph.hs CairoSDL.hs--all : $(PROGS)--drawing : Drawing.hs- $(HC_RULE)--drawing2 : Drawing2.hs- $(HC_RULE)--starandring : StarAndRing.hs- $(HC_RULE)--text : Text.hs- $(HC_RULE)--clock : Clock.hs- $(HC_RULE)--graph : Graph.hs- $(HC_RULE)--sdldrawing : CairoSDL.hs- $(HC_RULE)--HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS)--clean:- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)--HC=ghc
− demo/StarAndRing.hs
@@ -1,111 +0,0 @@-import Graphics.Rendering.Cairo-import qualified Graphics.Rendering.Cairo.Matrix as M--ringPath :: Render ()-ringPath = do- moveTo 200.86568 667.80795- curveTo 110.32266 562.62134 122.22863 403.77940 227.41524 313.23637- curveTo 332.60185 222.69334 491.42341 234.57563 581.96644 339.76224- curveTo 672.50948 444.94884 660.64756 603.79410 555.46095 694.33712- curveTo 450.27436 784.88016 291.40871 772.99456 200.86568 667.80795- closePath- moveTo 272.14411 365.19927- curveTo 195.64476 431.04875 186.97911 546.57972 252.82859 623.07908- curveTo 318.67807 699.57844 434.23272 708.22370 510.73208 642.37422- curveTo 587.23144 576.52474 595.85301 460.99047 530.00354 384.49112- curveTo 464.15406 307.99176 348.64347 299.34979 272.14411 365.19927- closePath--starPath :: Render ()-starPath = do- transform (M.Matrix 0.647919 (-0.761710) 0.761710 0.647919 (-208.7977) 462.0608)- moveTo 505.80857 746.23606- lineTo 335.06870 555.86488- lineTo 91.840384 635.31360- lineTo 282.21157 464.57374- lineTo 202.76285 221.34542- lineTo 373.50271 411.71660- lineTo 616.73103 332.26788- lineTo 426.35984 503.00775- lineTo 505.80857 746.23606- closePath--fillRing :: Render ()-fillRing = do- save- translate (-90) (-205)- ringPath- setSourceRGBA 1.0 0.0 0.0 0.75- fill- restore--fillStar :: Render ()-fillStar = do- save- translate (-90) (-205)- starPath- setSourceRGBA 0.0 0.0 ((fromIntegral 0xae) / (fromIntegral 0xff)) 0.55135137- fill- restore--clipToTopAndBottom :: Int -> Int -> Render ()-clipToTopAndBottom width height = do- moveTo 0 0- lineTo (fromIntegral width) 0.0- lineTo 0.0 (fromIntegral height)- lineTo (fromIntegral width) (fromIntegral height)- closePath- clip- newPath--clipToLeftAndRight :: Int -> Int -> Render ()-clipToLeftAndRight width height = do- moveTo 0 0- lineTo 0.0 (fromIntegral height)- lineTo (fromIntegral width) 0.0- lineTo (fromIntegral width) (fromIntegral height)- closePath- clip- newPath--starAndRing :: Int -> Int -> Render ()-starAndRing width height = do- setOperator OperatorClear- paint-- setOperator OperatorAdd-- renderWithSimilarSurface ContentColorAlpha width height $ \ringOverStar -> do- renderWith ringOverStar $ do- clipToTopAndBottom width height- fillStar- fillRing- setSourceSurface ringOverStar 0 0- paint-- renderWithSimilarSurface ContentColorAlpha width height $ \starOverRing -> do- renderWith starOverRing $ do- clipToLeftAndRight width height- fillRing- fillStar- setSourceSurface starOverRing 0 0- paint--main :: IO ()-main = do- withImageSurface FormatARGB32 width height $ \result -> do- renderWith result $ starAndRing width height- surfaceWriteToPNG result "StarAndRing.png"- putStrLn "wrote StarAndRing.png"- withPDFSurface "StarAndRing.pdf" (fromIntegral width) (fromIntegral height)- (flip renderWith $ starAndRing width height >> showPage)- putStrLn "wrote StarAndRing.pdf"- withPSSurface "StarAndRing.ps" (fromIntegral width) (fromIntegral height)- (flip renderWith $ starAndRing width height >> showPage)- putStrLn "wrote StarAndRing.ps"- withSVGSurface "StarAndRing.svg" (fromIntegral width) (fromIntegral height)- (flip renderWith $ starAndRing width height)- putStrLn "wrote StarAndRing.svg"-- where width = 600- height = 600
− demo/Text.hs
@@ -1,71 +0,0 @@-import Graphics.Rendering.Cairo-import qualified Graphics.Rendering.Cairo.Matrix as M--boxText :: String -> Double -> Double -> Render ()-boxText text x y = do- save-- lineWidth <- getLineWidth-- (TextExtents xb yb w h _ _) <- textExtents text-- rectangle (x + xb - lineWidth)- (y + yb - lineWidth)- (w + 2 * lineWidth)- (h + 2 * lineWidth)- stroke- moveTo x y- textPath text- fillPreserve- setSourceRGBA 0 0 1 0.5- setLineWidth 3.0- stroke-- restore--transpSurface :: Double -> Double -> Render ()-transpSurface w h = do- save- rectangle 0 0 w h- setSourceRGBA 0 0 0 0- setOperator OperatorSource- fill- restore--width = 400-height = 300--main :: IO ()-main = withImageSurface FormatARGB32 width height $ \surface -> do- renderWith surface $ do- setSourceRGB 0.0 0.0 0.0- setLineWidth 2.0-- transpSurface (fromIntegral width) (fromIntegral height)-- selectFontFace "sans" FontSlantNormal FontWeightNormal- setFontSize 40-- extents <- fontExtents- let fontHeight = fontExtentsHeight extents-- boxText "Howdy, world!" 10 fontHeight-- translate 0 fontHeight-- save- translate 10 fontHeight- rotate (10.0 * pi / 180.0)- boxText "Yay for Haskell!" 0 0- restore-- translate 0 (3 * fontHeight)-- save- setFontMatrix $ M.rotate ((-10.0) * pi / 180.0) $ M.scale 40.0 40.0 M.identity- boxText "...and Cairo!" 10 fontHeight- restore-- surfaceWriteToPNG surface "Text.png"-- return ()
+ demo/gtk2/CairoGhci.hs view
@@ -0,0 +1,76 @@+-- Example of an drawing graphics onto a canvas.+import Graphics.UI.Gtk+import Graphics.Rendering.Cairo+import Control.Monad.Trans ( liftIO )+import Graphics.UI.Gtk.Gdk.EventM++run :: Render () -> IO ()+run act = do+ initGUI+ dia <- dialogNew+ dialogAddButton dia stockClose ResponseClose+ contain <- dialogGetUpper dia+ canvas <- drawingAreaNew+ canvas `onSizeRequest` return (Requisition 250 250)+ canvas `on` exposeEvent $ tryEvent $ updateCanvas canvas act+ boxPackStartDefaults contain canvas+ widgetShow canvas+ dialogRun dia+ widgetDestroy dia+ -- Flush all commands that are waiting to be sent to the graphics server.+ -- This ensures that the window is actually closed before ghci displays the+ -- prompt again.+ flush++ where updateCanvas :: DrawingArea -> Render () -> EventM EExpose ()+ updateCanvas canvas act = liftIO $ do+ win <- widgetGetDrawWindow canvas+ renderWithDrawable win act++setRed :: Render ()+setRed = do+ setSourceRGB 1 0 0++++setFat :: Render ()+setFat = do+ setLineWidth 20+ setLineCap LineCapRound++++drawSquare :: Double -> Double -> Render ()+drawSquare width height = do+ (x,y) <- getCurrentPoint+ lineTo (x+width) y+ lineTo (x+width) (y+height)+ lineTo x (y+height)+ closePath+ stroke++++drawHCirc :: Double -> Double -> Double -> Render ()+drawHCirc x y radius = do+ arc x y radius 0 pi+ stroke++++drawStr :: String -> Render ()+drawStr txt = do+ lay <- createLayout txt+ showLayout lay++++drawStr_ :: String -> Render ()+drawStr_ txt = do+ lay <- liftIO $ do+ ctxt <- cairoCreateContext Nothing+ descr <- contextGetFontDescription ctxt+ descr `fontDescriptionSetSize` 20+ ctxt `contextSetFontDescription` descr+ layoutText ctxt txt+ showLayout lay
+ demo/gtk2/Clock.hs view
@@ -0,0 +1,407 @@+-- original author:+-- Mirco "MacSlow" Mueller <macslow@bangang.de>+--+-- created:+-- 10.1.2006 (or so)+--+-- http://www.gnu.org/licenses/licenses.html#GPL+--+-- ported to Haskell by:+-- Duncan Coutts <duncan.coutts@worc.ox.ac.uk>+--++import Graphics.Rendering.Cairo+import Graphics.UI.Gtk+import Graphics.UI.Gtk.Gdk.EventM+import System.Time+import Control.Monad (when)+import Data.Maybe (isJust)+import Data.IORef++drawClockBackground :: Bool -> Int -> Int -> Render ()+drawClockBackground quality width height = do+ save+ scale (fromIntegral width) (fromIntegral height)++ save+ setOperator OperatorOver+ when quality drawDropShadow+ drawClockFace quality+ restore++ translate 0.5 0.5+ scale 0.4 0.4+ setSourceRGB 0.16 0.18 0.19+ setLineWidth (1.5/60)+ setLineCap LineCapRound+ setLineJoin LineJoinRound+ drawHourMarks++ restore++drawClockHands :: Bool -> Int -> Int -> Render ()+drawClockHands quality width height = do+ save+ scale (fromIntegral width) (fromIntegral height)++ translate 0.5 0.5+ scale 0.4 0.4+ setSourceRGB 0.16 0.18 0.19+ setLineWidth (1.5/60)+ setLineCap LineCapRound+ setLineJoin LineJoinRound++ time <- liftIO (getClockTime >>= toCalendarTime)+ let hours = fromIntegral (if ctHour time >= 12+ then ctHour time - 12+ else ctHour time)+ minutes = fromIntegral (ctMin time)+ seconds = fromIntegral (ctSec time)++ drawHourHand quality hours minutes seconds+ drawMinuteHand quality minutes seconds+ drawSecondHand quality seconds++ restore++drawClockForeground :: Bool -> Int -> Int -> Render ()+drawClockForeground quality width height = do+ scale (fromIntegral width) (fromIntegral height)++ save+ translate 0.5 0.5+ scale 0.4 0.4+ setSourceRGB 0.16 0.18 0.19+ setLineWidth (1.5/60)+ setLineCap LineCapRound+ setLineJoin LineJoinRound++ when quality drawInnerShadow+ when quality drawReflection+ drawFrame quality+ restore++drawDropShadow =+ withRadialPattern 0.55 0.55 0.25 0.5 0.5 0.525 $ \pattern -> do+ patternAddColorStopRGBA pattern 0 0 0 0 0.811+ patternAddColorStopRGBA pattern 0.64 0.345 0.345 0.345 0.317+ patternAddColorStopRGBA pattern 0.84 0.713 0.713 0.713 0.137+ patternAddColorStopRGBA pattern 1 1 1 1 0+ patternSetFilter pattern FilterFast+ setSource pattern+ arc 0.5 0.5 (142/150) 0 (pi*2)+ fill++drawClockFace True =+ withLinearPattern 0.5 0 0.5 1 $ \pattern -> do+ patternAddColorStopRGB pattern 0 0.91 0.96 0.93+ patternAddColorStopRGB pattern 1 0.65 0.68 0.68+ patternSetFilter pattern FilterFast+ setSource pattern+ translate 0.5 0.5+ arc 0 0 (60/150) 0 (pi*2)+ fill+drawClockFace False = do+ setSourceRGB 0.78 0.82 0.805+ translate 0.5 0.5+ arc 0 0 (60/150) 0 (pi*2)+ fill++drawHourMarks = do+ save+ forM_ [1..12] $ \_ -> do+ rotate (pi/6)+ moveTo (4.5/6) 0+ lineTo (5.0/6) 0+ stroke+ restore++forM_ = flip mapM_++drawHourHand quality hours minutes seconds = do+ save+ rotate (-pi/2)+ setLineCap LineCapSquare+ setLineJoin LineJoinMiter+ rotate ( (pi/6) * hours+ + (pi/360) * minutes+ + (pi/21600) * seconds)++ -- hour hand's shadow+ when quality $ do+ setLineWidth (1.75/60)+ setOperator OperatorAtop+ setSourceRGBA 0.16 0.18 0.19 0.125+ moveTo (-2/15 + 0.025) 0.025+ lineTo (7/15 + 0.025) 0.025+ stroke++ -- the hand itself+ setLineWidth (1/60)+ setOperator OperatorOver+ setSourceRGB 0.16 0.18 0.19+ moveTo (-2/15) 0+ lineTo (7/15) 0+ stroke+ restore++drawMinuteHand quality minutes seconds = do+ save+ rotate (-pi/2)+ setLineCap LineCapSquare+ setLineJoin LineJoinMiter+ rotate ( (pi/30) * minutes+ + (pi/1800) * seconds)++ -- minute hand's shadow+ when quality $ do+ setLineWidth (1.75/60)+ setOperator OperatorAtop+ setSourceRGBA 0.16 0.18 0.19 0.125+ moveTo (-16/75 - 0.025) (-0.025)+ lineTo (2/3 - 0.025) (-0.025)+ stroke++ -- the minute hand itself+ setLineWidth (1/60)+ setOperator OperatorOver+ setSourceRGB 0.16 0.18 0.19+ moveTo (-16/75) 0+ lineTo (2/3) 0+ stroke+ restore++drawSecondHand quality seconds = do+ save+ rotate (-pi/2)+ setLineCap LineCapSquare+ setLineJoin LineJoinMiter+ rotate (seconds * pi/30);++ -- shadow of second hand-part+ when quality $ do+ setOperator OperatorAtop+ setSourceRGBA 0.16 0.18 0.19 0.125+ setLineWidth (1.3125 / 60)+ moveTo (-1.5/5 + 0.025) 0.025+ lineTo (3/5 + 0.025) 0.025+ stroke++ -- second hand+ setOperator OperatorOver+ setSourceRGB 0.39 0.58 0.77+ setLineWidth (0.75/60)+ moveTo (-1.5/5) 0+ lineTo (3/5) 0+ stroke++ arc 0 0 (1/20) 0 (pi*2)+ fill+ arc (63/100) 0 (1/35) 0 (pi*2)+ stroke+ setLineWidth (1/100)+ moveTo (10/15) 0+ lineTo (12/15) 0+ stroke+ setSourceRGB 0.31 0.31 0.31+ arc 0 0 (1/25) 0 (pi*2)+ fill+ restore++drawInnerShadow = do+ save+ setOperator OperatorOver+ arc 0 0 (142/150) 0 (pi*2)+ clip+ withRadialPattern 0.3 0.3 0.1 0 0 0.95 $ \pattern -> do+ patternAddColorStopRGBA pattern 0 1 1 1 0+ patternAddColorStopRGBA pattern 0.64 0.713 0.713 0.713 0.137+ patternAddColorStopRGBA pattern 0.84 0.345 0.345 0.345 0.317+ patternAddColorStopRGBA pattern 1 0 0 0 0.811+ patternSetFilter pattern FilterFast+ setSource pattern+ arc 0 0 (142/150) 0 (pi*2)+ fill+ restore++drawReflection = do+ save+ arc 0 0 (142/150) 0 (pi*2)+ clip+ rotate (-75 * pi/180)+ setSourceRGBA 0.87 0.9 0.95 0.25+ moveTo (-1) (-1)+ lineTo 1 (-1)+ lineTo 1 1+ curveTo 1 0.15 (-0.15) (-1) (-1) (-1)+ fill+ moveTo (-1) (-1)+ lineTo (-1) 1+ lineTo 1 1+ curveTo (-0.5) 1 (-1) 0.5 (-1) (-1)+ fill+ restore++drawFrame True = do+ save+ withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do+ patternAddColorStopRGB pattern 0 0.4 0.4 0.4+ patternAddColorStopRGB pattern 0.2 0.95 0.95 0.95+ patternSetFilter pattern FilterFast+ setSource pattern+ setLineWidth (10/75)+ arc 0 0 (142/150) 0 (pi*2)+ stroke++ withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do+ patternAddColorStopRGB pattern 0 0.9 0.9 0.9+ patternAddColorStopRGB pattern 0.2 0.35 0.35 0.35+ patternSetFilter pattern FilterFast+ setSource pattern+ setLineWidth (10/75)+ arc 0 0 (150/150) 0 (pi*2)+ stroke+ restore+drawFrame False = do+ save+ setSourceRGB 0 0 0+ setLineWidth (10/75)+ arc 0 0 1 0 (pi*2)+ stroke+ restore++initialSize :: Int+initialSize = 256++main = do+ initGUI++ window <- windowNew+ windowSetDecorated window False+ windowSetResizable window True+ windowSetPosition window WinPosCenterAlways++ widgetSetAppPaintable window True+ windowSetIconFromFile window "../cairo-clock-icon.png"+ windowSetTitle window "Gtk2Hs Cairo Clock"+ windowSetDefaultSize window initialSize initialSize+ windowSetGeometryHints window (Just window)+ (Just (32, 32)) (Just (512, 512))+ Nothing Nothing (Just (1,1))++ let setAlpha widget = do+ screen <- widgetGetScreen widget+ colormap <- screenGetRGBAColormap screen+ maybe (return ()) (widgetSetColormap widget) colormap+ setAlpha window --TODO: also call setAlpha on alpha screen change++ window `on` keyPressEvent $ tryEvent $ do+ "Escape" <- eventKeyName+ liftIO mainQuit++ window `on` buttonPressEvent $ tryEvent $ do+ LeftButton <- eventButton+ time <- eventTime+ (x,y) <- eventRootCoordinates+ liftIO $ windowBeginMoveDrag window LeftButton (round x) (round y) time++ window `on` buttonPressEvent $ tryEvent $ do+ MiddleButton <- eventButton+ time <- eventTime+ (x,y) <- eventRootCoordinates+ liftIO $ windowBeginResizeDrag window WindowEdgeSouthEast MiddleButton+ (round x) (round y) time++ timeoutAdd (widgetQueueDraw window >> return True) 1000++ backgroundRef <- newIORef (Just undefined)+ foregroundRef <- newIORef (Just undefined)++ let redrawStaticLayers = do+ (width, height) <- widgetGetSize window+ drawWin <- widgetGetDrawWindow window+ background <- createImageSurface FormatARGB32 width height+ foreground <- createImageSurface FormatARGB32 width height+ let clear = do+ save+ setOperator OperatorClear+ paint+ restore+ renderWith background $ do+ clear+ drawClockBackground True width height+ renderWith foreground $ do+ clear+ drawClockForeground True width height+ writeIORef backgroundRef (Just background)+ writeIORef foregroundRef (Just foreground)++ onRealize window redrawStaticLayers++ sizeRef <- newIORef (initialSize, initialSize)+ timeoutHandlerRef <- newIORef Nothing+ window `on` configureEvent $ do+ (w,h) <- eventSize+ liftIO $ do+ size <- readIORef sizeRef+ writeIORef sizeRef (w,h)+ when (size /= (w,h)) $ do++ background <- readIORef backgroundRef+ foreground <- readIORef foregroundRef+ maybe (return ()) surfaceFinish background+ maybe (return ()) surfaceFinish foreground++ writeIORef backgroundRef Nothing+ writeIORef foregroundRef Nothing++ timeoutHandler <- readIORef timeoutHandlerRef+ maybe (return ()) timeoutRemove timeoutHandler++ handler <- timeoutAddFull (do+ writeIORef timeoutHandlerRef Nothing+ redrawStaticLayers+ widgetQueueDraw window+ return False+ ) priorityDefaultIdle 300+ writeIORef timeoutHandlerRef (Just handler)++ return False++ window `on` exposeEvent $ do+ drawWin <- eventWindow+ exposeRegion <- eventRegion+ liftIO $ do+ (width, height) <- drawableGetSize drawWin++ background <- readIORef backgroundRef+ foreground <- readIORef foregroundRef++ renderWithDrawable drawWin $ do+ region exposeRegion+ clip++ save+ setOperator OperatorSource+ setSourceRGBA 0 0 0 0+ paint+ restore++ case background of+ Nothing -> drawClockBackground False width height+ Just background -> do+ setSourceSurface background 0 0+ paint++ drawClockHands (isJust background) width height++ case foreground of+ Nothing -> drawClockForeground False width height+ Just foreground -> do+ setSourceSurface foreground 0 0+ paint++ return True++ widgetShowAll window+ mainGUI
+ demo/gtk2/Drawing.hs view
@@ -0,0 +1,59 @@+-- Example of an drawing graphics onto a canvas.+import Graphics.UI.Gtk+import Graphics.Rendering.Cairo+import Graphics.UI.Gtk.Gdk.EventM++main = do+ initGUI+ dia <- dialogNew+ dialogAddButton dia stockOk ResponseOk+ contain <- dialogGetUpper dia+ canvas <- drawingAreaNew+ canvas `on` sizeRequest $ return (Requisition 40 40)+ ctxt <- cairoCreateContext Nothing+ text <- layoutEmpty ctxt+ text `layoutSetText` "Hello World."+ canvas `on` exposeEvent $ updateCanvas text+ boxPackStartDefaults contain canvas+ widgetShow canvas+ dialogRun dia+ return ()++updateCanvas :: PangoLayout -> EventM EExpose Bool+updateCanvas text = do+ win <- eventWindow+ liftIO $ do+ (width',height') <- drawableGetSize win+ let width = realToFrac width'+ height = realToFrac height'++ -- Draw using the cairo api+ renderWithDrawable win $ do+ setSourceRGB 1 0 0+ setLineWidth 20+ setLineCap LineCapRound+ setLineJoin LineJoinRound++ moveTo 30 30+ lineTo (width-30) (height-30)+ lineTo (width-30) 30+ lineTo 30 (height-30)+ stroke++ setSourceRGB 1 1 0+ setLineWidth 4++ save+ translate (width / 2) (height / 2)+ scale (width / 2) (height / 2)+ arc 0 0 1 (135 * pi/180) (225 * pi/180)+ restore+ stroke++ setSourceRGB 0 0 0+ moveTo 30 (realToFrac height / 4)+ rotate (pi/4)+ showLayout text+++ return True
+ demo/gtk2/Drawing2.hs view
@@ -0,0 +1,258 @@+--+-- Author: Johan Bockgård <bojohan@dd.chalmers.se>+--+-- This code is in the public domain.+--++import qualified Graphics.UI.Gtk as G+import qualified Graphics.Rendering.Cairo as C+import qualified Graphics.Rendering.Cairo.Matrix as M+++windowWidth, windowHeight :: Int+windowWidth = 500+windowHeight = 500++-- Write image to file+writePng :: IO ()+writePng =+ C.withImageSurface C.FormatARGB32 width height $ \ result -> do+ C.renderWith result $ example width height+ C.surfaceWriteToPNG result "Draw.png"+ where width = windowWidth+ height = windowHeight++-- Display image in window+main = do+ G.initGUI+ window <- G.windowNew+ canvas <- G.drawingAreaNew+ -- fix size+ -- G.windowSetResizable window False+ G.widgetSetSizeRequest window windowWidth windowHeight+ -- press any key to quit+ G.onKeyPress window $ const (do G.widgetDestroy window; return True)+ G.onDestroy window G.mainQuit+ G.onExpose canvas $ const (updateCanvas canvas)+ G.set window [G.containerChild G.:= canvas]+ G.widgetShowAll window+ G.mainGUI++updateCanvas :: G.DrawingArea -> IO Bool+updateCanvas canvas = do+ win <- G.widgetGetDrawWindow canvas+ (width, height) <- G.widgetGetSize canvas+ G.renderWithDrawable win $+ example width height+ return True++----------------------------------------------------------------++foreach :: (Monad m) => [a] -> (a -> m b) -> m [b]+foreach = flip mapM++keepState render = do+ C.save+ render+ C.restore++drawCircle x y r = do+ C.arc x y r 0 (2 * pi)+ fillStroke++drawRectangle x y w h = do+ C.rectangle x y w h+ fillStroke++stroke =+ keepState $ do+ C.setSourceRGBA 0 0 0 0.7+ C.stroke++fillStroke = do+ C.fillPreserve+ stroke++----------------------------------------------------------------++-- Example++example width height = do+ prologue width height+ example1++-- Set up stuff+prologue wWidth wHeight = do+ let width = 10+ height = 10+ xmax = width / 2+ xmin = - xmax+ ymax = height / 2+ ymin = - ymax+ scaleX = realToFrac wWidth / width+ scaleY = realToFrac wHeight / height++ -- style and color+ C.setLineCap C.LineCapRound+ C.setLineJoin C.LineJoinRound+ C.setLineWidth $ 1 / max scaleX scaleY+ C.setSourceRGBA 0.5 0.7 0.5 0.5++ -- Set up user coordinates+ C.scale scaleX scaleY+ -- center origin+ C.translate (width / 2) (height / 2)+ -- positive y-axis upwards+ let flipY = M.Matrix 1 0 0 (-1) 0 0+ C.transform flipY++ grid xmin xmax ymin ymax+++-- Grid and axes+grid xmin xmax ymin ymax =+ keepState $ do+ C.setSourceRGBA 0 0 0 0.7+ -- axes+ C.moveTo 0 ymin; C.lineTo 0 ymax; C.stroke+ C.moveTo xmin 0; C.lineTo xmax 0; C.stroke+ -- grid+ C.setDash [0.01, 0.99] 0+ foreach [xmin .. xmax] $ \ x ->+ do C.moveTo x ymin+ C.lineTo x ymax+ C.stroke++example1 = do+ -- circles+ drawCircle 0 0 1+ drawCircle 2 2 3+ -- a bunch of rectangles+ keepState $+ foreach [1 .. 5] $ \ _ ->+ do drawRectangle 0 1 2 3+ C.rotate (pi/8)+ -- some cute stuff+ thought+ apple+ snake++thought =+ keepState $ do+ C.scale 0.04 0.04+ C.translate (200) (380)+ C.rotate pi+ C.setSourceRGBA 0.5 0.5 1 0.7+ C.setLineWidth 1+ image+ fillStroke+ where+ m = C.moveTo+ c = C.curveTo+ z = C.closePath+ image = do+ m 184 327+ c 176 327 170 332 168 339+ c 166 333 160 329 153 329+ c 147 329 141 333 138 339+ c 137 339 136 338 134 338+ c 125 338 118 345 118 354+ c 118 363 125 371 134 371+ c 137 371 140 370 142 368+ c 142 368 142 368 142 369+ c 142 377 149 385 158 385+ c 162 385 166 383 168 381+ c 171 386 176 390 183 390+ c 188 390 193 387 196 383+ c 198 384 201 385 204 385+ c 212 385 220 378 220 369+ c 222 371 225 372 228 372+ c 237 372 244 364 244 355+ c 244 346 237 339 228 339+ c 227 339 226 339 225 340+ c 223 332 217 327 209 327+ c 204 327 199 330 196 333+ c 193 330 189 327 184 327+ z+ m 164 387+ c 158 387 153 391 153 397+ c 153 402 158 407 164 407+ c 170 407 174 402 174 397+ c 174 391 170 387 164 387+ z+ m 152 408+ c 149 408 146 411 146 414+ c 146 417 149 420 152 420+ c 155 420 158 417 158 414+ c 158 411 155 408 152 408+ z+ m 143 422+ c 141 422 139 424 139 426+ c 139 428 141 429 143 429+ c 144 429 146 428 146 426+ c 146 424 144 422 143 422+ z++apple =+ keepState $ do+ C.scale 0.05 0.05+ C.translate (1110) (220)+ C.rotate pi+ C.setLineWidth 0.5+ C.setSourceRGBA 0 0 0 0.7+ image1+ fillStroke+ C.setSourceRGBA 1 0 0 0.7+ image2+ fillStroke+ where+ m = C.moveTo+ c = C.curveTo+ z = C.closePath+ l = C.lineTo+ image1 = do+ m 1149 245+ l 1156 244+ l 1155 252+ l 1149 245+ z+ image2 = do+ m 1151 249+ c 1145 249 1140 254 1140 261+ c 1140 268 1145 273 1151 273+ c 1152 273 1153 273 1154 272+ c 1156 273 1157 273 1158 273+ c 1164 273 1169 268 1169 261+ c 1169 254 1164 249 1158 249+ c 1157 249 1156 249 1154 250+ c 1153 249 1152 249 1151 249+ z++snake =+ keepState $ do+ C.scale 0.04 0.04+ C.translate (150) (220)+ C.rotate pi+ C.setLineWidth 0.5+ C.setSourceRGBA 0.1 0.1 0 0.7+ image+ fillStroke+ where+ m = C.moveTo+ c = C.curveTo+ z = C.closePath+ l = C.lineTo+ image = do+ m 146 320+ c 143 308 130 314 123 319+ c 115 324 108 311 100 314+ c 93 317 92 319 81 318+ c 76 318 60 309 60 320+ c 60 328 73 321 82 323+ c 94 326 98 317 106 320+ c 113 323 120 330 128 323+ c 133 318 142 312 146 320+ l 146 320+ z++----------------------------------------------------------------
+ demo/gtk2/Graph.hs view
@@ -0,0 +1,98 @@+--+-- Author: Michael Sloan <mgsloan@gmail.com>+--+-- This code is in the public domain.+--+-- Based off Johan Bockgård's Drawing2.hs+--++import qualified Graphics.UI.Gtk as G+import qualified Graphics.Rendering.Cairo as C+import qualified Graphics.Rendering.Cairo.Matrix as M++f x = sin (x*5) / (x*5)++main = graph f++graph :: (Double -> Double) -> IO ()+graph f = do+ G.initGUI+ window <- G.windowNew+ canvas <- G.drawingAreaNew+ G.windowSetResizable window False+ G.widgetSetSizeRequest window 600 600+ -- press any key to quit+ G.onKeyPress window $ const (do G.widgetDestroy window; return True)+ G.onDestroy window G.mainQuit+ G.onExpose canvas $ const $ render f canvas+ G.set window [G.containerChild G.:= canvas]+ G.widgetShowAll window+ G.mainGUI++render :: (Double -> Double) -> G.DrawingArea -> IO Bool+render f canvas = do+ win <- G.widgetGetDrawWindow canvas+ (width, height) <- G.widgetGetSize canvas+ G.renderWithDrawable win $ (prologue width height >> renderG f)+ return True++foreach :: (Monad m) => [a] -> (a -> m b) -> m [b]+foreach = flip mapM++deriv :: (Double -> Double) -> Double -> Double+deriv f x = ((f $ x + 0.05) - (f $ x - 0.05)) * 10++gen :: Double -> Double -> (Double -> Double) -> [Double]+gen v t f | v > t = []+gen v t f = v : (gen (f v) t f)++skipBy f = foldr (\x c -> if f x then c else x : c) []++falloff x = 0.25 * (x + 1.5) / ((x+0.5)^5 + 1)++renderG :: (Double -> Double) -> C.Render ()+renderG f = do+ C.moveTo (-5) (f (-5))+ sequence_ $ map (\d -> C.lineTo d $ f d) $ skipBy (isInfinite . f) [-4.9,-4.8..5]+ --Adaptive attempt (falloff func is what really needs work)+ --sequence_ $ map (\d -> C.lineTo d $ f d) $ skipBy (isInfinite . f) $ tail $ gen (-5) 5 (\x -> x + (falloff $ abs $ deriv (deriv f) x))+ C.stroke++-- Set up stuff+prologue wWidth wHeight = do+ let width = 10+ height = 10+ xmax = width / 2+ xmin = - xmax+ ymax = height / 2+ ymin = - ymax+ scaleX = realToFrac wWidth / width+ scaleY = realToFrac wHeight / height++ -- style and color+ C.setLineCap C.LineCapRound+ C.setLineJoin C.LineJoinRound+ C.setLineWidth $ 1 / max scaleX scaleY++ -- Set up user coordinates+ C.scale scaleX scaleY+ -- center origin+ C.translate (width / 2) (height / 2)+ -- positive y-axis upwards+ let flipY = M.Matrix 1 0 0 (-1) 0 0+ C.transform flipY+ C.setSourceRGBA 0 0 0 1+ grid xmin xmax ymin ymax++-- Grid and axes+grid xmin xmax ymin ymax = do+ -- axes+ C.moveTo 0 ymin; C.lineTo 0 ymax; C.stroke+ C.moveTo xmin 0; C.lineTo xmax 0; C.stroke+ -- grid+ C.setDash [0.01, 0.99] 0+ foreach [xmin .. xmax] $ \ x ->+ do C.moveTo x ymin+ C.lineTo x ymax+ C.stroke+ C.setDash [] 0
+ demo/gtk2/Makefile view
@@ -0,0 +1,33 @@++PROGS = drawing drawing2 starandring text clock graph sdldrawing+SOURCES = Drawing.hs Drawing2.hs StarAndRing.hs Text.hs Clock.hs Graph.hs CairoSDL.hs++all : $(PROGS)++drawing : Drawing.hs+ $(HC_RULE)++drawing2 : Drawing2.hs+ $(HC_RULE)++starandring : StarAndRing.hs+ $(HC_RULE)++text : Text.hs+ $(HC_RULE)++clock : Clock.hs+ $(HC_RULE)++graph : Graph.hs+ $(HC_RULE)++sdldrawing : CairoSDL.hs+ $(HC_RULE)++HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS)++clean:+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)++HC=ghc
+ demo/gtk2/StarAndRing.hs view
@@ -0,0 +1,111 @@+import Graphics.Rendering.Cairo+import qualified Graphics.Rendering.Cairo.Matrix as M++ringPath :: Render ()+ringPath = do+ moveTo 200.86568 667.80795+ curveTo 110.32266 562.62134 122.22863 403.77940 227.41524 313.23637+ curveTo 332.60185 222.69334 491.42341 234.57563 581.96644 339.76224+ curveTo 672.50948 444.94884 660.64756 603.79410 555.46095 694.33712+ curveTo 450.27436 784.88016 291.40871 772.99456 200.86568 667.80795+ closePath+ moveTo 272.14411 365.19927+ curveTo 195.64476 431.04875 186.97911 546.57972 252.82859 623.07908+ curveTo 318.67807 699.57844 434.23272 708.22370 510.73208 642.37422+ curveTo 587.23144 576.52474 595.85301 460.99047 530.00354 384.49112+ curveTo 464.15406 307.99176 348.64347 299.34979 272.14411 365.19927+ closePath++starPath :: Render ()+starPath = do+ transform (M.Matrix 0.647919 (-0.761710) 0.761710 0.647919 (-208.7977) 462.0608)+ moveTo 505.80857 746.23606+ lineTo 335.06870 555.86488+ lineTo 91.840384 635.31360+ lineTo 282.21157 464.57374+ lineTo 202.76285 221.34542+ lineTo 373.50271 411.71660+ lineTo 616.73103 332.26788+ lineTo 426.35984 503.00775+ lineTo 505.80857 746.23606+ closePath++fillRing :: Render ()+fillRing = do+ save+ translate (-90) (-205)+ ringPath+ setSourceRGBA 1.0 0.0 0.0 0.75+ fill+ restore++fillStar :: Render ()+fillStar = do+ save+ translate (-90) (-205)+ starPath+ setSourceRGBA 0.0 0.0 ((fromIntegral 0xae) / (fromIntegral 0xff)) 0.55135137+ fill+ restore++clipToTopAndBottom :: Int -> Int -> Render ()+clipToTopAndBottom width height = do+ moveTo 0 0+ lineTo (fromIntegral width) 0.0+ lineTo 0.0 (fromIntegral height)+ lineTo (fromIntegral width) (fromIntegral height)+ closePath+ clip+ newPath++clipToLeftAndRight :: Int -> Int -> Render ()+clipToLeftAndRight width height = do+ moveTo 0 0+ lineTo 0.0 (fromIntegral height)+ lineTo (fromIntegral width) 0.0+ lineTo (fromIntegral width) (fromIntegral height)+ closePath+ clip+ newPath++starAndRing :: Int -> Int -> Render ()+starAndRing width height = do+ setOperator OperatorClear+ paint++ setOperator OperatorAdd++ renderWithSimilarSurface ContentColorAlpha width height $ \ringOverStar -> do+ renderWith ringOverStar $ do+ clipToTopAndBottom width height+ fillStar+ fillRing+ setSourceSurface ringOverStar 0 0+ paint++ renderWithSimilarSurface ContentColorAlpha width height $ \starOverRing -> do+ renderWith starOverRing $ do+ clipToLeftAndRight width height+ fillRing+ fillStar+ setSourceSurface starOverRing 0 0+ paint++main :: IO ()+main = do+ withImageSurface FormatARGB32 width height $ \result -> do+ renderWith result $ starAndRing width height+ surfaceWriteToPNG result "StarAndRing.png"+ putStrLn "wrote StarAndRing.png"+ withPDFSurface "StarAndRing.pdf" (fromIntegral width) (fromIntegral height)+ (flip renderWith $ starAndRing width height >> showPage)+ putStrLn "wrote StarAndRing.pdf"+ withPSSurface "StarAndRing.ps" (fromIntegral width) (fromIntegral height)+ (flip renderWith $ starAndRing width height >> showPage)+ putStrLn "wrote StarAndRing.ps"+ withSVGSurface "StarAndRing.svg" (fromIntegral width) (fromIntegral height)+ (flip renderWith $ starAndRing width height)+ putStrLn "wrote StarAndRing.svg"++ where width = 600+ height = 600
+ demo/gtk2/Text.hs view
@@ -0,0 +1,71 @@+import Graphics.Rendering.Cairo+import qualified Graphics.Rendering.Cairo.Matrix as M++boxText :: String -> Double -> Double -> Render ()+boxText text x y = do+ save++ lineWidth <- getLineWidth++ (TextExtents xb yb w h _ _) <- textExtents text++ rectangle (x + xb - lineWidth)+ (y + yb - lineWidth)+ (w + 2 * lineWidth)+ (h + 2 * lineWidth)+ stroke+ moveTo x y+ textPath text+ fillPreserve+ setSourceRGBA 0 0 1 0.5+ setLineWidth 3.0+ stroke++ restore++transpSurface :: Double -> Double -> Render ()+transpSurface w h = do+ save+ rectangle 0 0 w h+ setSourceRGBA 0 0 0 0+ setOperator OperatorSource+ fill+ restore++width = 400+height = 300++main :: IO ()+main = withImageSurface FormatARGB32 width height $ \surface -> do+ renderWith surface $ do+ setSourceRGB 0.0 0.0 0.0+ setLineWidth 2.0++ transpSurface (fromIntegral width) (fromIntegral height)++ selectFontFace "sans" FontSlantNormal FontWeightNormal+ setFontSize 40++ extents <- fontExtents+ let fontHeight = fontExtentsHeight extents++ boxText "Howdy, world!" 10 fontHeight++ translate 0 fontHeight++ save+ translate 10 fontHeight+ rotate (10.0 * pi / 180.0)+ boxText "Yay for Haskell!" 0 0+ restore++ translate 0 (3 * fontHeight)++ save+ setFontMatrix $ M.rotate ((-10.0) * pi / 180.0) $ M.scale 40.0 40.0 M.identity+ boxText "...and Cairo!" 10 fontHeight+ restore++ surfaceWriteToPNG surface "Text.png"++ return ()
+ demo/gtk3/CairoGhci.hs view
@@ -0,0 +1,76 @@+-- Example of an drawing graphics onto a canvas.+import Graphics.UI.Gtk+import Graphics.Rendering.Cairo+import Control.Monad.Trans ( liftIO )+import Graphics.UI.Gtk.Gdk.EventM++run :: Render () -> IO ()+run act = do+ initGUI+ dia <- dialogNew+ dialogAddButton dia stockClose ResponseClose+ contain <- dialogGetUpper dia+ canvas <- drawingAreaNew+ canvas `onSizeRequest` return (Requisition 250 250)+ canvas `on` exposeEvent $ tryEvent $ updateCanvas canvas act+ boxPackStartDefaults contain canvas+ widgetShow canvas+ dialogRun dia+ widgetDestroy dia+ -- Flush all commands that are waiting to be sent to the graphics server.+ -- This ensures that the window is actually closed before ghci displays the+ -- prompt again.+ flush++ where updateCanvas :: DrawingArea -> Render () -> EventM EExpose ()+ updateCanvas canvas act = liftIO $ do+ win <- widgetGetDrawWindow canvas+ renderWithDrawable win act++setRed :: Render ()+setRed = do+ setSourceRGB 1 0 0++++setFat :: Render ()+setFat = do+ setLineWidth 20+ setLineCap LineCapRound++++drawSquare :: Double -> Double -> Render ()+drawSquare width height = do+ (x,y) <- getCurrentPoint+ lineTo (x+width) y+ lineTo (x+width) (y+height)+ lineTo x (y+height)+ closePath+ stroke++++drawHCirc :: Double -> Double -> Double -> Render ()+drawHCirc x y radius = do+ arc x y radius 0 pi+ stroke++++drawStr :: String -> Render ()+drawStr txt = do+ lay <- createLayout txt+ showLayout lay++++drawStr_ :: String -> Render ()+drawStr_ txt = do+ lay <- liftIO $ do+ ctxt <- cairoCreateContext Nothing+ descr <- contextGetFontDescription ctxt+ descr `fontDescriptionSetSize` 20+ ctxt `contextSetFontDescription` descr+ layoutText ctxt txt+ showLayout lay
+ demo/gtk3/Clock.hs view
@@ -0,0 +1,327 @@+{-# LANGUAGE OverloadedStrings #-}++-- original author:+-- Mirco "MacSlow" Mueller <macslow@bangang.de>+--+-- created:+-- 10.1.2006 (or so)+--+-- http://www.gnu.org/licenses/licenses.html#GPL+--+-- ported to Haskell by:+-- Duncan Coutts <duncan.coutts@worc.ox.ac.uk>+--+-- updated to GTK 3 by Catherine Holloway+--++import Graphics.Rendering.Cairo+import Graphics.UI.Gtk+import Graphics.UI.Gtk.Gdk.EventM+import Data.Time+import Control.Monad (when)+import Data.Maybe (isJust)+import Data.IORef+import Data.Text++drawClockBackground :: WidgetClass widget => widget -> Bool -> Render ()+drawClockBackground canvas quality = do++ width <- liftIO $ widgetGetAllocatedWidth canvas+ height <- liftIO $ widgetGetAllocatedHeight canvas+ save+ scale (fromIntegral width) (fromIntegral height)++ save+ setOperator OperatorOver+ when quality drawDropShadow+ drawClockFace quality+ restore++ translate 0.5 0.5+ scale 0.4 0.4+ setSourceRGB 0.16 0.18 0.19+ setLineWidth (1.5/60)+ setLineCap LineCapRound+ setLineJoin LineJoinRound+ drawHourMarks++ restore++drawClockHands :: WidgetClass widget => widget -> Bool -> Render ()+drawClockHands canvas quality = do++ width <- liftIO $ widgetGetAllocatedWidth canvas+ height <- liftIO $ widgetGetAllocatedHeight canvas+ save+ scale (fromIntegral width) (fromIntegral height)++ translate 0.5 0.5+ scale 0.4 0.4+ setSourceRGB 0.16 0.18 0.19+ setLineWidth (1.5/60)+ setLineCap LineCapRound+ setLineJoin LineJoinRound++ time <- liftIO (localTimeOfDay . zonedTimeToLocalTime <$> getZonedTime)+ let hours = fromIntegral (todHour time `mod` 12)+ minutes = fromIntegral (todMin time)+ seconds = realToFrac (todSec time)++ drawHourHand quality hours minutes seconds+ drawMinuteHand quality minutes seconds+ drawSecondHand quality seconds++ restore++drawClockForeground :: Bool -> Int -> Int -> Render ()+drawClockForeground quality width height = do+ scale (fromIntegral width) (fromIntegral height)++ save+ translate 0.5 0.5+ scale 0.4 0.4+ setSourceRGB 0.16 0.18 0.19+ setLineWidth (1.5/60)+ setLineCap LineCapRound+ setLineJoin LineJoinRound++ when quality drawInnerShadow+ when quality drawReflection+ drawFrame quality+ restore++drawDropShadow =+ withRadialPattern 0.55 0.55 0.25 0.5 0.5 0.525 $ \pattern -> do+ patternAddColorStopRGBA pattern 0 0 0 0 0.811+ patternAddColorStopRGBA pattern 0.64 0.345 0.345 0.345 0.317+ patternAddColorStopRGBA pattern 0.84 0.713 0.713 0.713 0.137+ patternAddColorStopRGBA pattern 1 1 1 1 0+ patternSetFilter pattern FilterFast+ setSource pattern+ arc 0.5 0.5 (142/150) 0 (pi*2)+ fill++drawClockFace True =+ withLinearPattern 0.5 0 0.5 1 $ \pattern -> do+ patternAddColorStopRGB pattern 0 0.91 0.96 0.93+ patternAddColorStopRGB pattern 1 0.65 0.68 0.68+ patternSetFilter pattern FilterFast+ setSource pattern+ translate 0.5 0.5+ arc 0 0 (60/150) 0 (pi*2)+ fill+drawClockFace False = do+ setSourceRGB 0.78 0.82 0.805+ translate 0.5 0.5+ arc 0 0 (60/150) 0 (pi*2)+ fill++drawHourMarks = do+ save+ forM_ [1..12] $ \_ -> do+ rotate (pi/6)+ moveTo (4.5/6) 0+ lineTo (5.0/6) 0+ stroke+ restore++forM_ = flip mapM_++drawHourHand quality hours minutes seconds = do+ save+ rotate (-pi/2)+ setLineCap LineCapSquare+ setLineJoin LineJoinMiter+ rotate ( (pi/6) * hours+ + (pi/360) * minutes+ + (pi/21600) * seconds)++ -- hour hand's shadow+ when quality $ do+ setLineWidth (1.75/60)+ setOperator OperatorAtop+ setSourceRGBA 0.16 0.18 0.19 0.125+ moveTo (-2/15 + 0.025) 0.025+ lineTo (7/15 + 0.025) 0.025+ stroke++ -- the hand itself+ setLineWidth (1/60)+ setOperator OperatorOver+ setSourceRGB 0.16 0.18 0.19+ moveTo (-2/15) 0+ lineTo (7/15) 0+ stroke+ restore++drawMinuteHand quality minutes seconds = do+ save+ rotate (-pi/2)+ setLineCap LineCapSquare+ setLineJoin LineJoinMiter+ rotate ( (pi/30) * minutes+ + (pi/1800) * seconds)++ -- minute hand's shadow+ when quality $ do+ setLineWidth (1.75/60)+ setOperator OperatorAtop+ setSourceRGBA 0.16 0.18 0.19 0.125+ moveTo (-16/75 - 0.025) (-0.025)+ lineTo (2/3 - 0.025) (-0.025)+ stroke++ -- the minute hand itself+ setLineWidth (1/60)+ setOperator OperatorOver+ setSourceRGB 0.16 0.18 0.19+ moveTo (-16/75) 0+ lineTo (2/3) 0+ stroke+ restore++drawSecondHand quality seconds = do+ save+ rotate (-pi/2)+ setLineCap LineCapSquare+ setLineJoin LineJoinMiter+ rotate (seconds * pi/30);++ -- shadow of second hand-part+ when quality $ do+ setOperator OperatorAtop+ setSourceRGBA 0.16 0.18 0.19 0.125+ setLineWidth (1.3125 / 60)+ moveTo (-1.5/5 + 0.025) 0.025+ lineTo (3/5 + 0.025) 0.025+ stroke++ -- second hand+ setOperator OperatorOver+ setSourceRGB 0.39 0.58 0.77+ setLineWidth (0.75/60)+ moveTo (-1.5/5) 0+ lineTo (3/5) 0+ stroke++ arc 0 0 (1/20) 0 (pi*2)+ fill+ arc (63/100) 0 (1/35) 0 (pi*2)+ stroke+ setLineWidth (1/100)+ moveTo (10/15) 0+ lineTo (12/15) 0+ stroke+ setSourceRGB 0.31 0.31 0.31+ arc 0 0 (1/25) 0 (pi*2)+ fill+ restore++drawInnerShadow = do+ save+ setOperator OperatorOver+ arc 0 0 (142/150) 0 (pi*2)+ clip+ withRadialPattern 0.3 0.3 0.1 0 0 0.95 $ \pattern -> do+ patternAddColorStopRGBA pattern 0 1 1 1 0+ patternAddColorStopRGBA pattern 0.64 0.713 0.713 0.713 0.137+ patternAddColorStopRGBA pattern 0.84 0.345 0.345 0.345 0.317+ patternAddColorStopRGBA pattern 1 0 0 0 0.811+ patternSetFilter pattern FilterFast+ setSource pattern+ arc 0 0 (142/150) 0 (pi*2)+ fill+ restore++drawReflection = do+ save+ arc 0 0 (142/150) 0 (pi*2)+ clip+ rotate (-75 * pi/180)+ setSourceRGBA 0.87 0.9 0.95 0.25+ moveTo (-1) (-1)+ lineTo 1 (-1)+ lineTo 1 1+ curveTo 1 0.15 (-0.15) (-1) (-1) (-1)+ fill+ moveTo (-1) (-1)+ lineTo (-1) 1+ lineTo 1 1+ curveTo (-0.5) 1 (-1) 0.5 (-1) (-1)+ fill+ restore++drawFrame True = do+ save+ withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do+ patternAddColorStopRGB pattern 0 0.4 0.4 0.4+ patternAddColorStopRGB pattern 0.2 0.95 0.95 0.95+ patternSetFilter pattern FilterFast+ setSource pattern+ setLineWidth (10/75)+ arc 0 0 (142/150) 0 (pi*2)+ stroke++ withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do+ patternAddColorStopRGB pattern 0 0.9 0.9 0.9+ patternAddColorStopRGB pattern 0.2 0.35 0.35 0.35+ patternSetFilter pattern FilterFast+ setSource pattern+ setLineWidth (10/75)+ arc 0 0 (150/150) 0 (pi*2)+ stroke+ restore+drawFrame False = do+ save+ setSourceRGB 0 0 0+ setLineWidth (10/75)+ arc 0 0 1 0 (pi*2)+ stroke+ restore++initialSize :: Int+initialSize = 256++main = do+ initGUI+ window <- windowNew+ windowSetPosition window WinPosCenterAlways++ widgetSetAppPaintable window True+ windowSetIconFromFile window "../cairo-clock-icon.png"++ windowSetDefaultSize window initialSize initialSize+ windowSetGeometryHints window (Just window)+ (Just (32, 32)) (Just (512, 512))+ Nothing Nothing (Just (1,1))+++ window `on` keyPressEvent $ tryEvent $ do+ "Escape" <- eventKeyName+ liftIO mainQuit++ window `on` buttonPressEvent $ tryEvent $ do+ LeftButton <- eventButton+ time <- eventTime+ (x,y) <- eventRootCoordinates+ liftIO $ windowBeginMoveDrag window LeftButton (round x) (round y) time++ window `on` buttonPressEvent $ tryEvent $ do+ MiddleButton <- eventButton+ time <- eventTime+ (x,y) <- eventRootCoordinates+ liftIO $ windowBeginResizeDrag window WindowEdgeSouthEast MiddleButton+ (round x) (round y) time++ canvas <- drawingAreaNew+ ctxt <- cairoCreateContext Nothing+ text <- layoutEmpty ctxt+ text `layoutSetText` (pack "Hello World.")++ canvas `on` draw $ drawClockBackground canvas True+ canvas `on` draw $ drawClockHands canvas True+ set window [ containerChild := canvas, windowDecorated := False,+ windowResizable := True, windowTitle := (pack "Gtk2Hs Cairo Clock") ]+ widgetShowAll window+ timeoutAdd (widgetQueueDraw window >> return True) 1000+ mainGUI
+ demo/gtk3/Drawing.hs view
@@ -0,0 +1,58 @@+-- Example of an drawing graphics onto a canvas.+import Graphics.UI.Gtk+import qualified Graphics.UI.Gtk as Gtk+import Graphics.Rendering.Cairo+import Graphics.UI.Gtk.Gdk.EventM++main = do+ initGUI+ dia <- dialogNew+ -- in newer versions of GTK, 'size-request' is an invalid signal for Drawing areas,+ -- so the default size of the window will be changed instead.+ windowSetDefaultSize dia 400 400+ dialogAddButton dia stockOk ResponseOk+ contain <- dialogGetContentArea dia+ canvas <- drawingAreaNew+ ctxt <- cairoCreateContext Nothing+ text <- layoutEmpty ctxt+ text `layoutSetText` "Hello World."+ canvas `on` draw $ updateCanvas canvas text+ boxPackStart (castToBox contain) canvas PackGrow 0+ widgetShow canvas+ dialogRun dia+ return ()++updateCanvas :: WidgetClass widget => widget -> PangoLayout -> Render ()+updateCanvas canvas text = do+ width' <- liftIO $ widgetGetAllocatedWidth canvas+ height' <- liftIO $ widgetGetAllocatedHeight canvas+ let width = realToFrac width'+ height = realToFrac height'++ setSourceRGB 1 0 0+ setLineWidth 20+ setLineCap LineCapRound+ setLineJoin LineJoinRound++ moveTo 30 30+ lineTo (width-30) (height-30)+ lineTo (width-30) 30+ lineTo 30 (height-30)+ stroke++ setSourceRGB 1 1 0+ setLineWidth 4++ save+ translate (width / 2) (height / 2)+ scale (width / 2) (height / 2)+ arc 0 0 1 (135 * pi/180) (225 * pi/180)+ restore+ stroke++ setSourceRGB 0 0 0+ moveTo 30 (realToFrac height / 4)+ rotate (pi/4)+ showLayout text++
+ demo/gtk3/Drawing2.hs view
@@ -0,0 +1,261 @@+--+-- Author: Johan Bockgård <bojohan@dd.chalmers.se>+--+-- This code is in the public domain.+--++import qualified Graphics.UI.Gtk as G+import qualified Graphics.Rendering.Cairo as C+import qualified Graphics.Rendering.Cairo.Matrix as M+++windowWidth, windowHeight :: Int+windowWidth = 500+windowHeight = 500++-- Write image to file+writePng :: IO ()+writePng =+ C.withImageSurface C.FormatARGB32 width height $ \ result -> do+ C.renderWith result $ example width height+ C.surfaceWriteToPNG result "Draw.png"+ where width = windowWidth+ height = windowHeight++-- Display image in window+main = do+ G.initGUI+ window <- G.windowNew+ canvas <- G.drawingAreaNew+ G.windowSetDefaultSize window windowWidth windowWidth+ G.windowSetGeometryHints window (Just window)+ (Just (1, 1)) (Just (windowWidth, windowWidth))+ Nothing Nothing (Just (1,1))++ -- press any key to quit+ window `G.on` G.keyPressEvent $ G.tryEvent $ do C.liftIO G.mainQuit++ canvas `G.on` G.draw $ updateCanvas canvas++ G.set window [G.containerChild G.:= canvas]+ G.widgetShowAll window+ G.mainGUI++updateCanvas :: G.WidgetClass widget => widget -> C.Render ()+updateCanvas canvas = do+ width' <- C.liftIO $ G.widgetGetAllocatedWidth canvas+ height' <- C.liftIO $ G.widgetGetAllocatedHeight canvas+ let width = realToFrac width'+ height = realToFrac height'+ example width height++----------------------------------------------------------------++foreach :: (Monad m) => [a] -> (a -> m b) -> m [b]+foreach = flip mapM++keepState render = do+ C.save+ render+ C.restore++drawCircle x y r = do+ C.arc x y r 0 (2 * pi)+ fillStroke++drawRectangle x y w h = do+ C.rectangle x y w h+ fillStroke++stroke =+ keepState $ do+ C.setSourceRGBA 0 0 0 0.7+ C.stroke++fillStroke = do+ C.fillPreserve+ stroke++----------------------------------------------------------------++-- Example++example width height = do+ prologue width height+ example1++-- Set up stuff+prologue wWidth wHeight = do+ let width = 10+ height = 10+ xmax = width / 2+ xmin = - xmax+ ymax = height / 2+ ymin = - ymax+ scaleX = realToFrac wWidth / width+ scaleY = realToFrac wHeight / height++ -- style and color+ C.setLineCap C.LineCapRound+ C.setLineJoin C.LineJoinRound+ C.setLineWidth $ 1 / max scaleX scaleY+ C.setSourceRGBA 0.5 0.7 0.5 0.5++ -- Set up user coordinates+ C.scale scaleX scaleY+ -- center origin+ C.translate (width / 2) (height / 2)+ -- positive y-axis upwards+ let flipY = M.Matrix 1 0 0 (-1) 0 0+ C.transform flipY++ grid xmin xmax ymin ymax+++-- Grid and axes+grid xmin xmax ymin ymax =+ keepState $ do+ C.setSourceRGBA 0 0 0 0.7+ -- axes+ C.moveTo 0 ymin; C.lineTo 0 ymax; C.stroke+ C.moveTo xmin 0; C.lineTo xmax 0; C.stroke+ -- grid+ C.setDash [0.01, 0.99] 0+ foreach [xmin .. xmax] $ \ x ->+ do C.moveTo x ymin+ C.lineTo x ymax+ C.stroke++example1 = do+ -- circles+ drawCircle 0 0 1+ drawCircle 2 2 3+ -- a bunch of rectangles+ keepState $+ foreach [1 .. 5] $ \ _ ->+ do drawRectangle 0 1 2 3+ C.rotate (pi/8)+ -- some cute stuff+ thought+ apple+ snake++thought =+ keepState $ do+ C.scale 0.04 0.04+ C.translate (200) (380)+ C.rotate pi+ C.setSourceRGBA 0.5 0.5 1 0.7+ C.setLineWidth 1+ image+ fillStroke+ where+ m = C.moveTo+ c = C.curveTo+ z = C.closePath+ image = do+ m 184 327+ c 176 327 170 332 168 339+ c 166 333 160 329 153 329+ c 147 329 141 333 138 339+ c 137 339 136 338 134 338+ c 125 338 118 345 118 354+ c 118 363 125 371 134 371+ c 137 371 140 370 142 368+ c 142 368 142 368 142 369+ c 142 377 149 385 158 385+ c 162 385 166 383 168 381+ c 171 386 176 390 183 390+ c 188 390 193 387 196 383+ c 198 384 201 385 204 385+ c 212 385 220 378 220 369+ c 222 371 225 372 228 372+ c 237 372 244 364 244 355+ c 244 346 237 339 228 339+ c 227 339 226 339 225 340+ c 223 332 217 327 209 327+ c 204 327 199 330 196 333+ c 193 330 189 327 184 327+ z+ m 164 387+ c 158 387 153 391 153 397+ c 153 402 158 407 164 407+ c 170 407 174 402 174 397+ c 174 391 170 387 164 387+ z+ m 152 408+ c 149 408 146 411 146 414+ c 146 417 149 420 152 420+ c 155 420 158 417 158 414+ c 158 411 155 408 152 408+ z+ m 143 422+ c 141 422 139 424 139 426+ c 139 428 141 429 143 429+ c 144 429 146 428 146 426+ c 146 424 144 422 143 422+ z++apple =+ keepState $ do+ C.scale 0.05 0.05+ C.translate (1110) (220)+ C.rotate pi+ C.setLineWidth 0.5+ C.setSourceRGBA 0 0 0 0.7+ image1+ fillStroke+ C.setSourceRGBA 1 0 0 0.7+ image2+ fillStroke+ where+ m = C.moveTo+ c = C.curveTo+ z = C.closePath+ l = C.lineTo+ image1 = do+ m 1149 245+ l 1156 244+ l 1155 252+ l 1149 245+ z+ image2 = do+ m 1151 249+ c 1145 249 1140 254 1140 261+ c 1140 268 1145 273 1151 273+ c 1152 273 1153 273 1154 272+ c 1156 273 1157 273 1158 273+ c 1164 273 1169 268 1169 261+ c 1169 254 1164 249 1158 249+ c 1157 249 1156 249 1154 250+ c 1153 249 1152 249 1151 249+ z++snake =+ keepState $ do+ C.scale 0.04 0.04+ C.translate (150) (220)+ C.rotate pi+ C.setLineWidth 0.5+ C.setSourceRGBA 0.1 0.1 0 0.7+ image+ fillStroke+ where+ m = C.moveTo+ c = C.curveTo+ z = C.closePath+ l = C.lineTo+ image = do+ m 146 320+ c 143 308 130 314 123 319+ c 115 324 108 311 100 314+ c 93 317 92 319 81 318+ c 76 318 60 309 60 320+ c 60 328 73 321 82 323+ c 94 326 98 317 106 320+ c 113 323 120 330 128 323+ c 133 318 142 312 146 320+ l 146 320+ z++----------------------------------------------------------------
+ demo/gtk3/Graph.hs view
@@ -0,0 +1,102 @@+--+-- Author: Michael Sloan <mgsloan@gmail.com>+--+-- This code is in the public domain.+--+-- Based off Johan Bockgård's Drawing2.hs+--+-- updated to GTK 3 by Catherine Holloway+--+import qualified Graphics.UI.Gtk as G+import qualified Graphics.Rendering.Cairo as C+import qualified Graphics.Rendering.Cairo.Matrix as M++f x = sin (x*5) / (x*5)++main = graph f++windowSize :: Int+windowSize = 400++graph :: (Double -> Double) -> IO ()+graph f = do+ G.initGUI+ window <- G.windowNew+ canvas <- G.drawingAreaNew+ -- Gtk3 no longer has size requests, and window does not have a drawable+ -- area to fill, thus we must explicitly tell it how to draw the window size.+ G.windowSetDefaultSize window windowSize windowSize+ G.windowSetGeometryHints window (Just window)+ (Just (0, 0)) (Just (windowSize, windowSize))+ Nothing Nothing (Just (1,1))+ -- press any key to quit+ window `G.on` G.keyPressEvent $ G.tryEvent $ do C.liftIO G.mainQuit+ canvas `G.on` G.draw $ (prologue canvas >> renderG f)+ G.set window [G.containerChild G.:= canvas, G.windowResizable G.:= False]+ G.widgetShowAll window+ G.mainGUI++foreach :: (Monad m) => [a] -> (a -> m b) -> m [b]+foreach = flip mapM++deriv :: (Double -> Double) -> Double -> Double+deriv f x = ((f $ x + 0.05) - (f $ x - 0.05)) * 10++gen :: Double -> Double -> (Double -> Double) -> [Double]+gen v t f | v > t = []+gen v t f = v : (gen (f v) t f)++skipBy f = foldr (\x c -> if f x then c else x : c) []++falloff x = 0.25 * (x + 1.5) / ((x+0.5)^5 + 1)++renderG :: (Double -> Double) -> C.Render ()+renderG f = do+ C.moveTo (-5) (f (-5))+ sequence_ $ map (\d -> C.lineTo d $ f d) $ skipBy (isInfinite . f) [-4.9,-4.8..5]+ --Adaptive attempt (falloff func is what really needs work)+ --sequence_ $ map (\d -> C.lineTo d $ f d) $ skipBy (isInfinite . f) $ tail $ gen (-5) 5 (\x -> x + (falloff $ abs $ deriv (deriv f) x))+ C.stroke++-- Set up stuff+prologue canvas = do+ wWidth' <- C.liftIO $ G.widgetGetAllocatedWidth canvas+ wHeight' <- C.liftIO $ G.widgetGetAllocatedHeight canvas+ let wWidth = realToFrac wWidth'+ wHeight = realToFrac wHeight'+ width = 10+ height = 10+ xmax = width / 2+ xmin = - xmax+ ymax = height / 2+ ymin = - ymax+ scaleX = realToFrac wWidth / width+ scaleY = realToFrac wHeight / height++ -- style and color+ C.setLineCap C.LineCapRound+ C.setLineJoin C.LineJoinRound+ C.setLineWidth $ 1 / max scaleX scaleY++ -- Set up user coordinates+ C.scale scaleX scaleY+ -- center origin+ C.translate (width / 2) (height / 2)+ -- positive y-axis upwards+ let flipY = M.Matrix 1 0 0 (-1) 0 0+ C.transform flipY+ C.setSourceRGBA 0 0 0 1+ grid xmin xmax ymin ymax++-- Grid and axes+grid xmin xmax ymin ymax = do+ -- axes+ C.moveTo 0 ymin; C.lineTo 0 ymax; C.stroke+ C.moveTo xmin 0; C.lineTo xmax 0; C.stroke+ -- grid+ C.setDash [0.01, 0.99] 0+ foreach [xmin .. xmax] $ \ x ->+ do C.moveTo x ymin+ C.lineTo x ymax+ C.stroke+ C.setDash [] 0
+ demo/gtk3/Makefile view
@@ -0,0 +1,37 @@++PROGS = drawing drawing2 starandring text clock graph sdldrawing paths+SOURCES = Drawing.hs Drawing2.hs StarAndRing.hs Text.hs Clock.hs Graph.hs CairoSDL.hs Paths.hs+OUTPUT = paths.png++all : $(PROGS)++drawing : Drawing.hs+ $(HC_RULE)++drawing2 : Drawing2.hs+ $(HC_RULE)++starandring : StarAndRing.hs+ $(HC_RULE)++text : Text.hs+ $(HC_RULE)++clock : Clock.hs+ $(HC_RULE)++graph : Graph.hs+ $(HC_RULE)++sdldrawing : CairoSDL.hs+ $(HC_RULE)++paths : Paths.hs+ $(HC_RULE)++HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS)++clean:+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS) $(OUTPUT)++HC=ghc
+ demo/gtk3/StarAndRing.hs view
@@ -0,0 +1,111 @@+import Graphics.Rendering.Cairo+import qualified Graphics.Rendering.Cairo.Matrix as M++ringPath :: Render ()+ringPath = do+ moveTo 200.86568 667.80795+ curveTo 110.32266 562.62134 122.22863 403.77940 227.41524 313.23637+ curveTo 332.60185 222.69334 491.42341 234.57563 581.96644 339.76224+ curveTo 672.50948 444.94884 660.64756 603.79410 555.46095 694.33712+ curveTo 450.27436 784.88016 291.40871 772.99456 200.86568 667.80795+ closePath+ moveTo 272.14411 365.19927+ curveTo 195.64476 431.04875 186.97911 546.57972 252.82859 623.07908+ curveTo 318.67807 699.57844 434.23272 708.22370 510.73208 642.37422+ curveTo 587.23144 576.52474 595.85301 460.99047 530.00354 384.49112+ curveTo 464.15406 307.99176 348.64347 299.34979 272.14411 365.19927+ closePath++starPath :: Render ()+starPath = do+ transform (M.Matrix 0.647919 (-0.761710) 0.761710 0.647919 (-208.7977) 462.0608)+ moveTo 505.80857 746.23606+ lineTo 335.06870 555.86488+ lineTo 91.840384 635.31360+ lineTo 282.21157 464.57374+ lineTo 202.76285 221.34542+ lineTo 373.50271 411.71660+ lineTo 616.73103 332.26788+ lineTo 426.35984 503.00775+ lineTo 505.80857 746.23606+ closePath++fillRing :: Render ()+fillRing = do+ save+ translate (-90) (-205)+ ringPath+ setSourceRGBA 1.0 0.0 0.0 0.75+ fill+ restore++fillStar :: Render ()+fillStar = do+ save+ translate (-90) (-205)+ starPath+ setSourceRGBA 0.0 0.0 ((fromIntegral 0xae) / (fromIntegral 0xff)) 0.55135137+ fill+ restore++clipToTopAndBottom :: Int -> Int -> Render ()+clipToTopAndBottom width height = do+ moveTo 0 0+ lineTo (fromIntegral width) 0.0+ lineTo 0.0 (fromIntegral height)+ lineTo (fromIntegral width) (fromIntegral height)+ closePath+ clip+ newPath++clipToLeftAndRight :: Int -> Int -> Render ()+clipToLeftAndRight width height = do+ moveTo 0 0+ lineTo 0.0 (fromIntegral height)+ lineTo (fromIntegral width) 0.0+ lineTo (fromIntegral width) (fromIntegral height)+ closePath+ clip+ newPath++starAndRing :: Int -> Int -> Render ()+starAndRing width height = do+ setOperator OperatorClear+ paint++ setOperator OperatorAdd++ renderWithSimilarSurface ContentColorAlpha width height $ \ringOverStar -> do+ renderWith ringOverStar $ do+ clipToTopAndBottom width height+ fillStar+ fillRing+ setSourceSurface ringOverStar 0 0+ paint++ renderWithSimilarSurface ContentColorAlpha width height $ \starOverRing -> do+ renderWith starOverRing $ do+ clipToLeftAndRight width height+ fillRing+ fillStar+ setSourceSurface starOverRing 0 0+ paint++main :: IO ()+main = do+ withImageSurface FormatARGB32 width height $ \result -> do+ renderWith result $ starAndRing width height+ surfaceWriteToPNG result "StarAndRing.png"+ putStrLn "wrote StarAndRing.png"+ withPDFSurface "StarAndRing.pdf" (fromIntegral width) (fromIntegral height)+ (flip renderWith $ starAndRing width height >> showPage)+ putStrLn "wrote StarAndRing.pdf"+ withPSSurface "StarAndRing.ps" (fromIntegral width) (fromIntegral height)+ (flip renderWith $ starAndRing width height >> showPage)+ putStrLn "wrote StarAndRing.ps"+ withSVGSurface "StarAndRing.svg" (fromIntegral width) (fromIntegral height)+ (flip renderWith $ starAndRing width height)+ putStrLn "wrote StarAndRing.svg"++ where width = 600+ height = 600
+ demo/gtk3/Text.hs view
@@ -0,0 +1,71 @@+import Graphics.Rendering.Cairo+import qualified Graphics.Rendering.Cairo.Matrix as M++boxText :: String -> Double -> Double -> Render ()+boxText text x y = do+ save++ lineWidth <- getLineWidth++ (TextExtents xb yb w h _ _) <- textExtents text++ rectangle (x + xb - lineWidth)+ (y + yb - lineWidth)+ (w + 2 * lineWidth)+ (h + 2 * lineWidth)+ stroke+ moveTo x y+ textPath text+ fillPreserve+ setSourceRGBA 0 0 1 0.5+ setLineWidth 3.0+ stroke++ restore++transpSurface :: Double -> Double -> Render ()+transpSurface w h = do+ save+ rectangle 0 0 w h+ setSourceRGBA 0 0 0 0+ setOperator OperatorSource+ fill+ restore++sWidth = 400+sHeight = 300++main :: IO ()+main = withImageSurface FormatARGB32 sWidth sHeight $ \surface -> do+ renderWith surface $ do+ setSourceRGB 0.0 0.0 0.0+ setLineWidth 2.0++ transpSurface (fromIntegral sWidth) (fromIntegral sHeight)++ selectFontFace "sans" FontSlantNormal FontWeightNormal+ setFontSize 40++ extents <- fontExtents+ let fontHeight = fontExtentsHeight extents++ boxText "Howdy, world!" 10 fontHeight++ translate 0 fontHeight++ save+ translate 10 fontHeight+ rotate (10.0 * pi / 180.0)+ boxText "Yay for Haskell!" 0 0+ restore++ translate 0 (3 * fontHeight)++ save+ setFontMatrix $ M.rotate ((-10.0) * pi / 180.0) $ M.scale 40.0 40.0 M.identity+ boxText "...and Cairo!" 10 fontHeight+ restore++ surfaceWriteToPNG surface "Text.png"++ return ()