gtk: Add many cairo- wrappers: cairo-image-surface-create...

... cairo-pattern-create-linear, cairo-pattern-create-radial,
cairo-pattern-add-color-stop, cairo-create, cairo-translate,
cairo-scale, cairo-set-source, cairo-set-source-color, cairo-arc,
cairo-paint, cairo-fill, cairo-stroke, cairo-set-font-matrix,
cairo-matrix, cairo-surface-destroy, cairo-surface-flush, and
cairo-pattern-destroy.

diff --git a/src/gtk/Includes/cairo.cdecl b/src/gtk/Includes/cairo.cdecl
index 1d6f774ab2b73725089beb75a75e0c0fc1955c1a..92f45fef9c091626f8f1f4a2d26c3663c81d4074 100644 (file)
--- a/src/gtk/Includes/cairo.cdecl
+++ b/src/gtk/Includes/cairo.cdecl
@@ -2,6 +2,12 @@
 
 cairo/cairo.h |#
 
+(typedef cairo_matrix_t
+  (struct _cairo_matrix
+         (xx double) (yx double)
+         (xy double) (yy double)
+         (x0 double) (y0 double)))
+
 (typedef cairo_status_t
   (enum _cairo_status
     (CAIRO_STATUS_SUCCESS)
@@ -28,6 +34,13 @@ cairo/cairo.h |#
     (CAIRO_STATUS_INVALID_INDEX)
     (CAIRO_STATUS_CLIP_NOT_REPRESENTABLE)))
 
+(typedef cairo_rectangle_int_t
+        (struct _cairo_rectangle_int
+                (x int)
+                (y int)
+                (width int)
+                (height int)))
+
 (extern (* cairo_t) cairo_create (target (* cairo_surface_t)))
 
 (extern void cairo_destroy (cr (* cairo_t)))
@@ -36,16 +49,21 @@ cairo/cairo.h |#
 
 (extern void cairo_restore (cr (* cairo_t)))
 
-(extern void cairo_set_source_rgba
-       (cr (* cairo_t)) (red double)(green double)(blue double)(alpha double))
+(extern void cairo_set_source (cr (* cairo_t))
+       (source (* cairo_pattern_t)))
+
+(extern void cairo_set_source_rgba (cr (* cairo_t))
+       (red double)(green double)(blue double)(alpha double))
+
+(extern void cairo_set_source_surface (cr (* cairo_t))
+       (surface (* cairo_surface_t)) (x double) (y double))
 
 (extern void cairo_set_line_width (cr (* cairo_t)) (width double))
 
-(extern void cairo_set_dash
-       (cr         (* cairo_t))
-       (dashes     (* (const double)))
+(extern void cairo_set_dash (cr (* cairo_t))
+       (dashes (* (const double)))
        (num_dashes int)
-       (offset     double))
+       (offset double))
 
 (extern void cairo_translate (cr (* cairo_t)) (tx double) (ty double))
 
@@ -65,8 +83,10 @@ cairo/cairo.h |#
 
 (extern void cairo_rel_line_to (cr (* cairo_t)) (dx double) (dy double))
 
-(extern void cairo_rectangle
-       (cr (* cairo_t)) (x double) (y double) (width double) (height double))
+(extern void cairo_rectangle (cr (* cairo_t))
+       (x double) (y double) (width double) (height double))
+
+(extern void cairo_close_path (cr (* cairo_t)))
 
 (extern void cairo_paint (cr (* cairo_t)))
 
@@ -78,22 +98,34 @@ cairo/cairo.h |#
 
 (extern void cairo_fill_preserve (cr (* cairo_t)))
 
+(extern void cairo_reset_clip (cr (* cairo_t)))
+
 (extern void cairo_clip (cr (* cairo_t)))
 
 (extern void cairo_clip_extents (cr (* cairo_t))
        (x1 (* double)) (y1 (* double))
        (x2 (* double)) (y2 (* double)))
 
+(extern void cairo_set_font_matrix (cr (* cairo_t))
+       (matrix (* cairo_matrix_t)))
+
+(extern void cairo_show_text (cr (* cairo_t))
+       (utf8 (* (const char))))
+
 (extern cairo_status_t cairo_status (cr (* cairo_t)))
 
 (extern (* (const char)) cairo_status_to_string (status cairo_status_t))
 
 (extern void cairo_surface_destroy (surface (* cairo_surface_t)))
 
+(extern cairo_status_t cairo_surface_status (surface (* cairo_surface_t)))
+
 (extern cairo_status_t cairo_surface_write_to_png
        (surface (* cairo_surface_t))
        (filename (* (const char))))
 
+(extern void cairo_surface_flush (surface (* cairo_surface_t)))
+
 (typedef cairo_format_t
   (enum _cairo_format
     (CAIRO_FORMAT_ARGB32)
@@ -101,15 +133,26 @@ cairo/cairo.h |#
     (CAIRO_FORMAT_A8)
     (CAIRO_FORMAT_A1)))
 
- (extern (* cairo_surface_t)
+(extern (* cairo_surface_t)
        cairo_image_surface_create
        (format cairo_format_t)
        (width int)(height int))
 
-(typedef cairo_rectangle_int_t (struct _cairo_rectangle_int))
+(extern (* cairo_pattern_t)
+       cairo_pattern_create_linear
+       (x0 double) (y0 double)
+       (x1 double) (y1 double))
+
+(extern (* cairo_pattern_t)
+       cairo_pattern_create_radial
+       (cx0 double) (cy0 double) (radius0 double)
+       (cx1 double) (cy1 double) (radius1 double))
+
+(extern void cairo_pattern_destroy (pattern (* cairo_pattern_t)))
+
+(extern cairo_status_t cairo_pattern_status (pattern (* cairo_pattern_t)))
 
-(struct _cairo_rectangle_int
-       (x int)
-       (y int)
-       (width int)
-       (height int))
\ No newline at end of file
+(extern void
+       cairo_pattern_add_color_stop_rgba
+       (pattern (* cairo_pattern_t))
+       (offset double) (red double)(green double)(blue double)(alpha double))
\ No newline at end of file

diff --git a/src/gtk/cairo.scm b/src/gtk/cairo.scm
index 45220b12de368fa4ad0c8e61c462bc56b5d732db..cbb22f62efe2ab7b6d185a447ef69c13bb4ad046 100644 (file)
--- a/src/gtk/cairo.scm
+++ b/src/gtk/cairo.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-Copyright (C) 2012  Matthew Birkholz
+Copyright (C) 2012, 2013  Matthew Birkholz
 
 This file is part of an extension to MIT/GNU Scheme.
 
@@ -24,6 +24,119 @@ USA.
 ;;;; Cairo interface.
 ;;; package: (gtk cairo)
 
+(define (cairo-image-surface-create width height)
+  (let ((surface (make-alien '|cairo_surface_t|))
+       (copy (make-alien '|cairo_surface_t|)))
+    (add-gc-cleanup surface (make-cairo-surface-cleanup copy))
+    (C-call "cairo_image_surface_create" copy
+           (C-enum "CAIRO_FORMAT_RGB24") width height)
+    (copy-alien-address! surface copy)
+    (check-cairo-surface-status surface)
+    surface))
+
+(define (make-cairo-surface-cleanup alien)
+  (named-lambda (cairo-surface-cleanup)
+    ;;without-interrupts
+    (if (not (alien-null? alien))
+       (begin
+         (C-call "cairo_surface_destroy" alien)
+         (alien-null! alien)))))
+
+(define (cairo-surface-destroy surface)
+  (check-cairo-surface-status surface)
+  (without-interrupts
+   (lambda ()
+     (if (not (alien-null? surface))
+        (begin
+          (C-call "cairo_surface_destroy" surface)
+          (alien-null! surface)))))
+  (punt-gc-cleanup surface))
+
+(define (check-cairo-surface-status surface)
+  (let ((status (C-call "cairo_surface_status" surface)))
+    (if (not (= status (C-enum "CAIRO_STATUS_SUCCESS")))
+       (let ((msg (C-call "cairo_status_to_string"
+                          (make-alien '(* (const char)))
+                          status)))
+         (error msg surface)))))
+
+(define (guarantee-cairo-surface object operator)
+  (if (and (alien? object) (eq? (alien/ctype object) '|cairo_surface_t|))
+      object
+      (error:wrong-type-argument object "a cairo_surface_t alien" operator)))
+
+(define (cairo-surface-flush surface)
+  (guarantee-cairo-surface surface 'cairo-surface-flush)
+  (C-call "cairo_surface_flush" surface))
+\f
+(define (cairo-pattern-create-linear x1 y1 x2 y2)
+  (let ((pattern (make-alien '|cairo_pattern_t|))
+       (copy (make-alien '|cairo_pattern_t|)))
+    (add-gc-cleanup pattern (make-cairo-pattern-cleanup copy))
+    (C-call "cairo_pattern_create_linear" copy
+           (->flonum x1) (->flonum y1) (->flonum x2) (->flonum y2))
+    (copy-alien-address! pattern copy)
+    (check-cairo-pattern-status pattern)
+    pattern))
+
+(define (cairo-pattern-create-radial cx0 cy0 radius0 cx1 cy1 radius1)
+  (let ((pattern (make-alien '|cairo_pattern_t|))
+       (copy (make-alien '|cairo_pattern_t|)))
+    (add-gc-cleanup pattern (make-cairo-pattern-cleanup copy))
+    (C-call "cairo_pattern_create_radial" copy
+           (->flonum cx0) (->flonum cy0) (->flonum radius0)
+           (->flonum cx1) (->flonum cy1) (->flonum radius1))
+    (copy-alien-address! pattern copy)
+    (check-cairo-pattern-status pattern)
+    pattern))
+
+(define (make-cairo-pattern-cleanup alien)
+  (named-lambda (cairo-pattern-cleanup)
+    ;;without-interrupts
+    (if (not (alien-null? alien))
+       (begin
+         (C-call "cairo_pattern_destroy" alien)
+         (alien-null! alien)))))
+
+(define (cairo-pattern-destroy pattern)
+  (check-cairo-pattern-status pattern)
+  (without-interrupts
+   (lambda ()
+     (if (not (alien-null? pattern))
+        (begin
+          (C-call "cairo_pattern_destroy" pattern)
+          (alien-null! pattern)))))
+  (punt-gc-cleanup pattern))
+
+(define (check-cairo-pattern-status pattern)
+  (let ((status (C-call "cairo_pattern_status" pattern)))
+    (if (not (= status (C-enum "CAIRO_STATUS_SUCCESS")))
+       (let ((msg (C-call "cairo_status_to_string"
+                          (make-alien '(* (const char)))
+                          status)))
+         (error msg pattern)))))
+
+(define (guarantee-cairo-pattern object operator)
+  (if (and (alien? object) (eq? (alien/ctype object) '|cairo_pattern_t|))
+      object
+      (error:wrong-type-argument object "a cairo_pattern_t alien" operator)))
+
+(define (cairo-pattern-add-color-stop pattern offset color)
+  (guarantee-cairo-pattern pattern 'cairo-pattern-add-color-stop)
+  (let ((c (->color color 'cairo-pattern-add-color-stop)))
+    (C-call "cairo_pattern_add_color_stop_rgba" pattern (->flonum offset)
+           (color-red c) (color-green c) (color-blue c) (color-alpha c))))
+\f
+(define (cairo-create surface)
+  (guarantee-cairo-surface surface 'cairo-create)
+  (let ((cairo (make-alien '|cairo_t|))
+       (copy (make-alien '|cairo_t|)))
+    (add-gc-cleanup cairo (make-cairo-cleanup copy))
+    (C-call "cairo_create" copy surface)
+    (copy-alien-address! cairo copy)
+    (check-cairo-status cairo)
+    cairo))
+
 (define (gdk-cairo-create GdkWindow)
   (let ((cairo (make-alien '|cairo_t|))
        (copy (make-alien '|cairo_t|)))
@@ -56,9 +169,33 @@ USA.
     (if (not (= status (C-enum "CAIRO_STATUS_SUCCESS")))
        (let ((msg (C-call "cairo_status_to_string"
                           (make-alien '(* (const char)))
-                          cairo)))
+                          status)))
          (error msg cairo)))))
 
+(define (guarantee-cairo object operator)
+  (if (and (alien? object) (eq? (alien/ctype object) '|cairo_t|))
+      object
+      (error:wrong-type-argument object "a cairo_t alien" operator)))
+
+(define (cairo-translate cairo dx dy)
+  (guarantee-cairo cairo 'cairo-set-source)
+  (C-call "cairo_translate" cairo (->flonum dx) (->flonum dy)))
+
+(define (cairo-scale cairo sx sy)
+  (guarantee-cairo cairo 'cairo-set-source)
+  (C-call "cairo_scale" cairo (->flonum sx) (->flonum sy)))
+
+(define (cairo-set-source-color cairo color)
+  (guarantee-cairo cairo 'cairo-set-source-color)
+  (let ((c (->color color 'cairo-set-source-color)))
+    (C-call "cairo_set_source_rgba" cairo
+           (color-red c) (color-green c) (color-blue c) (color-alpha c))))
+
+(define (cairo-set-source cairo pattern)
+  (guarantee-cairo cairo 'cairo-set-source)
+  (guarantee-cairo-pattern pattern 'cairo-set-source)
+  (C-call "cairo_set_source" cairo pattern))
+
 (define-integrable (cairo-clip-extents cairo receiver)
   (let ((doubles (malloc (fix:* 4 (C-sizeof "double")) 'double)))
     (let ((y1 (C-array-loc doubles "double" 1))
@@ -68,4 +205,52 @@ USA.
       (let ((x1. (C-> doubles "double")) (y1. (C-> y1 "double"))
            (x2. (C-> x2 "double")) (y2. (C-> y2 "double")))
        (free doubles)
-       (receiver x1. y1. x2. y2.)))))
\ No newline at end of file
+       (receiver x1. y1. x2. y2.)))))
+
+(define (cairo-arc cairo xc yc radius start-angle end-angle)
+  (guarantee-cairo cairo 'cairo-set-source)
+  (C-call "cairo_arc" cairo (->flonum xc) (->flonum yc) (->flonum radius)
+         (->flonum start-angle) (->flonum end-angle)))
+
+(define (cairo-paint cairo)
+  (guarantee-cairo cairo 'cairo-paint)
+  (C-call "cairo_paint" cairo))
+
+(define (cairo-fill cairo)
+  (guarantee-cairo cairo 'cairo-fill)
+  (C-call "cairo_fill" cairo))
+
+(define (cairo-stroke cairo)
+  (guarantee-cairo cairo 'cairo-stroke)
+  (C-call "cairo_stroke" cairo))
+
+(define (cairo-set-font-matrix cairo matrix)
+  (guarantee-cairo cairo 'cairo-set-font-matrix)
+  (guarantee-cairo-matrix matrix 'cairo-set-font-matrix)
+  #;(C-call "scm_cairo_set_font_matrix" cairo matrix)
+  (let ((cairo-matrix (malloc (C-sizeof "cairo_matrix_t") '|cairo_matrix_t|)))
+    (C->= cairo-matrix "cairo_matrix_t xx" (flo:vector-ref matrix 0))
+    (C->= cairo-matrix "cairo_matrix_t yx" (flo:vector-ref matrix 1))
+    (C->= cairo-matrix "cairo_matrix_t x0" (flo:vector-ref matrix 2))
+    (C->= cairo-matrix "cairo_matrix_t xy" (flo:vector-ref matrix 3))
+    (C->= cairo-matrix "cairo_matrix_t yy" (flo:vector-ref matrix 4))
+    (C->= cairo-matrix "cairo_matrix_t y0" (flo:vector-ref matrix 5))
+    (C-call "cairo_set_font_matrix" cairo cairo-matrix)
+    (free cairo-matrix)))
+
+(define (guarantee-cairo-matrix object operator)
+  (if (and (flo:flonum? object)
+          (= (flo:vector-length object) 6))
+      object
+      (error:wrong-type-argument object "a cairo matrix" operator)))
+
+(define (cairo-matrix xx yx x0
+                     xy yy y0)
+  (let ((v (flo:vector-cons 6)))
+    (flo:vector-set! v 0 xx)
+    (flo:vector-set! v 1 yx)
+    (flo:vector-set! v 2 x0)
+    (flo:vector-set! v 3 xy)
+    (flo:vector-set! v 4 yy)
+    (flo:vector-set! v 5 y0)
+    v))
\ No newline at end of file

diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index 07ffc45fe343d8f7dfbf815229a1505b84a65267..078bc18af0443b9f6951afc8c7d38238e86a726c 100644 (file)
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -129,10 +129,30 @@ USA.
 (define-package (gtk cairo)
   (parent (gtk))
   (files "cairo")
+  (import (gtk fix-layout)
+         ->color)
   (export (gtk)
+         cairo-image-surface-create
+         cairo-surface-destroy
+         cairo-surface-flush
+         cairo-pattern-create-linear
+         cairo-pattern-create-radial
+         cairo-pattern-destroy
+         cairo-pattern-add-color-stop
+         cairo-create
          gdk-cairo-create
          cairo-destroy
-         cairo-clip-extents))
+         cairo-translate
+         cairo-scale
+         cairo-set-source-color
+         cairo-set-source
+         cairo-clip-extents
+         cairo-arc
+         cairo-paint
+         cairo-fill
+         cairo-stroke
+         cairo-set-font-matrix
+         cairo-matrix))
 
 (define-package (gtk gtk-widget)
   (parent (gtk))