1 ;; Common Lisp bindings for Cairo
2 ;; Copyright 2005 Espen S. Johnsen <espen@users.sf.net>
4 ;; Permission is hereby granted, free of charge, to any person obtaining
5 ;; a copy of this software and associated documentation files (the
6 ;; "Software"), to deal in the Software without restriction, including
7 ;; without limitation the rights to use, copy, modify, merge, publish,
8 ;; distribute, sublicense, and/or sell copies of the Software, and to
9 ;; permit persons to whom the Software is furnished to do so, subject to
10 ;; the following conditions:
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
23 ;; $Id: cairo.lisp,v 1.24 2008/11/28 19:26:04 espen Exp $
27 (eval-when (:compile-toplevel :load-toplevel :execute)
28 (define-enum-type surface-format :argb32 :rgb24 :a8 :a1)
29 (define-enum-type content :color :alpha :color-alpha)
30 (define-enum-type svg-version :svg-1.1 :svg-1.2)
32 (define-enum-type status
33 :success :no-memory :invalid-restore :invalid-pop-group
34 :no-current-point :invalid-matrix :invalid-status :null-pointer
35 :invalid-string :invalid-path-data :read-error :write-error
36 :surface-finished :surface-type-mismatch :pattern-type-mismatch
37 :invalid-content :invalid-format :invalid-visual :file-not-found
40 (define-enum-type fill-rule :winding :even-odd)
41 (define-enum-type line-cap :butt :round :square)
42 (define-enum-type line-join :miter :round :bevel)
43 (define-enum-type font-slant :normal :italic :oblique)
44 (define-enum-type font-weight :normal :bold)
46 (define-enum-type operator
47 :clear :source :over :in :out :atop :dest :dest-over
48 :dest-in :dest-out :dest-atop :xor :add :saturate)
50 (define-enum-type antialias :default :none :gray :subpixel)
51 (define-enum-type extend :none :repeat :reflect)
52 (define-enum-type filter :fast :good :best :nearest :bilinear :gaussian)
53 (define-enum-type subpixel-order :default :rgb :bgr :vrgb :vbgr)
54 (define-enum-type hint-style :default :none :slight :medium :full)
55 (define-enum-type hint-metrics :default :off :on)
58 (define-enum-type surface-type
59 image-surface pdf-surface ps-surface xlib-surface xcb-surface
60 glitz-surface quartz-surface win32-surface beos-surface
61 directfb-surface svg-surface os2-surface)
63 (defclass surface-class (proxy-class)
66 (defmethod validate-superclass ((class surface-class) (super standard-class))
67 (subtypep (class-name super) 'surface))
69 (defclass glyph (struct)
85 (:metaclass struct-class))
87 (defclass font-face (ref-counted-object)
89 (:metaclass proxy-class)
90 (:ref %font-face-reference)
91 (:unref %font-face-destroy))
93 (defclass font-options (ref-counted-object)
96 :getter "font_options_get_antialias"
97 :setter "font_options_set_antialias"
98 :accessor font-options-antialias
102 :getter "font_options_get_subpixel_order"
103 :setter "font_options_set_subpixel_order"
104 :accessor font-options-subpixel-order
105 :type subpixel-order)
108 :getter "font_options_get_hint_style"
109 :setter "font_options_set_hint_style"
110 :accessor font-options-hint-style
114 :getter "font_options_get_hint_metrics"
115 :setter "font_options_set_hint_metrics"
116 :accessor font-options-hint-metrics
118 (:metaclass proxy-class)
119 (:ref %font-options-reference)
120 (:unref %font-options-destroy))
122 (defclass scaled-font (ref-counted-object)
124 (:metaclass proxy-class)
125 (:ref %scaled-font-reference)
126 (:unref %scaled-font-destroy))
128 (defclass matrix (struct)
129 ((xx :allocation :alien :initarg :xx :initform 1.0
130 :accessor matrix-xx :type double-float)
131 (yx :allocation :alien :initarg :yx :initform 0.0
132 :accessor matrix-yx :type double-float)
133 (xy :allocation :alien :initarg :xy :initform 1.0
134 :accessor matrix-xy :type double-float)
135 (yy :allocation :alien :initarg :yy :initform 0.0
136 :accessor matrix-yy :type double-float)
137 (x0 :allocation :alien :initarg :x0 :initform 0.0
138 :accessor matrix-x0 :type double-float)
139 (y0 :allocation :alien :initarg :y0 :initform 0.0
140 :accessor matrix-y0 :type double-float))
141 (:metaclass struct-class))
143 (defclass font-extents (struct)
144 ((ascent :allocation :alien :reader font-extents-ascent :type double-float)
145 (descent :allocation :alien :reader font-extents-descent :type double-float)
146 (height :allocation :alien :reader font-extents-height :type double-float)
147 (max-x-advance :allocation :alien :reader font-extents-max-x-advance :type double-float)
148 (max-y-advance :allocation :alien :reader font-extents-max-y-advance :type double-float))
149 (:metaclass struct-class))
151 (defclass text-extents (struct)
152 ((x-bearing :allocation :alien :reader text-extents-x-bearing :type double-float)
153 (y-bearing :allocation :alien :reader text-extents-y-bearing :type double-float)
154 (width :allocation :alien :reader text-extents-width :type double-float)
155 (height :allocation :alien :reader text-extents-height :type double-float)
156 (x-advance :allocation :alien :reader text-extents-x-advance :type double-float)
157 (y-advance :allocation :alien :reader text-extents-y-advance :type double-float))
158 (:metaclass struct-class))
160 (defclass pattern (ref-counted-object)
163 :getter "cairo_pattern_get_extend"
164 :setter "cairo_pattern_set_extend"
165 :accessor pattern-extend
169 :getter "cairo_pattern_get_filter"
170 :setter "cairo_pattern_set_filter"
171 :accessor pattern-filter
175 :getter "cairo_pattern_get_matrix"
176 :setter "cairo_pattern_set_matrix"
177 :accessor pattern-matrix
179 (:metaclass proxy-class)
180 (:ref %pattern-reference)
181 (:unref %pattern-destroy))
184 (defclass surface (ref-counted-object)
187 :getter "cairo_surface_get_content"
188 :reader surface-content
190 (:metaclass surface-class))
192 (defclass image-surface (surface)
195 :getter "cairo_image_surface_get_data"
200 :getter "cairo_image_surface_get_format"
201 :reader surface-format
202 :type surface-format)
205 :getter "cairo_image_surface_get_width"
206 :reader surface-width
210 :getter "cairo_image_surface_get_height"
211 :reader surface-height
215 :getter "cairo_image_surface_get_stride"
216 :reader surface-stride
218 (:metaclass surface-class))
220 (defclass xlib-surface (surface)
223 :getter "cairo_xlib_surface_get_width"
224 :reader surface-width
228 :getter "cairo_xlib_surface_get_height"
229 :reader surface-height
231 (:metaclass surface-class))
233 (defclass vector-surface (surface)
234 ((width :allocation :virtual :getter surface-width)
235 (height :allocation :virtual :setter surface-height))
236 (:metaclass surface-class))
238 (defclass pdf-surface (vector-surface)
240 (:metaclass surface-class))
242 (defclass ps-surface (vector-surface)
244 (:metaclass surface-class))
246 (defclass svg-surface (vector-surface)
248 (:metaclass surface-class))
251 (defclass context (ref-counted-object)
254 :getter "cairo_get_target"
259 :getter "cairo_get_source"
260 :setter "cairo_set_source"
265 :getter "cairo_get_antialias"
266 :setter "cairo_set_antialias"
271 :getter "cairo_get_tolerance"
272 :setter "cairo_set_tolerance"
277 :getter "cairo_get_fill_rule"
278 :setter "cairo_set_fill_rule"
283 :getter "cairo_get_line_width"
284 :setter "cairo_set_line_width"
289 :getter "cairo_get_line_cap"
290 :setter "cairo_set_line_cap"
295 :getter "cairo_get_line_join"
296 :setter "cairo_set_line_join"
301 :getter "cairo_get_miter_limit"
302 :setter "cairo_set_miter_limit"
303 :accessor miter-limit
308 :setter "cairo_set_font_matrix"
309 :writer (setf font-matrix)
314 :setter "cairo_set_font_options"
315 :writer (setf font-options)
319 :getter "cairo_get_font_face"
320 :setter "cairo_set_font_face"
323 #?(pkg-exists-p "cairo" :atleast-version "1.4")
326 :getter "cairo_get_scaled_font"
327 :setter "cairo_set_scaled_font"
328 :accessor scaled-font
332 :getter "cairo_get_operator"
333 :setter "cairo_set_operator"
339 :setter "cairo_set_matrix"
340 :writer (setf matrix)
343 (:metaclass proxy-class)
348 (defclass path (struct)
349 ((status :allocation :alien :type status)
350 (data :allocation :alien :type pointer)
351 (length :allocation :alien :type int))
352 (:metaclass proxy-class)
353 (:unref %path-destroy))
355 (defclass jpeg-parameter (struct)
366 (:metaclass struct-class)))
369 (define-condition cairo-error (error)
370 ((status :initarg :status :reader cairo-status))
371 (:report (lambda (condition stream)
372 (format stream "Cairo function returned with status code: ~A"
373 (cairo-status condition)))))
375 (deftype status-signal () 'status)
377 (define-type-method from-alien-form ((type status-signal) status &key ref)
378 (declare (ignore type ref))
379 `(let ((status ,(from-alien-form 'status status)))
380 (unless (eq status :success)
381 (error 'cairo-error :status status))
388 (defmethod allocate-foreign ((context context) &key target)
389 (%create-context target))
391 (defbinding (%create-context "cairo_create") () pointer
394 (defbinding %reference () pointer
397 (defbinding %destroy () nil
400 (defbinding (save-context "cairo_save") () nil
403 (defbinding (restore-context "cairo_restore") () nil
406 (defmacro with-context ((cr &optional var) &body body)
407 (let ((context (or var (make-symbol "CONTEXT"))))
408 `(let ((,context ,cr))
409 (save-context ,context)
412 (restore-context ,context)))))
414 (defbinding status () status
417 (defun ensure-color-component (component)
420 (integer (/ component 256.0))))
422 (defbinding (set-source-color "cairo_set_source_rgba") (cr red green blue &optional (alpha 1.0)) nil
424 ((ensure-color-component red) double-float)
425 ((ensure-color-component green) double-float)
426 ((ensure-color-component blue) double-float)
427 ((ensure-color-component alpha) double-float))
429 (defbinding set-source-surface (cr surface &optional (x 0.0) (y 0.0)) nil
435 (defun set-source (cr source)
437 (pattern (setf (source cr) source))
438 (surface (set-source-surface cr source))
439 (null (set-source-color cr 0.0 0.0 0.0))
440 (list (apply #'set-source-color cr source))
441 (vector (apply #'set-source-color cr (coerce source 'list)))))
443 (defbinding set-dash (cr dashes &optional (offset 0.0)) nil
445 (dashes (vector double-float))
446 ((length dashes) int)
447 (offset double-float))
449 (defbinding (paint "cairo_paint_with_alpha") (cr &optional (alpha 1.0)) nil
451 (alpha double-float))
453 (defbinding mask () nil
457 (defbinding mask-surface () nil
460 (surface-x double-float)
461 (surface-y double-float))
463 (defmacro defoperator (name &optional clip-p)
464 (let ((iname (intern (format nil "%~A" name)))
465 (pname (intern (format nil "%~A-PRESERVE" name))))
467 (defbinding ,iname () nil
469 (defbinding ,pname () nil
471 (defun ,name (cr &optional preserve)
476 (let ((tname (intern (format nil "IN-~A-P" name)))
477 (ename (intern (format nil "~A-EXTENTS" name))))
479 (defbinding ,tname () boolean
483 (defbinding ,ename () nil
485 (x1 double-float :out)
486 (y1 double-float :out)
487 (x2 double-float :out)
488 (y2 double-float :out))))))))
494 (defbinding reset-clip () nil
497 (defbinding copy-page () nil
500 (defbinding show-page () nil
506 (defbinding %path-destroy () nil
509 (defbinding copy-path () path
512 (defbinding copy-path-flat () path
515 (defbinding append-path () nil
519 (defbinding get-current-point () nil
521 (x double-float :out)
522 (y double-float :out))
524 (defbinding new-path () nil
527 #?(pkg-exists-p "cairo" :atleast-version "1.2")
528 (defbinding new-sub-path () nil
531 (defbinding close-path () nil
534 (defmacro defpath (name args &optional relative-p)
535 (flet ((def (name type)
537 ,(when (eq type 'optimized-double-float)
538 `(declaim (inline ,(first name))))
539 (defbinding ,name () nil
541 ,@(mapcar #'(lambda (arg) (list arg type)) args)))))
544 ,(def name 'double-float)
545 ,(let ((name (intern (format nil "FAST-~A" name)))
546 (cname (gffi::default-alien-fname name)))
547 (def (list name cname) 'optimized-double-float))
549 (let* ((rel-name (intern (format nil "REL-~A" name)))
550 (fast-rel-name (intern (format nil "FAST-REL-~A" name)))
551 (cname (gffi::default-alien-fname rel-name)))
553 (def rel-name 'double-float)
554 (def (list fast-rel-name cname) 'optimized-double-float)))))))
557 (defpath arc (xc yc radius angle1 angle2))
558 (defpath arc-negative (xc yc radius angle1 angle2))
559 (defpath curve-to (x1 y1 x2 y2 x3 y3) t)
560 (defpath line-to (x y) t)
561 (defpath move-to (x y) t)
562 (defpath rectangle (x y width height))
564 (defun circle (cr x y radius &optional negative-p)
565 (move-to cr radius 0.0d0)
567 (arc-negative cr x y radius (* pi 2) 0.0d0)
568 (arc cr x y radius 0.0d0 (* pi 2)))
572 (defbinding glyph-path (cr glyphs) nil
574 (glyphs (vector glyph))
575 ((length glyphs) int))
577 (defbinding text-path () nil
585 (defbinding (pattern-add-color-stop "cairo_pattern_add_color_stop_rgba")
586 (pattern offset red green blue &optional (alpha 1.0)) nil
588 (offset double-float)
589 ((ensure-color-component red) double-float)
590 ((ensure-color-component green) double-float)
591 ((ensure-color-component blue) double-float)
592 ((ensure-color-component alpha) double-float))
594 (defbinding (pattern-create "cairo_pattern_create_rgba")
595 (red green blue &optional (alpha 1.0)) pattern
596 ((ensure-color-component red) double-float)
597 ((ensure-color-component green) double-float)
598 ((ensure-color-component blue) double-float)
599 ((ensure-color-component alpha) double-float))
601 (defbinding pattern-create-for-surface () pattern
604 (defbinding pattern-create-linear () pattern
610 (defbinding pattern-create-radial () pattern
613 (radius0 double-float)
616 (radius1 double-float))
618 (defbinding %pattern-reference () pointer
621 (defbinding %pattern-destroy () nil
624 (defbinding pattern-status () status
631 (defbinding translate () nil
636 (defbinding scale (cr sx &optional (sy sx)) nil
641 (defun scale-to-device (cr &optional keep-rotation-p)
643 (multiple-value-bind (dx dy) (device-to-user-distance cr 1.0 0.0)
644 (scale cr (sqrt (+ (* dx dx) (* dy dy)))))
645 (multiple-value-bind (x y)
648 (multiple-value-call #'user-to-device cr (get-current-point cr)))
650 (translate cr x y))))
652 (defbinding rotate () nil
654 (angle double-float))
656 (defbinding transform () nil
660 (defbinding (matrix "cairo_get_matrix") () nil
662 ((make-instance 'matrix) matrix :in/return))
664 (defbinding identity-matrix () nil
667 (defbinding user-to-device () nil
669 (x double-float :in/out)
670 (y double-float :in/out))
672 (defbinding user-to-device-distance (cr dx &optional (dy dx)) nil
674 (dx double-float :in/out)
675 (dy double-float :in/out))
677 (defbinding device-to-user () nil
679 (x double-float :in/out)
680 (y double-float :in/out))
682 (defbinding device-to-user-distance (cr dx &optional (dy dx)) nil
684 (dx double-float :in/out)
685 (dy double-float :in/out))
690 (defbinding select-font-face () nil
694 (weight font-weight))
696 (defbinding set-font-size () nil
700 (defbinding (font-matrix "cairo_get_font_matrix") () nil
702 ((make-instance 'matrix) matrix :in/return))
704 (defbinding (font-options "cairo_get_font_options") () nil
706 ((make-instance 'font-options) font-options :in/return))
708 (defbinding show-text () nil
712 (defbinding show-glyphs () nil
714 (glyphs (vector (inlined glyph)))
715 ((length glyphs) int))
717 (defbinding font-extents (cr &optional (extents (make-instance 'font-extents))) nil
719 (extents font-extents :in/return))
721 (defbinding text-extents (cr text &optional (extents (make-instance 'text-extents))) nil
724 (extents text-extents :in/return))
726 (defbinding glyph-extents (cr glyphs &optional (extents (make-instance 'text-extents))) nil
728 (glyphs (vector glyph))
729 ((length glyphs) int)
730 (extents text-extents :in/return))
735 (defbinding %font-face-reference () pointer
738 (defbinding %font-face-destroy () nil
741 (defbinding font-face-status () status
742 (font-face font-face))
748 (defbinding %scaled-font-reference () pointer
751 (defbinding %scaled-font-destroy () nil
754 (defbinding scaled-font-status () status
755 (scaled-font scaled-font))
757 (defbinding scaled-font-extents (scaled-font &optional (extents (make-instance 'text-extents))) nil
758 (scaled-font scaled-font)
759 (extents text-extents :in/return))
761 (defbinding scaled-font-glyph-extents (scaled-font glyphs &optional (extents (make-instance 'text-extents))) nil
762 (scaled-font scaled-font)
763 (glyphs (vector glyph))
764 ((length glyphs) int)
765 (extents text-extents :in/return))
767 (defbinding %scaled-font-create () pointer
768 (font-face font-face)
771 (options font-options))
773 (defmethod allocate-foreign ((scaled-font scaled-font) &key font-face font-matrix cmt options)
774 (%scaled-font-create font-face font-matrix cmt options))
781 (defbinding %font-options-copy () nil
784 (defbinding %font-options-destroy () nil
787 (defbinding font-options-status () status
788 (font-options font-options))
790 (defbinding %font-options-create () pointer)
792 (defmethod allocate-foreign ((font-options font-options) &rest initargs)
793 (declare (ignore initargs))
794 (%font-options-create))
796 (defbinding font-options-merge () nil
797 (options1 font-options :in/return)
798 (options2 font-options))
800 (defbinding font-options-hash () unsigned-int
801 (options font-options))
803 (defbinding font-options-equal-p () boolean
804 (options1 font-options)
805 (options2 font-options))
811 (defgeneric user-data (surface key))
812 (defgeneric (setf user-data) (value surface key))
814 (defmethod make-proxy-instance :around ((class surface-class) location
816 (let ((class (find-class (%surface-get-type location))))
817 (apply #'call-next-method class location initargs)))
819 (defbinding %surface-get-type () surface-type
822 (defbinding %surface-reference () pointer
825 (defbinding %surface-destroy () nil
828 (defbinding %surface-status () status
831 (defmethod allocate-foreign :around ((surface image-surface) &key)
832 (let ((location (call-next-method)))
834 ((not (eq (%surface-status location) :success))
835 (%surface-destroy location)
836 (error 'cairo-error :status (%surface-status location)))
839 (defmethod reference-function ((class surface-class))
840 (declare (ignore class))
841 #'%surface-reference)
843 (defmethod unreference-function ((class surface-class))
844 (declare (ignore class))
847 (defbinding %surface-set-user-data (surface key data-id) status-signal
849 ((quark-intern key) pointer-data)
850 (data-id pointer-data)
851 (user-data-destroy-callback callback))
853 (defmethod (setf user-data) (data (surface surface) key)
854 (%surface-set-user-data (foreign-location surface) key (register-user-data data))
857 (defbinding %surface-get-user-data () pointer-data
861 (defmethod user-data ((surface surface) key)
862 (find-user-data (%surface-get-user-data surface (quark-intern key))))
864 (defbinding surface-create-similar () surface
866 (format surface-format )
870 (defbinding surface-finish () nil
873 (defbinding surface-flush () nil
876 (defbinding surface-get-font-options () nil
878 ((make-instance 'font-options) font-options :in/return))
880 (defbinding surface-set-device-offset () nil
882 (x-offset double-float)
883 (y-offset double-float))
885 (defbinding surface-status () status
888 (defbinding %surface-mark-dirty () nil
891 (defbinding %surface-mark-dirty-rectangle () nil
898 (defun surface-mark-dirty (surface &optional x y width height)
900 (%surface-mark-dirty-rectangle surface x y width height)
901 (%surface-mark-dirty surface)))
903 (defbinding surface-set-fallback-resolution () nil
905 (x-pixels-per-inch double-float)
906 (y-pixels-per-inch double-float))
908 (defun %stream-write-func (stream-id data length)
909 (let ((stream (find-user-data stream-id))
911 (map-c-vector 'vector #'identity data '(unsigned-byte 8) length)))
912 (handler-case (etypecase stream
914 (write-sequence sequence stream)
916 ((or symbol function)
917 (funcall stream sequence)))
918 (serious-condition (condition)
919 (declare (ignore condition))
922 (define-callback stream-write-func status
923 ((stream-id pointer-data) (data pointer) (length unsigned-int))
924 (if (= (%stream-write-func stream-id data length) length)
928 (defun %stream-read-func (stream-id data length)
929 (let* ((stream (find-user-data stream-id))
930 (sequence (make-array length :element-type '(unsigned-byte 8)))
932 (handler-case (etypecase stream
934 (read-sequence sequence stream))
935 ((or symbol function)
936 (funcall stream sequence)))
937 (serious-condition (condition)
938 (declare (ignore condition))
940 (make-c-vector '(unsigned-byte 8) bytes-read
941 :content sequence :location data)
944 (define-callback stream-read-func status
945 ((stream-id pointer-data) (data pointer) (length unsigned-int))
946 (if (= (%stream-read-func stream-id data length) length)
950 (defmacro with-surface ((surface cr) &body body)
951 `(let ((,cr (make-instance 'context :target ,surface)))
957 (defmethod allocate-foreign ((surface image-surface) &key source type
958 width height stride format)
961 (let ((stream-id (register-user-data source)))
964 ((member type '("png" "image/png") :test #'equal)
965 (%image-surface-create-from-png-stream stream-id))
966 ((member type '("jpeg" "image/jpeg") :test #'equal)
967 (%image-surface-create-from-jpeg-stream stream-id))
968 ((not type) (error "Image type must be specified"))
969 ((error "Can't handle image type ~A" type)))
970 (destroy-user-data stream-id))))
971 ((or string pathname)
973 ((member type '("png" "image/png") :test #'equal)
974 (%image-surface-create-from-png source))
975 ((member type '("jpeg" "image/jpeg") :test #'equal)
976 (%image-surface-create-from-jpeg source))
977 ((not type) (error "Image type must be specified"))
978 ((error "Can't handle image type ~A" type))))
980 (%image-surface-create-for-data source format width height
981 (or stride (format-stride-for-width format width))))
982 (null (%image-surface-create format width height))))
984 #?(pkg-exists-p "cairo" :atleast-version "1.6")
985 (defbinding format-stride-for-width () int
986 surface-format (width int))
988 #?-(pkg-exists-p "cairo" :atleast-version "1.6")
989 (defun format-stride-for-width (format width)
990 (let ((element-size (cdr (assoc format '((:argb32 . 4) (:rgb24 . 4) (:a8 . 1) (:a1 1/8))))))
991 (ceiling (* width element-size))))
994 (defbinding %image-surface-create () pointer
995 (format surface-format)
999 (defbinding %image-surface-create-for-data () pointer
1001 (format surface-format)
1006 (defbinding %image-surface-create-from-png () pointer
1007 (filename pathname))
1009 (defbinding %image-surface-create-from-png-stream (stream) pointer
1010 (stream-read-func callback)
1011 (stream pointer-data))
1013 (defbinding %surface-write-to-png () status-signal
1015 (filename pathname))
1017 (defbinding %surface-write-to-png-stream (surface stream) status-signal
1019 (stream-write-func callback)
1020 (stream pointer-data))
1022 (defgeneric surface-write-to-png (surface dest))
1024 (defmethod surface-write-to-png (surface filename)
1025 (%surface-write-to-png surface filename))
1027 (defmethod surface-write-to-png (surface (stream stream))
1028 (let ((stream-id (register-user-data stream)))
1030 (%surface-write-to-png-stream surface stream-id)
1031 (destroy-user-data stream-id))))
1036 (define-callback jpeg-stream-write-func unsigned
1037 ((stream-id pointer-data) (data pointer) (length unsigned-int))
1038 (%stream-write-func stream-id data length))
1040 (define-callback jpeg-stream-read-func unsigned
1041 ((stream-id pointer-data) (data pointer) (length unsigned-int))
1042 (%stream-read-func stream-id data length))
1044 (defbinding %image-surface-create-from-jpeg () pointer
1046 (status status-signal :out))
1048 (defbinding %image-surface-create-from-jpeg-stream (stream) pointer
1049 (jpeg-stream-read-func callback)
1050 (stream pointer-data)
1051 (status status-signal :out))
1053 (defgeneric surface-write-to-jpeg (surface dest &key quality interlace))
1055 (defun %surface-acquire-image (surface)
1057 (image-surface surface)
1058 ((let ((image (make-instance 'image-surface
1059 :width (surface-width surface)
1060 :height (surface-height surface)
1062 (with-surface (image cr)
1063 (set-source-surface cr surface)
1064 (setf (operator cr) :source)
1068 (defbinding %surface-write-to-jpeg () status-signal
1069 (surface image-surface)
1071 (param jpeg-parameter))
1073 (defmethod surface-write-to-jpeg (surface filename &key
1074 (quality 75) (interlace t))
1075 (let ((param (make-instance 'jpeg-parameter
1076 :quality quality :interlace interlace)))
1077 (%surface-write-to-jpeg (%surface-acquire-image surface) filename param)))
1079 (defbinding %surface-write-to-jpeg-stream (surface stream param) status-signal
1081 (jpeg-stream-write-func callback)
1082 (stream pointer-data)
1083 (param jpeg-parameter))
1085 (defmethod surface-write-to-jpeg (surface (stream stream) &key
1086 (quality 75) (interlace t))
1087 (let ((stream-id (register-user-data stream))
1088 (param (make-instance 'jpeg-parameter
1089 :quality quality :interlace interlace)))
1091 (%surface-write-to-jpeg-stream (%surface-acquire-image surface) stream-id param)
1092 (destroy-user-data stream-id))))
1095 ;;; Virtual size surface (abstract class)
1097 (defmethod initialize-instance :after ((surface vector-surface) &key
1099 (setf (user-data surface 'width) width)
1100 (setf (user-data surface 'height) height))
1102 (defmethod surface-width ((surface vector-surface))
1103 (user-data surface 'width))
1105 (defmethod surface-height ((surface vector-surface))
1106 (user-data surface 'height))
1109 (defun allocate-vector-surface (surface-create surface-create-for-stream
1110 &key output filename stream width height)
1113 ((/= (count-if #'identity (list output filename stream)) 1)
1114 (error "One and only one of the arguments :OUTPUT, :FILENAME and :STREAM shoud be specified"))
1115 (filename (funcall surface-create filename width height))
1116 ((typep output '(or string pathname))
1117 (%svg-surface-create output width height))
1119 (let* ((stream-id (register-user-data (or stream output)))
1120 (location (funcall surface-create-for-stream
1121 stream-id width height)))
1122 (%surface-set-user-data location 'stream stream-id)
1129 (defmethod allocate-foreign ((surface pdf-surface) &rest args)
1130 (apply #'allocate-vector-surface
1131 #'%pdf-surface-create #'%pdf-surface-create-for-stream args))
1133 (defbinding %pdf-surface-create () pointer
1135 (width double-float)
1136 (height double-float))
1138 (defbinding %pdf-surface-create-for-stream (stream width height) pointer
1139 (stream-write-func callback)
1140 (stream pointer-data)
1141 (width double-float)
1142 (height double-float))
1144 (defbinding pdf-surface-set-size () nil
1145 (surface pdf-surface)
1146 (width double-float)
1147 (height double-float))
1152 (defmethod allocate-foreign ((surface ps-surface) &rest args)
1153 (apply #'allocate-vector-surface
1154 #'%ps-surface-create #'%ps-surface-create-for-stream args))
1156 (defbinding %ps-surface-create () pointer
1158 (width double-float)
1159 (height double-float))
1161 (defbinding %ps-surface-create-for-stream (stream width height) pointer
1162 (stream-write-func callback)
1163 (stream pointer-data)
1164 (width double-float)
1165 (height double-float))
1167 (defbinding ps-surface-set-size () nil
1168 (surface ps-surface)
1169 (width double-float)
1170 (height double-float))
1172 (defbinding ps-surface-dsc-begin-setup () nil
1173 (surface ps-surface))
1175 (defbinding ps-surface-dsc-begin-page-setup () nil
1176 (surface ps-surface))
1178 (defbinding ps-surface-dsc-comment () nil
1179 (surface ps-surface)
1185 (defmethod allocate-foreign ((surface svg-surface) &rest args)
1186 (apply #'allocate-vector-surface
1187 #'%svg-surface-create #'%svg-surface-create-for-stream args))
1189 (defbinding %svg-surface-create () pointer
1191 (width double-float)
1192 (height double-float))
1194 (defbinding %svg-surface-create-for-stream (stream width height) pointer
1195 (stream-write-func callback)
1196 (stream pointer-data)
1197 (width double-float)
1198 (height double-float))
1200 (defbinding svg-surface-restrict-to-version () nil
1201 (surface svg-surface)
1202 (version svg-version))
1208 (defbinding matrix-init (xx yx xy yy x0 y0 &optional (matrix (make-instance 'matrix))) nil
1209 (matrix matrix :in/return)
1210 (xx double-float) (yx double-float)
1211 (xy double-float) (yy double-float)
1212 (x0 double-float) (y0 double-float))
1214 (defbinding matrix-init-identity (&optional (matrix (make-instance 'matrix))) nil
1215 (matrix matrix :in/return))
1217 (defun identity-matrix-p (matrix)
1218 (with-slots (xx yx xy yy x0 y0) matrix
1220 (= xx 1.0d0) (= yx 0.0d0) (= xy 0.0d0)
1221 (= yy 1.0d0) (= x0 0.0d0) (= y0 0.0d0))))
1223 (defbinding matrix-init-translate (tx ty &optional (matrix (make-instance 'matrix))) nil
1224 (matrix matrix :in/return)
1228 (defbinding matrix-init-scale (sx &optional (sy sx) (matrix (make-instance 'matrix))) nil
1229 (matrix matrix :in/return)
1233 (defbinding matrix-init-rotate (rotation &optional (matrix (make-instance 'matrix))) nil
1234 (matrix matrix :in/return)
1235 (rotation double-float))
1237 (defbinding matrix-translate () nil
1238 (matrix matrix :in/return)
1242 (defbinding matrix-scale (matrix sx &optional (sy sx)) nil
1243 (matrix matrix :in/return)
1247 (defbinding matrix-rotate () nil
1248 (matrix matrix :in/return)
1249 (rotation double-float))
1251 (defbinding matrix-invert () nil
1252 (matrix matrix :in/return))
1254 (defbinding matrix-multiply () nil
1255 (result matrix :out)
1259 (defbinding matrix-transform-distance (matrix dx &optional (dy dx)) nil
1261 (dx double-float :in/out)
1262 (dy double-float :in/out))
1264 (defbinding matrix-transform-point () nil
1266 (x double-float :in/out)
1267 (y double-float :in/out))
1270 ;; Version information
1272 (defbinding %version () int)
1275 (let ((version (%version)))
1277 (mod (truncate version 10000) 100)
1278 (mod (truncate version 100) 100)
1279 (mod version 100))))
1281 (defbinding version-string () (static string))