From 81240b33a15adac72a12da484e076e43b154f316 Mon Sep 17 00:00:00 2001 From: espen Date: Thu, 11 Jan 2007 10:20:22 +0000 Subject: [PATCH] Various enhancements and minor bug fixes --- cairo/cairo.lisp | 144 +++++++++++++++++++++++++++++++----------------------- cairo/export.lisp | 10 +++- 2 files changed, 90 insertions(+), 64 deletions(-) diff --git a/cairo/cairo.lisp b/cairo/cairo.lisp index e37b4a2..75452a2 100644 --- a/cairo/cairo.lisp +++ b/cairo/cairo.lisp @@ -20,12 +20,19 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: cairo.lisp,v 1.7 2006-12-24 14:28:20 espen Exp $ +;; $Id: cairo.lisp,v 1.8 2007-01-11 10:20:22 espen Exp $ (in-package "CAIRO") (eval-when (:compile-toplevel :load-toplevel :execute) (define-enum-type surface-format :argb32 :rgb24 :a8 :a1) + #?(pkg-exists-p "cairo" :atleast-version "1.2") + (define-enum-type content :color :alpha :color-alpha) + #?(pkg-exists-p "cairo" :atleast-version "1.2") + (define-enum-type surface-type + :image :pdf :ps :xlib :xcb :glitz :quartz :win32 :beos :directfb + :svg :nquartz :os2) + (define-enum-type status :success :no-memory :invalid-restore :invalid-pop-group @@ -161,7 +168,18 @@ (defclass surface (proxy) - () + (#?(pkg-exists-p "cairo" :atleast-version "1.2") + (type + :allocation :virtual + :getter "cairo_surface_get_tyoe" + :reader surface-type + :type surface-type) + #?(pkg-exists-p "cairo" :atleast-version "1.2") + (content + :allocation :virtual + :getter "cairo_surface_get_content" + :reader surface-content + :type content)) (:metaclass proxy-class) (:ref %surface-reference) (:unref %surface-destroy)) @@ -315,12 +333,20 @@ ((ensure-color-component blue) double-float) ((ensure-color-component alpha) double-float)) -(defbinding set-source-surface () nil +(defbinding set-source-surface (cr surface &optional (x 0.0) (y 0.0)) nil (cr context) (surface surface) (x double-float) (y double-float)) +(defun set-source (cr source) + (etypecase source + (pattern (setf (source cr) source)) + (surface (set-source-surface cr source)) + (list (apply #'set-source-color cr source)) + (vector (apply #'set-source-color cr (coerce source 'list))) + (null (set-source-color cr 0.0 0.0 0.0)))) + (defbinding set-dash (cr dashes &optional (offset 0.0)) nil (cr context) (dashes (vector double-float)) @@ -399,58 +425,39 @@ (defbinding close-path () nil (cr context)) -(defbinding arc () nil - (cr context) - (xc double-float) - (yc double-float) - (radius double-float) - (angle1 double-float) - (angle2 double-float)) - -(defbinding arc-negative () nil - (cr context) - (xc double-float) - (yc double-float) - (radius double-float) - (angle1 double-float) - (angle2 double-float)) +(defmacro defpath (name args &optional relative-p) + (flet ((def (name type) + `(progn + ,(when (eq type 'optimized-double-float) + `(declaim (ftype (function (context ,@(loop repeat (length args) collect 'double-float))) ,(first name)))) + (defbinding ,name () nil + (cr context) + ,@(mapcar #'(lambda (arg) (list arg type)) args))))) + + `(progn + ,(def name 'double-float) + ,(let ((name (intern (format nil "FAST-~A" name))) + (cname (gffi::default-alien-fname name))) + (def (list name cname) 'optimized-double-float)) + ,@(when relative-p + (let* ((rel-name (intern (format nil "REL-~A" name))) + (fast-rel-name (intern (format nil "FAST-REL-~A" name))) + (cname (gffi::default-alien-fname rel-name))) + (list + (def rel-name 'double-float) + (def (list fast-rel-name cname) 'optimized-double-float))))))) + + +(defpath arc (xc yc radius angle1 angle2)) +(defpath arc-negative (xc yc radius angle1 angle2)) +(defpath curve-to (x1 y1 x2 y2 x3 y3) t) +(defpath line-to (x y) t) +(defpath move-to (x y) t) +(defpath rectangle (x y width height)) (defun circle (cr x y radius) (arc cr x y radius 0.0 (* pi 2))) -(defmacro defpath (name &rest args) - (let ((relname (intern (format nil "REL-~A" name)))) - `(progn - (defbinding ,name () nil - (cr context) - ,@args) - (defbinding ,relname () nil - (cr context) - ,@args)))) - -(defpath curve-to - (x1 double-float) - (y1 double-float) - (x2 double-float) - (y2 double-float) - (x3 double-float) - (y3 double-float)) - -(defpath line-to - (x double-float) - (y double-float)) - -(defpath move-to - (x double-float) - (y double-float)) - -(defbinding rectangle () nil - (cr context) - (x double-float) - (y double-float) - (width double-float) - (height double-float)) - (defbinding glyph-path (cr glyphs) nil (cr context) (glyphs (vector glyph)) @@ -468,17 +475,17 @@ (pattern offset red green blue &optional (alpha 1.0)) nil (pattern pattern) (offset double-float) - (red double-float) - (green double-float) - (blue double-float) - (alpha double-float)) + ((ensure-color-component red) double-float) + ((ensure-color-component green) double-float) + ((ensure-color-component blue) double-float) + ((ensure-color-component alpha) double-float)) (defbinding (pattern-create "cairo_pattern_create_rgba") (red green blue &optional (alpha 1.0)) pattern - (red double-float) - (green double-float) - (blue double-float) - (alpha double-float)) + ((ensure-color-component red) double-float) + ((ensure-color-component green) double-float) + ((ensure-color-component blue) double-float) + ((ensure-color-component alpha) double-float)) (defbinding pattern-create-for-surface () pattern (surface surface)) @@ -515,11 +522,19 @@ (tx double-float) (ty double-float)) -(defbinding scale () nil +(defbinding scale (cr sx &optional (sy sx)) nil (cr context) (sx double-float) (sy double-float)) +(defun scale-to-device (cr &optional keep-rotation-p) + (if keep-rotation-p + (multiple-value-call #'scale cr (device-to-user-distance cr 1.0)) + (multiple-value-bind (x y) + (multiple-value-call #'user-to-device cr (get-current-point cr)) + (identity-matrix cr) + (translate cr x y)))) + (defbinding rotate () nil (cr context) (angle double-float)) @@ -540,7 +555,7 @@ (x double-float :in/out) (y double-float :in/out)) -(defbinding user-to-device-distance (cr dx &optional (dy 0.0)) nil +(defbinding user-to-device-distance (cr dx &optional (dy dx)) nil (cr context) (dx double-float :in/out) (dy double-float :in/out)) @@ -550,7 +565,7 @@ (x double-float :in/out) (y double-float :in/out)) -(defbinding device-to-user-distance (cr dx &optional (dy 0.0)) nil +(defbinding device-to-user-distance (cr dx &optional (dy dx)) nil (cr context) (dx double-float :in/out) (dy double-float :in/out)) @@ -715,6 +730,11 @@ (%surface-mark-dirty-rectangle surface x y width height) (%surface-mark-dirty surface))) +#?(pkg-exists-p "cairo" :atleast-version "1.2") +(defbinding surface-set-fallback-resolution () nil + (surface surface) + (x-pixels-per-inch double-float) + (y-pixels-per-inch double-float)) ;; Image Surface diff --git a/cairo/export.lisp b/cairo/export.lisp index 4bfae5d..9c517e8 100644 --- a/cairo/export.lisp +++ b/cairo/export.lisp @@ -8,9 +8,15 @@ (ename (intern (format nil "~A-EXTENTS" name)))) (list name tname ename)))) - (defexport defpath (name &rest args) + (defexport defpath (name args &optional relative-p) (declare (ignore args)) - (list name (intern (format nil "REL-~A" name))))) + (if (not relative-p) + (list name (intern (format nil "FAST-~A" name))) + (list + name + (intern (format nil "FAST-~A" name)) + (intern (format nil "REL-~A" name)) + (intern (format nil "FAST-REL-~A" name)))))) ;;; Autogenerating exported symbols -- 2.11.0