chiark / gitweb /
Add a boundp-function slot, which is required by virtual slot getter.
[clg] / cairo / cairo.lisp
1 ;; Common Lisp bindings for Cairo
2 ;; Copyright 2005 Espen S. Johnsen <espen@users.sf.net>
3 ;;
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:
11 ;;
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
14 ;;
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.
22
23 ;; $Id: cairo.lisp,v 1.25 2009-02-09 11:45:03 espen Exp $
24
25 (in-package "CAIRO")
26
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)
31
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
38     :invalid-dash)
39
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)
45
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)
49
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)
56
57
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)
62
63   (defclass surface-class (proxy-class)
64     ())
65
66   (defmethod validate-superclass ((class surface-class) (super standard-class))
67     (subtypep (class-name super) 'surface))
68
69   (defclass glyph (struct)
70     ((index 
71       :allocation :alien 
72       :initarg :index 
73       :accessor glyph-index 
74       :type unsigned-long)
75      (x     
76       :allocation :alien 
77       :initarg :x 
78       :accessor glyph-x 
79       :type double-float)
80      (y     
81       :allocation :alien 
82       :initarg :y 
83       :accessor glyph-y
84       :type double-float))
85     (:metaclass struct-class))
86
87   (defclass font-face (ref-counted-object)
88     ()
89     (:metaclass proxy-class)
90     (:ref %font-face-reference)
91     (:unref %font-face-destroy))
92
93   (defclass font-options (ref-counted-object)
94     ((antialias
95       :allocation :virtual 
96       :getter "font_options_get_antialias"
97       :setter "font_options_set_antialias"
98       :accessor font-options-antialias
99       :type antialias)
100      (subpixel-order
101       :allocation :virtual 
102       :getter "font_options_get_subpixel_order"
103       :setter "font_options_set_subpixel_order"
104       :accessor font-options-subpixel-order
105       :type subpixel-order)
106      (hint-style
107       :allocation :virtual 
108       :getter "font_options_get_hint_style"
109       :setter "font_options_set_hint_style"
110       :accessor font-options-hint-style
111       :type hint-style)
112      (hint-metrics
113       :allocation :virtual 
114       :getter "font_options_get_hint_metrics"
115       :setter "font_options_set_hint_metrics"
116       :accessor font-options-hint-metrics
117       :type hint-metrics))
118     (:metaclass proxy-class)    
119     (:ref %font-options-reference)
120     (:unref %font-options-destroy))
121
122   (defclass scaled-font (ref-counted-object)
123     ()
124     (:metaclass proxy-class)
125     (:ref %scaled-font-reference)
126     (:unref %scaled-font-destroy))
127
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))
142
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))
150
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))
159
160   (defclass pattern (ref-counted-object)
161     ((extend
162       :allocation :virtual 
163       :getter "cairo_pattern_get_extend"
164       :setter "cairo_pattern_set_extend"
165       :accessor pattern-extend
166       :type extend)
167      (filter
168       :allocation :virtual 
169       :getter "cairo_pattern_get_filter"
170       :setter "cairo_pattern_set_filter"
171       :accessor pattern-filter
172       :type filter)
173      (matrix
174       :allocation :virtual 
175       :getter "cairo_pattern_get_matrix"
176       :setter "cairo_pattern_set_matrix"
177       :accessor pattern-matrix
178       :type matrix))
179     (:metaclass proxy-class)
180     (:ref %pattern-reference)
181     (:unref %pattern-destroy))
182
183
184   (defclass surface (ref-counted-object)
185     ((content 
186       :allocation :virtual 
187       :getter "cairo_surface_get_content"
188       :reader surface-content
189       :type content))
190     (:metaclass surface-class))
191
192   (defclass image-surface (surface)
193     ((data
194       :allocation :virtual 
195       :getter "cairo_image_surface_get_data"
196       :reader surface-data
197       :type pointer)
198      (format
199       :allocation :virtual 
200       :getter "cairo_image_surface_get_format"
201       :reader surface-format
202       :type surface-format)
203      (width
204       :allocation :virtual 
205       :getter "cairo_image_surface_get_width"
206       :reader surface-width
207       :type int)
208      (height
209       :allocation :virtual 
210       :getter "cairo_image_surface_get_height"
211       :reader surface-height
212       :type int)
213      (stride
214       :allocation :virtual 
215       :getter "cairo_image_surface_get_stride"
216       :reader surface-stride
217       :type int))
218     (:metaclass surface-class))
219
220   (defclass xlib-surface (surface)
221     ((width
222       :allocation :virtual 
223       :getter "cairo_xlib_surface_get_width"
224       :reader surface-width
225       :type int)
226      (height
227       :allocation :virtual 
228       :getter "cairo_xlib_surface_get_height"
229       :reader surface-height
230       :type int))
231     (:metaclass surface-class))
232
233   (defclass vector-surface (surface)
234     ((width :allocation :virtual :getter surface-width)
235      (height :allocation :virtual :setter surface-height))
236     (:metaclass surface-class))
237
238   (defclass pdf-surface (vector-surface)
239     ()
240     (:metaclass surface-class))
241   
242   (defclass ps-surface (vector-surface)
243     ()
244     (:metaclass surface-class))
245     
246   (defclass svg-surface (vector-surface)
247     ()
248     (:metaclass surface-class))
249
250
251   (defclass context (ref-counted-object)
252     ((target
253       :allocation :virtual 
254       :getter "cairo_get_target"
255       :reader target
256       :type surface)
257      (source
258       :allocation :virtual 
259       :getter "cairo_get_source"
260       :setter "cairo_set_source"
261       :accessor source
262       :type pattern)
263      (antialias
264       :allocation :virtual 
265       :getter "cairo_get_antialias"
266       :setter "cairo_set_antialias"
267       :accessor antialias
268       :type antialias)
269      (tolerance
270       :allocation :virtual 
271       :getter "cairo_get_tolerance"
272       :setter "cairo_set_tolerance"
273       :accessor tolerance
274       :type double-float)
275      (fill-rule
276       :allocation :virtual 
277       :getter "cairo_get_fill_rule"
278       :setter "cairo_set_fill_rule"
279       :accessor fill-rule
280       :type fill-rule)
281      (line-width
282       :allocation :virtual 
283       :getter "cairo_get_line_width"
284       :setter "cairo_set_line_width"
285       :accessor line-width
286       :type double-float)
287      (line-cap
288       :allocation :virtual 
289       :getter "cairo_get_line_cap"
290       :setter "cairo_set_line_cap"
291       :accessor line-cap
292       :type line-cap)
293      (line-join
294       :allocation :virtual 
295       :getter "cairo_get_line_join"
296       :setter "cairo_set_line_join"
297       :accessor line-join
298       :type line-join)
299      (miter-limit
300       :allocation :virtual 
301       :getter "cairo_get_miter_limit"
302       :setter "cairo_set_miter_limit"
303       :accessor miter-limit
304       :type double-float)
305      (font-matrix
306       :allocation :virtual 
307       :getter font-matrix
308       :setter "cairo_set_font_matrix"
309       :writer (setf font-matrix)
310       :type matrix)
311      (font-options
312       :allocation :virtual 
313       :getter font-options
314       :setter "cairo_set_font_options"
315       :writer (setf font-options)
316       :type font-options)
317      (font-face
318       :allocation :virtual 
319       :getter "cairo_get_font_face"
320       :setter "cairo_set_font_face"
321       :accessor font-face
322       :type font-face)
323      #?(pkg-exists-p "cairo" :atleast-version "1.4")
324      (scaled-font
325       :allocation :virtual 
326       :getter "cairo_get_scaled_font"
327       :setter "cairo_set_scaled_font"
328       :accessor scaled-font
329       :type scaled-font)
330      (operator
331       :allocation :virtual 
332       :getter "cairo_get_operator"
333       :setter "cairo_set_operator"
334       :accessor operator
335       :type operator)
336      (matrix
337       :allocation :virtual 
338       :getter matrix
339       :setter "cairo_set_matrix"
340       :writer (setf matrix)
341       :type matrix)
342      )
343     (:metaclass proxy-class)
344     (:ref %reference)
345     (:unref %destroy))
346
347
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))
354
355   (defclass jpeg-parameter (struct)
356     ((quality     
357       :allocation :alien 
358       :initarg :quality
359       :initform 75
360       :type int)
361      (interlace     
362       :allocation :alien 
363       :initarg :interlace
364       :initform t
365       :type boolean))
366     (:metaclass struct-class)))
367
368
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)))))
374
375 (deftype status-signal () 'status)
376
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))
382      status))
383
384
385
386 ;;; Cairo context
387
388 (defmethod allocate-foreign ((context context) &key target)
389   (%create-context target))
390
391 (defbinding (%create-context "cairo_create") () pointer
392   (target surface))
393
394 (defbinding %reference () pointer
395   (location pointer))
396
397 (defbinding %destroy () nil
398   (location pointer))
399
400 (defbinding (save-context "cairo_save") () nil
401   (cr context))
402
403 (defbinding (restore-context "cairo_restore") () nil
404   (cr context))
405
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)
410        (unwind-protect
411            (progn ,@body)
412          (restore-context ,context)))))
413
414 (defbinding status () status
415   (cr context))
416
417 (defun ensure-color-component (component)
418   (etypecase component
419     (float component)
420     (integer (/ component 256.0))))
421
422 (defbinding (set-source-color "cairo_set_source_rgba") (cr red green blue &optional (alpha 1.0)) nil
423   (cr context)
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))
428
429 (defbinding set-source-surface (cr surface &optional (x 0.0) (y 0.0)) nil
430   (cr context)
431   (surface surface)
432   (x double-float)
433   (y double-float))
434
435 (defun set-source (cr source)
436   (etypecase 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)))))
442
443 (defbinding set-dash (cr dashes &optional (offset 0.0)) nil
444   (cr context)
445   (dashes (vector double-float))
446   ((length dashes) int)
447   (offset double-float))
448
449 (defbinding (paint "cairo_paint_with_alpha") (cr &optional (alpha 1.0)) nil
450   (cr context)
451   (alpha double-float))
452
453 (defbinding mask () nil
454   (cr context)
455   (pattern pattern))
456
457 (defbinding mask-surface () nil
458   (cr context)
459   (surface surface)
460   (surface-x double-float)
461   (surface-y double-float))
462
463 (defmacro defoperator (name &optional clip-p)
464   (let ((iname (intern (format nil "%~A" name)))
465         (pname (intern (format nil "%~A-PRESERVE" name))))
466     `(progn
467        (defbinding ,iname () nil
468          (cr context))
469        (defbinding ,pname () nil
470          (cr context))
471        (defun ,name (cr &optional preserve)
472          (if preserve
473              (,pname cr)
474            (,iname cr)))
475        ,(unless clip-p
476           (let ((tname (intern (format nil "IN-~A-P" name)))
477                 (ename (intern (format nil "~A-EXTENTS" name))))
478             `(progn
479                (defbinding ,tname () boolean
480                  (cr context)
481                  (x double-float)
482                  (y double-float))
483                (defbinding ,ename () nil
484                  (cr context)
485                  (x1 double-float :out)
486                  (y1 double-float :out)
487                  (x2 double-float :out)
488                  (y2 double-float :out))))))))
489
490 (defoperator clip t)
491 (defoperator stroke)
492 (defoperator fill)
493
494 (defbinding reset-clip () nil
495   (cr context))
496
497 (defbinding copy-page () nil
498   (cr context))
499
500 (defbinding show-page () nil
501   (cr context))
502
503
504 ;;; Paths
505
506 (defbinding %path-destroy () nil
507   (location pointer))
508
509 (defbinding copy-path () path
510   (cr context))
511
512 (defbinding copy-path-flat () path
513   (cr context))
514
515 (defbinding append-path () nil
516   (cr context)
517   (path path))
518
519 (defbinding get-current-point () nil
520   (cr context)
521   (x double-float :out)
522   (y double-float :out))
523
524 (defbinding new-path () nil
525   (cr context))
526
527 #?(pkg-exists-p "cairo" :atleast-version "1.2")
528 (defbinding new-sub-path () nil
529   (cr context))
530
531 (defbinding close-path () nil
532   (cr context))
533
534 (defmacro defpath (name args &optional relative-p)
535   (flet ((def (name type)
536            `(progn
537               ,(when (eq type 'optimized-double-float)
538                  `(declaim (inline ,(first name))))
539               (defbinding ,name () nil
540                 (cr context)
541                 ,@(mapcar #'(lambda (arg) (list arg type)) args)))))
542
543   `(progn
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))
548      ,@(when relative-p
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)))
552            (list
553             (def rel-name 'double-float)
554             (def (list fast-rel-name cname) 'optimized-double-float)))))))
555
556
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))
563
564 (defun circle (cr x y radius &optional negative-p)
565   (move-to cr radius 0.0d0)
566   (if negative-p
567       (arc-negative cr x y radius (* pi 2) 0.0d0)
568     (arc cr x y radius 0.0d0 (* pi 2)))
569   (close-path cr))
570
571
572 (defbinding glyph-path (cr glyphs) nil
573   (cr context)
574   (glyphs (vector glyph))
575   ((length glyphs) int))
576
577 (defbinding text-path () nil
578   (cr context)
579   (text string))
580
581
582
583 ;;; Patterns
584
585 (defbinding (pattern-add-color-stop "cairo_pattern_add_color_stop_rgba")
586     (pattern offset red green blue &optional (alpha 1.0)) nil
587   (pattern pattern)
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))
593
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))
600
601 (defbinding pattern-create-for-surface () pattern
602   (surface surface))
603
604 (defbinding pattern-create-linear () pattern
605   (x0 double-float)
606   (y0 double-float)
607   (x1 double-float)
608   (y1 double-float))
609
610 (defbinding pattern-create-radial () pattern
611   (cx0 double-float)
612   (cy0 double-float)
613   (radius0 double-float)
614   (cx1 double-float)
615   (cy1 double-float)
616   (radius1 double-float))
617
618 (defbinding %pattern-reference () pointer
619   (location pointer))
620
621 (defbinding %pattern-destroy () nil
622   (location pointer))
623
624 (defbinding pattern-status () status
625   (pattern pattern))
626
627
628
629 ;;; Transformations
630
631 (defbinding translate () nil
632   (cr context)
633   (tx double-float)
634   (ty double-float))
635
636 (defbinding scale (cr sx &optional (sy sx)) nil
637   (cr context)
638   (sx double-float)
639   (sy double-float))
640
641 (defun scale-to-device (cr &optional keep-rotation-p)
642   (if 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)
646         (with-context (cr)
647           (move-to cr 0.0 0.0)
648           (multiple-value-call #'user-to-device cr (get-current-point cr)))
649       (identity-matrix cr)
650       (translate cr x y))))
651
652 (defbinding rotate () nil
653   (cr context)
654   (angle double-float))
655
656 (defbinding transform () nil
657   (cr context)
658   (matrix matrix))
659
660 (defbinding (matrix "cairo_get_matrix") () nil
661   (cr context)
662   ((make-instance 'matrix) matrix :in/return))
663
664 (defbinding identity-matrix () nil
665   (cr context))
666
667 (defbinding user-to-device () nil
668   (cr context)
669   (x double-float :in/out)
670   (y double-float :in/out))
671
672 (defbinding user-to-device-distance (cr dx &optional (dy dx)) nil
673   (cr context)
674   (dx double-float :in/out)
675   (dy double-float :in/out))
676
677 (defbinding device-to-user () nil
678   (cr context)
679   (x double-float :in/out)
680   (y double-float :in/out))
681
682 (defbinding device-to-user-distance (cr dx &optional (dy dx)) nil
683   (cr context)
684   (dx double-float :in/out)
685   (dy double-float :in/out))
686
687
688 ;;; Text
689
690 (defbinding select-font-face () nil
691   (cr context)
692   (family string)
693   (slant font-slant)
694   (weight font-weight))
695
696 (defbinding set-font-size () nil
697   (cr context)
698   (size double-float))
699
700 (defbinding (font-matrix "cairo_get_font_matrix") () nil
701   (cr context)
702   ((make-instance 'matrix) matrix :in/return))
703
704 (defbinding (font-options "cairo_get_font_options") () nil
705   (cr context)
706   ((make-instance 'font-options) font-options :in/return))
707
708 (defbinding show-text () nil
709   (cr context)
710   (text string))
711
712 (defbinding show-glyphs () nil
713   (cr context)
714   (glyphs (vector (inlined glyph)))
715   ((length glyphs) int))
716
717 (defbinding font-extents (cr &optional (extents (make-instance 'font-extents))) nil
718   (cr context)
719   (extents font-extents :in/return))
720
721 (defbinding text-extents (cr text &optional (extents (make-instance 'text-extents))) nil
722   (cr context)
723   (text string)
724   (extents text-extents :in/return))
725
726 (defbinding glyph-extents (cr glyphs &optional (extents (make-instance 'text-extents))) nil
727   (cr context)
728   (glyphs (vector glyph))
729   ((length glyphs) int)
730   (extents text-extents :in/return))
731
732
733 ;;; Fonts
734
735 (defbinding %font-face-reference () pointer
736   (location pointer))
737
738 (defbinding %font-face-destroy () nil
739   (location pointer))
740
741 (defbinding font-face-status () status
742   (font-face font-face))
743
744
745
746 ;;; Scaled Fonts
747
748 (defbinding %scaled-font-reference () pointer
749   (location pointer))
750
751 (defbinding %scaled-font-destroy () nil
752   (location pointer))
753
754 (defbinding scaled-font-status () status
755   (scaled-font scaled-font))
756
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))
760
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))
766
767 (defbinding %scaled-font-create () pointer
768   (font-face font-face)
769   (font-matrix matrix)
770   (ctm matrix)
771   (options font-options))
772
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))
775
776
777
778 ;;; Font Options
779
780
781 (defbinding %font-options-copy () nil
782   (location pointer))
783
784 (defbinding %font-options-destroy () nil
785   (location pointer))
786
787 (defbinding font-options-status () status
788   (font-options font-options))
789
790 (defbinding %font-options-create () pointer)
791
792 (defmethod allocate-foreign ((font-options font-options) &rest initargs)
793   (declare (ignore initargs))
794   (%font-options-create))
795
796 (defbinding font-options-merge () nil
797   (options1 font-options :in/return)
798   (options2 font-options))
799
800 (defbinding font-options-hash () unsigned-int
801   (options font-options))
802
803 (defbinding font-options-equal-p () boolean
804   (options1 font-options)
805   (options2 font-options))
806
807
808
809 ;;; Surfaces
810
811 (defgeneric user-data (surface key))
812 (defgeneric (setf user-data) (value surface key))
813
814 (defmethod make-proxy-instance :around ((class surface-class) location 
815                                         &rest initargs)
816   (let ((class (find-class (%surface-get-type location))))
817     (apply #'call-next-method class location initargs)))
818
819 (defbinding %surface-get-type () surface-type
820   (location pointer))
821
822 (defbinding %surface-reference () pointer
823   (location pointer))
824
825 (defbinding %surface-destroy () nil
826   (location pointer))
827
828 (defbinding %surface-status () status
829   pointer)
830
831 (defmethod allocate-foreign :around ((surface surface) &key)
832   (let ((location (call-next-method)))
833     (cond
834       ((not (eq (%surface-status location) :success))
835        (%surface-destroy location)
836        (error 'cairo-error :status (%surface-status location)))
837       (t location))))
838
839 (defmethod reference-function ((class surface-class))
840   (declare (ignore class))
841   #'%surface-reference)
842
843 (defmethod unreference-function ((class surface-class))
844   (declare (ignore class))
845   #'%surface-destroy)
846
847 (defbinding %surface-set-user-data (surface key data-id) status-signal
848   (surface pointer)
849   ((quark-intern key) pointer-data)
850   (data-id pointer-data)
851   (user-data-destroy-callback callback))
852
853 (defmethod (setf user-data) (data (surface surface) key)
854   (%surface-set-user-data (foreign-location surface) key (register-user-data data))
855   data)
856
857 (defbinding %surface-get-user-data () pointer-data
858   (surface surface)
859   (key pointer-data))
860
861 (defmethod user-data ((surface surface) key)
862   (find-user-data (%surface-get-user-data surface (quark-intern key))))
863
864 (defbinding surface-create-similar () surface
865   (other surface)
866   (format surface-format )
867   (width int)
868   (height int))
869
870 (defbinding surface-finish () nil
871   (surface surface))
872
873 (defbinding surface-flush () nil
874   (surface surface))
875
876 (defbinding surface-get-font-options () nil
877   (surface surface)
878   ((make-instance 'font-options) font-options :in/return))
879
880 (defbinding surface-set-device-offset () nil
881   (surface surface)
882   (x-offset double-float)
883   (y-offset double-float))
884
885 (defbinding surface-status () status
886   (surface surface))
887
888 (defbinding %surface-mark-dirty () nil
889   (surface surface))
890
891 (defbinding %surface-mark-dirty-rectangle () nil
892   (surface surface)
893   (x int)
894   (y int)
895   (width int)
896   (height int))
897
898 (defun surface-mark-dirty (surface &optional x y width height)
899   (if x
900       (%surface-mark-dirty-rectangle surface x y width height)
901     (%surface-mark-dirty surface)))
902
903 (defbinding surface-set-fallback-resolution () nil
904   (surface surface)
905   (x-pixels-per-inch double-float)
906   (y-pixels-per-inch double-float))
907
908 (defun %stream-write-func (stream-id data length)
909   (let ((stream (find-user-data stream-id))
910         (sequence 
911          (map-c-vector 'vector #'identity data '(unsigned-byte 8) length)))
912     (handler-case (etypecase stream
913                     (stream 
914                      (write-sequence sequence stream)
915                      length)
916                     ((or symbol function) 
917                      (funcall stream sequence)))
918       (serious-condition (condition)
919         (declare (ignore condition))
920         0))))
921
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)
925       :success
926     :write-error))
927
928 (defun %stream-read-func (stream-id data length)
929   (let* ((stream (find-user-data stream-id)))
930     (handler-case                              
931         (multiple-value-bind (sequence bytes-read)
932             (etypecase stream
933               (stream
934                (let ((sequence (make-array length
935                                 :element-type '(unsigned-byte 8))))
936                  (values sequence (read-sequence sequence stream))))
937               ((or symbol function) (funcall stream length)))
938           (make-c-vector '(unsigned-byte 8) (or bytes-read (length sequence))
939            :content sequence :location data)
940           (or bytes-read (length sequence)))
941       (serious-condition (condition)
942         (declare (ignore condition))
943         0))))
944
945 (define-callback stream-read-func status 
946     ((stream-id pointer-data) (data pointer) (length unsigned-int))
947   (if (= (%stream-read-func stream-id data length) length)
948       :success
949     :read-error))
950
951 (defmacro with-surface ((surface cr) &body body)
952   `(let ((,cr (make-instance 'context :target ,surface)))
953      ,@body))
954
955
956 ;; Image Surface
957
958 (defmethod allocate-foreign ((surface image-surface) &key source type
959                              width height stride format)
960   (etypecase source
961    (null (%image-surface-create format width height))
962    ((or stream function symbol)
963     (let ((stream-id (register-user-data source)))
964       (unwind-protect
965            (cond
966              ((member type '("png" "image/png") :test #'equal)
967               (%image-surface-create-from-png-stream stream-id))
968              ((member type '("jpeg" "image/jpeg") :test #'equal)
969               (%image-surface-create-from-jpeg-stream stream-id))
970              ((not type) (error "Image type must be specified"))
971              ((error "Can't handle image type ~A" type)))
972         (destroy-user-data stream-id))))
973    ((or string pathname)
974     (cond 
975       ((member type '("png" "image/png") :test #'equal)
976        (%image-surface-create-from-png source))
977       ((member type '("jpeg" "image/jpeg") :test #'equal)
978        (%image-surface-create-from-jpeg source))
979       ((not type) (error "Image type must be specified"))
980       ((error "Can't handle image type ~A" type))))
981    (pointer
982     (%image-surface-create-for-data source format width height 
983      (or stride (format-stride-for-width format width))))))
984
985 #?(pkg-exists-p "cairo" :atleast-version "1.6")
986 (defbinding format-stride-for-width () int
987   surface-format (width int))
988
989 #?-(pkg-exists-p "cairo" :atleast-version "1.6")
990 (defun format-stride-for-width (format width)
991   (let ((element-size (cdr (assoc format '((:argb32 . 4) (:rgb24 . 4) (:a8 . 1) (:a1 1/8))))))
992     (ceiling (* width element-size))))
993
994
995 (defbinding %image-surface-create () pointer
996   (format surface-format)
997   (width int)
998   (hegit int))
999
1000 (defbinding %image-surface-create-for-data () pointer
1001   (data pointer)
1002   (format surface-format)
1003   (width int)
1004   (hegit int)
1005   (stride int))
1006
1007 (defbinding %image-surface-create-from-png () pointer
1008   (filename pathname))
1009
1010 (defbinding %image-surface-create-from-png-stream (stream) pointer
1011   (stream-read-func callback)
1012   (stream pointer-data))
1013
1014 (defbinding %surface-write-to-png () status-signal
1015   (surface surface)
1016   (filename pathname))
1017
1018 (defbinding %surface-write-to-png-stream (surface stream) status-signal
1019   (surface surface)
1020   (stream-write-func callback)
1021   (stream pointer-data))
1022
1023 (defgeneric surface-write-to-png (surface dest))
1024
1025 (defmethod surface-write-to-png (surface filename)
1026   (%surface-write-to-png surface filename))
1027
1028 (defmethod surface-write-to-png (surface (stream stream))
1029   (let ((stream-id (register-user-data stream)))
1030     (unwind-protect
1031          (%surface-write-to-png-stream surface stream-id)
1032       (destroy-user-data stream-id))))
1033
1034
1035 ;;; JPEG support
1036
1037 (define-callback jpeg-stream-write-func unsigned
1038     ((stream-id pointer-data) (data pointer) (length unsigned-int))
1039   (%stream-write-func stream-id data length))
1040
1041 (define-callback jpeg-stream-read-func unsigned
1042     ((stream-id pointer-data) (data pointer) (length unsigned-int))
1043   (%stream-read-func stream-id data length))
1044
1045 (defbinding %image-surface-create-from-jpeg () pointer
1046   (filename pathname)
1047   (status status-signal :out))
1048
1049 (defbinding %image-surface-create-from-jpeg-stream (stream) pointer
1050   (jpeg-stream-read-func callback)
1051   (stream pointer-data)
1052   (status status-signal :out))
1053
1054 (defgeneric surface-write-to-jpeg (surface dest &key quality interlace))
1055
1056 (defun %surface-acquire-image (surface)
1057   (typecase surface
1058     (image-surface surface)
1059     ((let ((image (make-instance 'image-surface
1060                    :width (surface-width surface)
1061                    :height (surface-height surface)
1062                    :format :argb32)))
1063        (with-surface (image cr)
1064          (set-source-surface cr surface)
1065          (setf (operator cr) :source)
1066          (paint cr))
1067        image))))
1068
1069 (defbinding %surface-write-to-jpeg () status-signal
1070   (surface image-surface)
1071   (filename pathname)
1072   (param jpeg-parameter))
1073
1074 (defmethod surface-write-to-jpeg (surface filename &key 
1075                                   (quality 75) (interlace t))
1076   (let ((param (make-instance 'jpeg-parameter 
1077                 :quality quality :interlace interlace)))
1078     (%surface-write-to-jpeg (%surface-acquire-image surface) filename param)))
1079
1080 (defbinding %surface-write-to-jpeg-stream (surface stream param) status-signal
1081   (surface surface)
1082   (jpeg-stream-write-func callback)
1083   (stream pointer-data)
1084   (param jpeg-parameter))
1085
1086 (defmethod surface-write-to-jpeg (surface (stream stream) &key 
1087                                   (quality 75) (interlace t))
1088   (let ((stream-id (register-user-data stream))
1089         (param (make-instance 'jpeg-parameter 
1090                 :quality quality :interlace interlace)))
1091     (unwind-protect
1092          (%surface-write-to-jpeg-stream (%surface-acquire-image surface) stream-id param)
1093       (destroy-user-data stream-id))))
1094
1095
1096 ;;; Virtual size surface (abstract class)
1097
1098 (defmethod initialize-instance :after ((surface vector-surface) &key
1099                                        width height)
1100   (setf (user-data surface 'width) width)
1101   (setf (user-data surface 'height) height))
1102
1103 (defmethod surface-width ((surface vector-surface))
1104   (user-data surface 'width))
1105
1106 (defmethod surface-height ((surface vector-surface))
1107   (user-data surface 'height))
1108
1109
1110 (defun allocate-vector-surface (surface-create surface-create-for-stream
1111                                 &key output filename stream width height)
1112   (let ((location
1113          (cond
1114            ((/= (count-if #'identity (list output filename stream)) 1)
1115             (error "One and only one of the arguments :OUTPUT, :FILENAME and :STREAM shoud be specified"))
1116            (filename (funcall surface-create filename width height))
1117            ((typep output '(or string pathname))
1118             (%svg-surface-create output width height))
1119            (t
1120             (let* ((stream-id (register-user-data (or stream output)))
1121                    (location (funcall surface-create-for-stream 
1122                               stream-id width height)))
1123               (%surface-set-user-data location 'stream stream-id)
1124               location)))))
1125     location))
1126
1127
1128 ;;; PDF Surface
1129
1130 (defmethod allocate-foreign ((surface pdf-surface) &rest args)
1131   (apply #'allocate-vector-surface 
1132    #'%pdf-surface-create #'%pdf-surface-create-for-stream args))
1133
1134 (defbinding %pdf-surface-create () pointer
1135   (filename pathname)
1136   (width double-float)
1137   (height double-float))
1138
1139 (defbinding %pdf-surface-create-for-stream (stream width height) pointer
1140   (stream-write-func callback)
1141   (stream pointer-data)
1142   (width double-float)
1143   (height double-float))
1144
1145 (defbinding pdf-surface-set-size () nil
1146   (surface pdf-surface)
1147   (width double-float)
1148   (height double-float))
1149
1150
1151 ;;; PS Surface
1152
1153 (defmethod allocate-foreign ((surface ps-surface) &rest args)
1154   (apply #'allocate-vector-surface 
1155    #'%ps-surface-create #'%ps-surface-create-for-stream args))
1156
1157 (defbinding %ps-surface-create () pointer
1158   (filename pathname)
1159   (width double-float)
1160   (height double-float))
1161
1162 (defbinding %ps-surface-create-for-stream (stream width height) pointer
1163   (stream-write-func callback)
1164   (stream pointer-data)
1165   (width double-float)
1166   (height double-float))
1167
1168 (defbinding ps-surface-set-size () nil
1169   (surface ps-surface)
1170   (width double-float)
1171   (height double-float))
1172
1173 (defbinding ps-surface-dsc-begin-setup () nil
1174   (surface ps-surface))
1175
1176 (defbinding ps-surface-dsc-begin-page-setup () nil
1177   (surface ps-surface))
1178
1179 (defbinding ps-surface-dsc-comment () nil
1180   (surface ps-surface)
1181   (comment string))
1182
1183
1184 ;;; SVG Surface
1185
1186 (defmethod allocate-foreign ((surface svg-surface) &rest args)
1187   (apply #'allocate-vector-surface 
1188    #'%svg-surface-create #'%svg-surface-create-for-stream args))
1189
1190 (defbinding %svg-surface-create () pointer
1191   (filename pathname)
1192   (width double-float)
1193   (height double-float))
1194
1195 (defbinding %svg-surface-create-for-stream (stream width height) pointer
1196   (stream-write-func callback)
1197   (stream pointer-data)
1198   (width double-float)
1199   (height double-float))
1200
1201 (defbinding svg-surface-restrict-to-version () nil
1202   (surface svg-surface)
1203   (version svg-version))
1204
1205
1206
1207 ;;; Matrices
1208
1209 (defbinding matrix-init (xx yx xy yy x0 y0 &optional (matrix (make-instance 'matrix))) nil
1210   (matrix matrix :in/return)
1211   (xx double-float) (yx double-float) 
1212   (xy double-float) (yy double-float) 
1213   (x0 double-float) (y0 double-float))
1214
1215 (defbinding matrix-init-identity (&optional (matrix (make-instance 'matrix))) nil
1216   (matrix matrix :in/return))
1217
1218 (defun identity-matrix-p (matrix)
1219   (with-slots (xx yx xy yy x0 y0) matrix
1220     (and 
1221      (= xx 1.0d0) (= yx 0.0d0) (= xy 0.0d0)
1222      (= yy 1.0d0) (= x0 0.0d0) (= y0 0.0d0))))
1223
1224 (defbinding matrix-init-translate (tx ty &optional (matrix (make-instance 'matrix))) nil
1225   (matrix matrix :in/return)
1226   (tx double-float)
1227   (ty double-float))
1228
1229 (defbinding matrix-init-scale (sx &optional (sy sx) (matrix (make-instance 'matrix))) nil
1230   (matrix matrix :in/return)
1231   (sx double-float)
1232   (sy double-float))
1233
1234 (defbinding matrix-init-rotate (rotation &optional (matrix (make-instance 'matrix))) nil
1235   (matrix matrix :in/return)
1236   (rotation double-float))
1237
1238 (defbinding matrix-translate () nil
1239   (matrix matrix :in/return)
1240   (tx double-float)
1241   (ty double-float))
1242
1243 (defbinding matrix-scale (matrix sx &optional (sy sx)) nil
1244   (matrix matrix :in/return)
1245   (sx double-float)
1246   (sy double-float))
1247
1248 (defbinding matrix-rotate () nil
1249   (matrix matrix :in/return)
1250   (rotation double-float))
1251
1252 (defbinding matrix-invert () nil
1253   (matrix matrix :in/return))
1254
1255 (defbinding matrix-multiply () nil
1256   (result matrix :out)
1257   (a matrix)
1258   (b matrix))
1259
1260 (defbinding matrix-transform-distance (matrix dx &optional (dy dx)) nil
1261   (matrix matrix)
1262   (dx double-float :in/out)
1263   (dy double-float :in/out))
1264
1265 (defbinding matrix-transform-point () nil
1266   (matrix matrix)
1267   (x double-float :in/out)
1268   (y double-float :in/out))
1269
1270
1271 ;; Version information
1272
1273 (defbinding %version () int)
1274
1275 (defun version ()
1276   (let ((version (%version)))
1277     (values 
1278      (mod (truncate version 10000) 100)
1279      (mod (truncate version 100) 100)
1280      (mod version 100))))
1281
1282 (defbinding version-string () (static string))