diff --git a/Graphics/Rendering/Cairo.hs b/Graphics/Rendering/Cairo.hs --- a/Graphics/Rendering/Cairo.hs +++ b/Graphics/Rendering/Cairo.hs @@ -127,8 +127,16 @@ , relCurveTo , relLineTo , relMoveTo + , copyPath + , copyPathFlat + , appendPath + , pathExtents -- ** Patterns + , createRGBPattern + , createRGBAPattern + , createLinearPattern + , createRadialPattern , withRGBPattern , withRGBAPattern , withPatternForSurface @@ -300,6 +308,9 @@ , HintMetrics(..) , FontOptions , Path + , PathElement(..) + , SurfaceType(..) + , PatternType(..) #if CAIRO_CHECK_VERSION(1,10,0) , RectangleInt(..) , RegionOverlap(..) @@ -310,6 +321,24 @@ , Extend(..) , Filter(..) + -- 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) @@ -998,6 +1027,87 @@ 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. @@ -1017,7 +1127,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) @@ -1042,7 +1153,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) @@ -1056,7 +1167,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) @@ -1071,7 +1182,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 @@ -1094,14 +1205,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, @@ -1120,7 +1231,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) @@ -1204,7 +1315,7 @@ patternSetExtend :: MonadIO m => Pattern -- ^ a 'Pattern' - -> Extend -- ^ an 'Extent' + -> Extend -- ^ an 'Extend' enum -> m () patternSetExtend p e = liftIO $ Internal.patternSetExtend p e @@ -1221,7 +1332,7 @@ patternSetFilter :: MonadIO m => Pattern -- ^ a 'Pattern' - -> Filter -- ^ a 'Filter' + -> Filter -- ^ a 'Filter' type -> m () patternSetFilter p f = liftIO $ Internal.patternSetFilter p f @@ -1232,6 +1343,220 @@ Pattern -- ^ a 'Pattern' -> m Filter 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 spedified 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 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 -> @@ -62,7 +62,7 @@ {#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,12 +17,17 @@ import Foreign import Foreign.C -import Data.Text +import Foreign.Marshal.Alloc (mallocBytes,finalizerFree) 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' } -> `()'#} @@ -40,3 +45,165 @@ {#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/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,8 @@ , Format(..) , Extend(..) , Filter(..) + , SurfaceType(..) + , PatternType(..) , cIntConv , cFloatConv @@ -58,6 +60,7 @@ , cFromEnum , peekFloatConv , withFloatConv + , peekIntConv ) where @@ -92,14 +95,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 @@ -323,14 +346,11 @@ -- -- 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 +358,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,12 +411,16 @@ {#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)#} @@ -440,3 +464,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/cairo.cabal b/cairo.cabal --- a/cairo.cabal +++ b/cairo.cabal @@ -1,5 +1,5 @@ Name: cairo -Version: 0.13.5.0 +Version: 0.13.6.0 License: BSD3 License-file: COPYRIGHT Copyright: (c) 2001-2010 The Gtk2Hs Team, (c) Paolo Martini 2005, (c) Abraham Egnor 2003, 2004, (c) Aetion Technologies LLC 2004 @@ -53,7 +53,7 @@ custom-setup setup-depends: base >= 4.6, - Cabal >= 1.24 && < 2.3, + Cabal >= 1.24 && < 2.5, gtk2hs-buildtools >= 0.13.2.0 && < 0.14 Library @@ -94,4 +94,4 @@ if flag(cairo_svg) pkgconfig-depends: cairo-svg if os(darwin) || os(freebsd) - cpp-options: -D__attribute__(A)= -D_Nullable= -D_Nonnull= + cpp-options: -D__attribute__(A)= -D_Nullable= -D_Nonnull= -D_Noreturn= diff --git a/demo/gtk3/Makefile b/demo/gtk3/Makefile --- a/demo/gtk3/Makefile +++ b/demo/gtk3/Makefile @@ -1,6 +1,7 @@ -PROGS = drawing drawing2 starandring text clock graph sdldrawing -SOURCES = Drawing.hs Drawing2.hs StarAndRing.hs Text.hs Clock.hs Graph.hs CairoSDL.hs +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) @@ -25,9 +26,12 @@ 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) + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS) $(OUTPUT) HC=ghc