diff --git a/Graphics/Rendering/Cairo.hs b/Graphics/Rendering/Cairo.hs --- a/Graphics/Rendering/Cairo.hs +++ b/Graphics/Rendering/Cairo.hs @@ -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\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 +-- 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 +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 +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 +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 +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 +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 +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 +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 +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 +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 +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 +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 +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) diff --git a/Graphics/Rendering/Cairo/Internal/Drawing/Cairo.chs b/Graphics/Rendering/Cairo/Internal/Drawing/Cairo.chs --- a/Graphics/Rendering/Cairo/Internal/Drawing/Cairo.chs +++ b/Graphics/Rendering/Cairo/Internal/Drawing/Cairo.chs @@ -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' } -> `()'#} diff --git a/Graphics/Rendering/Cairo/Internal/Drawing/Paths.chs b/Graphics/Rendering/Cairo/Internal/Drawing/Paths.chs --- a/Graphics/Rendering/Cairo/Internal/Drawing/Paths.chs +++ b/Graphics/Rendering/Cairo/Internal/Drawing/Paths.chs @@ -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 + diff --git a/Graphics/Rendering/Cairo/Internal/Drawing/Patterns.chs b/Graphics/Rendering/Cairo/Internal/Drawing/Patterns.chs --- a/Graphics/Rendering/Cairo/Internal/Drawing/Patterns.chs +++ b/Graphics/Rendering/Cairo/Internal/Drawing/Patterns.chs @@ -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 + diff --git a/Graphics/Rendering/Cairo/Internal/Drawing/Text.chs b/Graphics/Rendering/Cairo/Internal/Drawing/Text.chs --- a/Graphics/Rendering/Cairo/Internal/Drawing/Text.chs +++ b/Graphics/Rendering/Cairo/Internal/Drawing/Text.chs @@ -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 + diff --git a/Graphics/Rendering/Cairo/Internal/Drawing/Transformations.chs b/Graphics/Rendering/Cairo/Internal/Drawing/Transformations.chs --- a/Graphics/Rendering/Cairo/Internal/Drawing/Transformations.chs +++ b/Graphics/Rendering/Cairo/Internal/Drawing/Transformations.chs @@ -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) -- diff --git a/Graphics/Rendering/Cairo/Internal/Surfaces/SVG.chs b/Graphics/Rendering/Cairo/Internal/Surfaces/SVG.chs --- a/Graphics/Rendering/Cairo/Internal/Surfaces/SVG.chs +++ b/Graphics/Rendering/Cairo/Internal/Surfaces/SVG.chs @@ -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 diff --git a/Graphics/Rendering/Cairo/Internal/Utilities.chs b/Graphics/Rendering/Cairo/Internal/Utilities.chs --- a/Graphics/Rendering/Cairo/Internal/Utilities.chs +++ b/Graphics/Rendering/Cairo/Internal/Utilities.chs @@ -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) diff --git a/Graphics/Rendering/Cairo/Types.chs b/Graphics/Rendering/Cairo/Types.chs --- a/Graphics/Rendering/Cairo/Types.chs +++ b/Graphics/Rendering/Cairo/Types.chs @@ -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 diff --git a/Gtk2HsSetup.hs b/Gtk2HsSetup.hs deleted file mode 100644 --- a/Gtk2HsSetup.hs +++ /dev/null @@ -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 "" . 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) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/SetupMain.hs b/SetupMain.hs deleted file mode 100644 --- a/SetupMain.hs +++ /dev/null @@ -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 - diff --git a/SetupWrapper.hs b/SetupWrapper.hs deleted file mode 100644 --- a/SetupWrapper.hs +++ /dev/null @@ -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 diff --git a/cairo.cabal b/cairo.cabal --- a/cairo.cabal +++ b/cairo.cabal @@ -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= diff --git a/demo/CairoGhci.hs b/demo/CairoGhci.hs deleted file mode 100644 --- a/demo/CairoGhci.hs +++ /dev/null @@ -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 diff --git a/demo/Clock.hs b/demo/Clock.hs deleted file mode 100644 --- a/demo/Clock.hs +++ /dev/null @@ -1,407 +0,0 @@ --- original author: --- Mirco "MacSlow" Mueller --- --- created: --- 10.1.2006 (or so) --- --- http://www.gnu.org/licenses/licenses.html#GPL --- --- ported to Haskell by: --- Duncan Coutts --- - -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 diff --git a/demo/Drawing.hs b/demo/Drawing.hs deleted file mode 100644 --- a/demo/Drawing.hs +++ /dev/null @@ -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 diff --git a/demo/Drawing2.hs b/demo/Drawing2.hs deleted file mode 100644 --- a/demo/Drawing2.hs +++ /dev/null @@ -1,258 +0,0 @@ --- --- Author: Johan Bockgård --- --- 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 - ----------------------------------------------------------------- diff --git a/demo/Graph.hs b/demo/Graph.hs deleted file mode 100644 --- a/demo/Graph.hs +++ /dev/null @@ -1,98 +0,0 @@ --- --- Author: Michael Sloan --- --- 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 diff --git a/demo/Makefile b/demo/Makefile deleted file mode 100644 --- a/demo/Makefile +++ /dev/null @@ -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 diff --git a/demo/StarAndRing.hs b/demo/StarAndRing.hs deleted file mode 100644 --- a/demo/StarAndRing.hs +++ /dev/null @@ -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 diff --git a/demo/Text.hs b/demo/Text.hs deleted file mode 100644 --- a/demo/Text.hs +++ /dev/null @@ -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 () diff --git a/demo/gtk2/CairoGhci.hs b/demo/gtk2/CairoGhci.hs new file mode 100644 --- /dev/null +++ b/demo/gtk2/CairoGhci.hs @@ -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 diff --git a/demo/gtk2/Clock.hs b/demo/gtk2/Clock.hs new file mode 100644 --- /dev/null +++ b/demo/gtk2/Clock.hs @@ -0,0 +1,407 @@ +-- original author: +-- Mirco "MacSlow" Mueller +-- +-- created: +-- 10.1.2006 (or so) +-- +-- http://www.gnu.org/licenses/licenses.html#GPL +-- +-- ported to Haskell by: +-- Duncan Coutts +-- + +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 diff --git a/demo/gtk2/Drawing.hs b/demo/gtk2/Drawing.hs new file mode 100644 --- /dev/null +++ b/demo/gtk2/Drawing.hs @@ -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 diff --git a/demo/gtk2/Drawing2.hs b/demo/gtk2/Drawing2.hs new file mode 100644 --- /dev/null +++ b/demo/gtk2/Drawing2.hs @@ -0,0 +1,258 @@ +-- +-- Author: Johan Bockgård +-- +-- 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 + +---------------------------------------------------------------- diff --git a/demo/gtk2/Graph.hs b/demo/gtk2/Graph.hs new file mode 100644 --- /dev/null +++ b/demo/gtk2/Graph.hs @@ -0,0 +1,98 @@ +-- +-- Author: Michael Sloan +-- +-- 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 diff --git a/demo/gtk2/Makefile b/demo/gtk2/Makefile new file mode 100644 --- /dev/null +++ b/demo/gtk2/Makefile @@ -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 diff --git a/demo/gtk2/StarAndRing.hs b/demo/gtk2/StarAndRing.hs new file mode 100644 --- /dev/null +++ b/demo/gtk2/StarAndRing.hs @@ -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 diff --git a/demo/gtk2/Text.hs b/demo/gtk2/Text.hs new file mode 100644 --- /dev/null +++ b/demo/gtk2/Text.hs @@ -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 () diff --git a/demo/gtk3/CairoGhci.hs b/demo/gtk3/CairoGhci.hs new file mode 100644 --- /dev/null +++ b/demo/gtk3/CairoGhci.hs @@ -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 diff --git a/demo/gtk3/Clock.hs b/demo/gtk3/Clock.hs new file mode 100644 --- /dev/null +++ b/demo/gtk3/Clock.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- original author: +-- Mirco "MacSlow" Mueller +-- +-- created: +-- 10.1.2006 (or so) +-- +-- http://www.gnu.org/licenses/licenses.html#GPL +-- +-- ported to Haskell by: +-- Duncan Coutts +-- +-- 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 diff --git a/demo/gtk3/Drawing.hs b/demo/gtk3/Drawing.hs new file mode 100644 --- /dev/null +++ b/demo/gtk3/Drawing.hs @@ -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 + + diff --git a/demo/gtk3/Drawing2.hs b/demo/gtk3/Drawing2.hs new file mode 100644 --- /dev/null +++ b/demo/gtk3/Drawing2.hs @@ -0,0 +1,261 @@ +-- +-- Author: Johan Bockgård +-- +-- 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 + +---------------------------------------------------------------- diff --git a/demo/gtk3/Graph.hs b/demo/gtk3/Graph.hs new file mode 100644 --- /dev/null +++ b/demo/gtk3/Graph.hs @@ -0,0 +1,102 @@ +-- +-- Author: Michael Sloan +-- +-- 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 diff --git a/demo/gtk3/Makefile b/demo/gtk3/Makefile new file mode 100644 --- /dev/null +++ b/demo/gtk3/Makefile @@ -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 diff --git a/demo/gtk3/StarAndRing.hs b/demo/gtk3/StarAndRing.hs new file mode 100644 --- /dev/null +++ b/demo/gtk3/StarAndRing.hs @@ -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 diff --git a/demo/gtk3/Text.hs b/demo/gtk3/Text.hs new file mode 100644 --- /dev/null +++ b/demo/gtk3/Text.hs @@ -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 ()