From: Matt Birkholz Date: Fri, 5 Apr 2013 17:20:45 +0000 (-0700) Subject: gtk: Add many cairo- wrappers: cairo-image-surface-create... X-Git-Tag: mit-scheme-pucked-9.2.12~527 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ee275cf519efd94ac063d80a6116c48afcd1475a;p=mit-scheme.git 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 1d6f774ab..92f45fef9 100644 --- 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 45220b12d..cbb22f62e 100644 --- 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)) + +(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)))) + +(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 07ffc45fe..078bc18af 100644 --- 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))