X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/81240b33a15adac72a12da484e076e43b154f316..a622ac465423fd53a187047a1d828caded25c1cd:/cairo/cairo.lisp diff --git a/cairo/cairo.lisp b/cairo/cairo.lisp index 75452a2..7310818 100644 --- a/cairo/cairo.lisp +++ b/cairo/cairo.lisp @@ -20,19 +20,14 @@ ;; 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.8 2007-01-11 10:20:22 espen Exp $ +;; $Id: cairo.lisp,v 1.16 2007-10-16 07:48:39 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 svg-version :svg-1.1 :svg-1.2) (define-enum-type status :success :no-memory :invalid-restore :invalid-pop-group @@ -45,7 +40,7 @@ (define-enum-type status (define-enum-type fill-rule :winding :even-odd) (define-enum-type line-cap :butt :round :square) (define-enum-type line-join :miter :round :bevel) - (define-enum-type font-slant :normal :itaic :oblique) + (define-enum-type font-slant :normal :italic :oblique) (define-enum-type font-weight :normal :bold) (define-enum-type operator @@ -59,6 +54,18 @@ (define-enum-type subpixel-order :default :rgb :bgr :vrgb :vbgr) (define-enum-type hint-style :default :none :slight :medium :full) (define-enum-type hint-metrics :default :off :on) + + (define-enum-type surface-type + image-surface pdf-surface ps-surface xlib-surface xcb-surface + glitz-surface quartz-surface win32-surface beos-surface + directfb-surface svg-surface os2-surface) + + (defclass surface-class (proxy-class) + ()) + + (defmethod validate-superclass ((class surface-class) (super standard-class)) + (subtypep (class-name super) 'surface)) + (defclass glyph (struct) ((index :allocation :alien @@ -77,13 +84,13 @@ (defclass glyph (struct) :type double-float)) (:metaclass struct-class)) - (defclass font-face (proxy) + (defclass font-face (ref-counted-object) () (:metaclass proxy-class) (:ref %font-face-reference) (:unref %font-face-destroy)) - (defclass font-options (proxy) + (defclass font-options (ref-counted-object) ((antialias :allocation :virtual :getter "font_options_get_antialias" @@ -112,7 +119,7 @@ (defclass font-options (proxy) (:ref %font-options-reference) (:unref %font-options-destroy)) - (defclass scaled-font (proxy) + (defclass scaled-font (ref-counted-object) () (:metaclass proxy-class) (:ref %scaled-font-reference) @@ -143,7 +150,7 @@ (defclass text-extents (struct) (y-advance :allocation :alien :reader text-extents-y-advance :type double-float)) (:metaclass struct-class)) - (defclass pattern (proxy) + (defclass pattern (ref-counted-object) ((extend :allocation :virtual :getter "cairo_pattern_get_extend" @@ -167,24 +174,69 @@ (defclass pattern (proxy) (:unref %pattern-destroy)) - (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 + (defclass surface (ref-counted-object) + ((content :allocation :virtual :getter "cairo_surface_get_content" :reader surface-content :type content)) - (:metaclass proxy-class) - (:ref %surface-reference) - (:unref %surface-destroy)) + (:metaclass surface-class)) - (defclass context (proxy) + (defclass image-surface (surface) + ((data + :allocation :virtual + :getter "cairo_image_surface_get_data" + :reader surface-data + :type pointer) + (format + :allocation :virtual + :getter "cairo_image_surface_get_format" + :reader surface-format + :type surface-format) + (width + :allocation :virtual + :getter "cairo_image_surface_get_width" + :reader surface-width + :type int) + (height + :allocation :virtual + :getter "cairo_image_surface_get_height" + :reader surface-height + :type int) + (stride + :allocation :virtual + :getter "cairo_image_surface_get_stride" + :reader surface-stride + :type int)) + (:metaclass surface-class)) + + (defclass xlib-surface (surface) + ((width + :allocation :virtual + :getter "cairo_xlib_surface_get_width" + :reader surface-width + :type int) + (height + :allocation :virtual + :getter "cairo_xlib_surface_get_height" + :reader surface-height + :type int)) + (:metaclass surface-class)) + + (defclass pdf-surface (surface) + () + (:metaclass surface-class)) + + (defclass ps-surface (surface) + () + (:metaclass surface-class)) + + (defclass svg-surface (surface) + () + (:metaclass surface-class)) + + + (defclass context (ref-counted-object) ((target :allocation :virtual :getter "cairo_get_target" @@ -273,32 +325,23 @@ (defclass context (proxy) (:ref %reference) (:unref %destroy)) - (defclass image-surface (surface) - ((width - :allocation :virtual - :getter "cairo_image_surface_get_width" - :reader surface-width - :type int) - (height - :allocation :virtual - :getter "cairo_image_surface_get_height" - :reader surface-height - :type int)) - (:metaclass proxy-class) - (:ref %surface-reference) - (:unref %surface-destroy)) - ;; (defclass path (proxy) ;; () ;; (:metaclass proxy-class)) -) + ) ;;; Cairo context -(defbinding %reference () nil +(defmethod allocate-foreign ((context context) &key target) + (%create-context target)) + +(defbinding (%create-context "cairo_create") () pointer + (target surface)) + +(defbinding %reference () pointer (location pointer)) (defbinding %destroy () nil @@ -310,8 +353,8 @@ (defbinding (save-context "cairo_save") () nil (defbinding (restore-context "cairo_restore") () nil (cr context)) -(defmacro with-context ((cr) &body body) - (let ((context (make-symbol "CONTEXT"))) +(defmacro with-context ((cr &optional var) &body body) + (let ((context (or var (make-symbol "CONTEXT")))) `(let ((,context ,cr)) (save-context ,context) (unwind-protect @@ -343,9 +386,9 @@ (defun set-source (cr source) (etypecase source (pattern (setf (source cr) source)) (surface (set-source-surface cr source)) + (null (set-source-color cr 0.0 0.0 0.0)) (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)))) + (vector (apply #'set-source-color cr (coerce source 'list))))) (defbinding set-dash (cr dashes &optional (offset 0.0)) nil (cr context) @@ -387,7 +430,7 @@ (defbinding ,tname () boolean (cr context) (x double-float) (y double-float)) - (defbinding ,ename () boolean + (defbinding ,ename () nil (cr context) (x1 double-float :out) (y1 double-float :out) @@ -427,9 +470,9 @@ (defbinding close-path () nil (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)))) + `(progn + ,(when (eq type 'optimized-double-float) + `(declaim (inline ,(first name)))) (defbinding ,name () nil (cr context) ,@(mapcar #'(lambda (arg) (list arg type)) args))))) @@ -455,8 +498,13 @@ (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))) +(defun circle (cr x y radius &optional negative-p) + (move-to cr radius 0.0d0) + (if negative-p + (arc-negative cr x y radius (* pi 2) 0.0d0) + (arc cr x y radius 0.0d0 (* pi 2))) + (close-path cr)) + (defbinding glyph-path (cr glyphs) nil (cr context) @@ -504,7 +552,7 @@ (defbinding pattern-create-radial () pattern (cy1 double-float) (radius1 double-float)) -(defbinding %pattern-reference () nil +(defbinding %pattern-reference () pointer (location pointer)) (defbinding %pattern-destroy () nil @@ -529,9 +577,12 @@ (defbinding scale (cr sx &optional (sy sx)) nil (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)) + (multiple-value-bind (dx dy) (device-to-user-distance cr 1.0 0.0) + (scale cr (sqrt (+ (* dx dx) (* dy dy))))) + (multiple-value-bind (x y) + (with-context (cr) + (move-to cr 0.0 0.0) + (multiple-value-call #'user-to-device cr (get-current-point cr))) (identity-matrix cr) (translate cr x y)))) @@ -609,7 +660,7 @@ (defbinding glyph-extents (cr glyphs &optional (extents (make-instance 'text-ext ;;; Fonts -(defbinding %font-face-reference () nil +(defbinding %font-face-reference () pointer (location pointer)) (defbinding %font-face-destroy () nil @@ -622,7 +673,7 @@ (defbinding font-face-status () status ;;; Scaled Fonts -(defbinding %scaled-font-reference () nil +(defbinding %scaled-font-reference () pointer (location pointer)) (defbinding %scaled-font-destroy () nil @@ -685,12 +736,45 @@ (defbinding font-options-equal-p () boolean ;;; Surfaces -(defbinding %surface-reference () nil +(defmethod make-proxy-instance :around ((class surface-class) location + &rest initargs) + (let ((class (find-class (%surface-get-type location)))) + (apply #'call-next-method class location initargs))) + +(defbinding %surface-get-type () surface-type + (location pointer)) + +(defbinding %surface-reference () pointer (location pointer)) (defbinding %surface-destroy () nil (location pointer)) +(defmethod reference-function ((class surface-class)) + (declare (ignore class)) + #'%surface-reference) + +(defmethod unreference-function ((class surface-class)) + (declare (ignore class)) + #'%surface-destroy) + +(defbinding %surface-set-user-data (surface key data-id) status + (surface pointer) + ((quark-intern key) pointer-data) + (data-id pointer-data) + (user-data-destroy-callback callback)) + +(defmethod (setf user-data) (data (surface surface) key) + (%surface-set-user-data (foreign-location surface) key (register-user-data data)) + data) + +(defbinding %surface-get-user-data () pointer-data + (surface surface) + (key pointer-data)) + +(defmethod user-data ((surface surface) key) + (find-user-data (%surface-get-user-data surface (quark-intern key)))) + (defbinding surface-create-similar () surface (other surface) (format surface-format ) @@ -730,46 +814,166 @@ (defun surface-mark-dirty (surface &optional x y width height) (%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)) +(define-callback stream-write-func status + ((stream-id pointer-data) (data pointer) (length unsigned-int)) + (let ((stream (find-user-data stream-id))) + (typecase stream + (stream + (map-c-vector 'nil #'(lambda (octet) (write-byte octet stream)) + data '(unsigned-byte 8) length)) + ((or symbol function) + (funcall stream + (map-c-vector 'vector #'identity data '(unsigned-byte 8) length))))) + :success) + + +(defmacro with-surface ((surface cr) &body body) + `(let ((,cr (make-instance 'context :target ,surface))) + ,@body)) + ;; Image Surface ;; Should data be automatically freed when the surface is GCed? (defmethod allocate-foreign ((surface image-surface) - &key width height stride format data) - (if (not data) - (%image-surface-create format width height) + &key filename width height stride format data) + (cond + (filename (%image-surface-create-from-png filename)) + ((not data) (%image-surface-create format width height)) + (t (%image-surface-create-for-data data format width height (or stride (let ((element-size (cdr (assoc format '((:argb32 . 4) (:rgb24 . 4) (:a8 . 1) (:a1 1/8)))))) - (ceiling (* width element-size))))))) + (ceiling (* width element-size)))))))) -(defbinding %image-surface-create () image-surface +(defbinding %image-surface-create () pointer (format surface-format) (width int) (hegit int)) -(defbinding %image-surface-create-for-data () image-surface +(defbinding %image-surface-create-for-data () pointer (data pointer) (format surface-format) (width int) (hegit int) (stride int)) +(defbinding %image-surface-create-from-png () pointer + (filename pathname)) - -;;; PNG Surface - -(defbinding image-surface-create-from-png (filename) image-surface - ((truename filename) pathname)) - +(defbinding surface-write-to-png () status + (surface surface) + (filename pathname)) + + +;;; PDF Surface + +(defmethod allocate-foreign ((surface pdf-surface) + &key filename stream width height) + (cond + ((and filename stream) + (error "Only one of the arguments :filename and :stream may be specified")) + (filename (%pdf-surface-create filename width height)) + (stream + (let* ((stream-id (register-user-data stream)) + (location (%pdf-surface-create-for-stream stream-id width height))) + (%surface-set-user-data location 'stream stream-id) + location)))) + + +(defbinding %pdf-surface-create () pointer + (filename pathname) + (width double-float) + (height double-float)) + +(defbinding %pdf-surface-create-for-stream (stream width height) pointer + (stream-write-func callback) + (stream pointer-data) + (width double-float) + (height double-float)) + +(defbinding pdf-surface-set-size () nil + (surface pdf-surface) + (width double-float) + (height double-float)) + + +;;; PS Surface + +(defmethod allocate-foreign ((surface ps-surface) + &key filename stream width height) + (cond + ((and filename stream) + (error "Only one of the arguments :filename and :stream may be specified")) + (filename (%ps-surface-create filename width height)) + (stream + (let* ((stream-id (register-user-data stream)) + (location (%ps-surface-create-for-stream stream-id width height))) + (%surface-set-user-data location 'stream stream-id) + location)))) + +(defbinding %ps-surface-create () pointer + (filename pathname) + (width double-float) + (height double-float)) + +(defbinding %ps-surface-create-for-stream (stream width height) pointer + (stream-write-func callback) + (stream pointer-data) + (width double-float) + (height double-float)) + +(defbinding ps-surface-set-size () nil + (surface ps-surface) + (width double-float) + (height double-float)) + +(defbinding ps-surface-dsc-begin-setup () nil + (surface ps-surface)) + +(defbinding ps-surface-dsc-begin-page-setup () nil + (surface ps-surface)) + +(defbinding ps-surface-dsc-comment () nil + (surface ps-surface) + (comment string)) + + +;;; SVG Surface + +(defmethod allocate-foreign ((surface svg-surface) + &key filename stream width height) + (cond + ((and filename stream) + (error "Only one of the arguments :filename and :stream may be specified")) + (filename (%svg-surface-create filename width height)) + (stream + (let* ((stream-id (register-user-data stream)) + (location (%svg-surface-create-for-stream stream-id width height))) + (%surface-set-user-data location 'stream stream-id) + location)))) + +(defbinding %svg-surface-create () pointer + (filename pathname) + (width double-float) + (height double-float)) + +(defbinding %svg-surface-create-for-stream (stream width height) pointer + (stream-write-func callback) + (stream pointer-data) + (width double-float) + (height double-float)) + +(defbinding svg-surface-restrict-to-version () nil + (surface svg-surface) + (version svg-version)) @@ -781,15 +985,21 @@ (defbinding matrix-init () nil (xy double-float) (yy double-float) (x0 double-float) (y0 double-float)) -(defbinding matrix-init-identity () nil +(defbinding matrix-init-identity (&optional (matrix (make-instance 'matrix))) nil (matrix matrix :in/return)) +(defun identity-matrix-p (matrix) + (with-slots (xx yx xy yy x0 y0) matrix + (and + (= xx 1.0d0) (= yx 0.0d0) (= xy 0.0d0) + (= yy 1.0d0) (= x0 0.0d0) (= y0 0.0d0)))) + (defbinding matrix-init-translate () nil (matrix matrix :in/return) (tx double-float) (ty double-float)) -(defbinding matrix-init-scale () nil +(defbinding matrix-init-scale (matrix sx &optional (sy sx)) nil (matrix matrix :in/return) (sx double-float) (sy double-float)) @@ -803,7 +1013,7 @@ (defbinding matrix-translate () nil (tx double-float) (ty double-float)) -(defbinding matrix-scale () nil +(defbinding matrix-scale (matrix sx &optional (sy sx)) nil (matrix matrix :in/return) (sx double-float) (sy double-float)) @@ -820,15 +1030,12 @@ (defbinding matrix-multiply () nil (a matrix) (b matrix)) -(defbinding matrix-transform-distance () nil - (matrix matrix :in/return) - (dx double-float) - (dy double-float)) +(defbinding matrix-transform-distance (matrix dx &optional (dy dx)) nil + (matrix matrix) + (dx double-float :in/out) + (dy double-float :in/out)) (defbinding matrix-transform-point () nil - (matrix matrix :in/return) - (x double-float) - (y double-float)) - - - + (matrix matrix) + (x double-float :in/out) + (y double-float :in/out))