chiark - git - mdw - clg/blob - 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.24 2008-11-28 19:26:04 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 image-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          (sequence (make-array length :element-type '(unsigned-byte 8)))
 931          (bytes-read
 932           (handler-case (etypecase stream
 933                           (stream
 934                            (read-sequence sequence stream))
 935                           ((or symbol function)
 936                            (funcall stream sequence)))
 937             (serious-condition (condition)
 938               (declare (ignore condition))
 939               0))))
 940     (make-c-vector '(unsigned-byte 8) bytes-read
 941      :content sequence :location data)
 942     bytes-read))
 943
 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)
 947       :success
 948     :read-error))
 949
 950 (defmacro with-surface ((surface cr) &body body)
 951   `(let ((,cr (make-instance 'context :target ,surface)))
 952      ,@body))
 953
 954
 955 ;; Image Surface
 956
 957 (defmethod allocate-foreign ((surface image-surface) &key source type
 958                              width height stride format)
 959   (etypecase source
 960    (stream
 961     (let ((stream-id (register-user-data source)))
 962       (unwind-protect
 963            (cond
 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)
 972     (cond
 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))))
 979    (pointer
 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))))
 983
 984 #?(pkg-exists-p "cairo" :atleast-version "1.6")
 985 (defbinding format-stride-for-width () int
 986   surface-format (width int))
 987
 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))))
 992
 993
 994 (defbinding %image-surface-create () pointer
 995   (format surface-format)
 996   (width int)
 997   (hegit int))
 998
 999 (defbinding %image-surface-create-for-data () pointer
1000   (data pointer)
1001   (format surface-format)
1002   (width int)
1003   (hegit int)
1004   (stride int))
1005
1006 (defbinding %image-surface-create-from-png () pointer
1007   (filename pathname))
1008
1009 (defbinding %image-surface-create-from-png-stream (stream) pointer
1010   (stream-read-func callback)
1011   (stream pointer-data))
1012
1013 (defbinding %surface-write-to-png () status-signal
1014   (surface surface)
1015   (filename pathname))
1016
1017 (defbinding %surface-write-to-png-stream (surface stream) status-signal
1018   (surface surface)
1019   (stream-write-func callback)
1020   (stream pointer-data))
1021
1022 (defgeneric surface-write-to-png (surface dest))
1023
1024 (defmethod surface-write-to-png (surface filename)
1025   (%surface-write-to-png surface filename))
1026
1027 (defmethod surface-write-to-png (surface (stream stream))
1028   (let ((stream-id (register-user-data stream)))
1029     (unwind-protect
1030          (%surface-write-to-png-stream surface stream-id)
1031       (destroy-user-data stream-id))))
1032
1033
1034 ;;; JPEG support
1035
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))
1039
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))
1043
1044 (defbinding %image-surface-create-from-jpeg () pointer
1045   (filename pathname)
1046   (status status-signal :out))
1047
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))
1052
1053 (defgeneric surface-write-to-jpeg (surface dest &key quality interlace))
1054
1055 (defun %surface-acquire-image (surface)
1056   (typecase surface
1057     (image-surface surface)
1058     ((let ((image (make-instance 'image-surface
1059                    :width (surface-width surface)
1060                    :height (surface-height surface)
1061                    :format :argb32)))
1062        (with-surface (image cr)
1063          (set-source-surface cr surface)
1064          (setf (operator cr) :source)
1065          (paint cr))
1066        image))))
1067
1068 (defbinding %surface-write-to-jpeg () status-signal
1069   (surface image-surface)
1070   (filename pathname)
1071   (param jpeg-parameter))
1072
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)))
1078
1079 (defbinding %surface-write-to-jpeg-stream (surface stream param) status-signal
1080   (surface surface)
1081   (jpeg-stream-write-func callback)
1082   (stream pointer-data)
1083   (param jpeg-parameter))
1084
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)))
1090     (unwind-protect
1091          (%surface-write-to-jpeg-stream (%surface-acquire-image surface) stream-id param)
1092       (destroy-user-data stream-id))))
1093
1094
1095 ;;; Virtual size surface (abstract class)
1096
1097 (defmethod initialize-instance :after ((surface vector-surface) &key
1098                                        width height)
1099   (setf (user-data surface 'width) width)
1100   (setf (user-data surface 'height) height))
1101
1102 (defmethod surface-width ((surface vector-surface))
1103   (user-data surface 'width))
1104
1105 (defmethod surface-height ((surface vector-surface))
1106   (user-data surface 'height))
1107
1108
1109 (defun allocate-vector-surface (surface-create surface-create-for-stream
1110                                 &key output filename stream width height)
1111   (let ((location
1112          (cond
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))
1118            (t
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)
1123               location)))))
1124     location))
1125
1126
1127 ;;; PDF Surface
1128
1129 (defmethod allocate-foreign ((surface pdf-surface) &rest args)
1130   (apply #'allocate-vector-surface
1131    #'%pdf-surface-create #'%pdf-surface-create-for-stream args))
1132
1133 (defbinding %pdf-surface-create () pointer
1134   (filename pathname)
1135   (width double-float)
1136   (height double-float))
1137
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))
1143
1144 (defbinding pdf-surface-set-size () nil
1145   (surface pdf-surface)
1146   (width double-float)
1147   (height double-float))
1148
1149
1150 ;;; PS Surface
1151
1152 (defmethod allocate-foreign ((surface ps-surface) &rest args)
1153   (apply #'allocate-vector-surface
1154    #'%ps-surface-create #'%ps-surface-create-for-stream args))
1155
1156 (defbinding %ps-surface-create () pointer
1157   (filename pathname)
1158   (width double-float)
1159   (height double-float))
1160
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))
1166
1167 (defbinding ps-surface-set-size () nil
1168   (surface ps-surface)
1169   (width double-float)
1170   (height double-float))
1171
1172 (defbinding ps-surface-dsc-begin-setup () nil
1173   (surface ps-surface))
1174
1175 (defbinding ps-surface-dsc-begin-page-setup () nil
1176   (surface ps-surface))
1177
1178 (defbinding ps-surface-dsc-comment () nil
1179   (surface ps-surface)
1180   (comment string))
1181
1182
1183 ;;; SVG Surface
1184
1185 (defmethod allocate-foreign ((surface svg-surface) &rest args)
1186   (apply #'allocate-vector-surface
1187    #'%svg-surface-create #'%svg-surface-create-for-stream args))
1188
1189 (defbinding %svg-surface-create () pointer
1190   (filename pathname)
1191   (width double-float)
1192   (height double-float))
1193
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))
1199
1200 (defbinding svg-surface-restrict-to-version () nil
1201   (surface svg-surface)
1202   (version svg-version))
1203
1204
1205
1206 ;;; Matrices
1207
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))
1213
1214 (defbinding matrix-init-identity (&optional (matrix (make-instance 'matrix))) nil
1215   (matrix matrix :in/return))
1216
1217 (defun identity-matrix-p (matrix)
1218   (with-slots (xx yx xy yy x0 y0) matrix
1219     (and
1220      (= xx 1.0d0) (= yx 0.0d0) (= xy 0.0d0)
1221      (= yy 1.0d0) (= x0 0.0d0) (= y0 0.0d0))))
1222
1223 (defbinding matrix-init-translate (tx ty &optional (matrix (make-instance 'matrix))) nil
1224   (matrix matrix :in/return)
1225   (tx double-float)
1226   (ty double-float))
1227
1228 (defbinding matrix-init-scale (sx &optional (sy sx) (matrix (make-instance 'matrix))) nil
1229   (matrix matrix :in/return)
1230   (sx double-float)
1231   (sy double-float))
1232
1233 (defbinding matrix-init-rotate (rotation &optional (matrix (make-instance 'matrix))) nil
1234   (matrix matrix :in/return)
1235   (rotation double-float))
1236
1237 (defbinding matrix-translate () nil
1238   (matrix matrix :in/return)
1239   (tx double-float)
1240   (ty double-float))
1241
1242 (defbinding matrix-scale (matrix sx &optional (sy sx)) nil
1243   (matrix matrix :in/return)
1244   (sx double-float)
1245   (sy double-float))
1246
1247 (defbinding matrix-rotate () nil
1248   (matrix matrix :in/return)
1249   (rotation double-float))
1250
1251 (defbinding matrix-invert () nil
1252   (matrix matrix :in/return))
1253
1254 (defbinding matrix-multiply () nil
1255   (result matrix :out)
1256   (a matrix)
1257   (b matrix))
1258
1259 (defbinding matrix-transform-distance (matrix dx &optional (dy dx)) nil
1260   (matrix matrix)
1261   (dx double-float :in/out)
1262   (dy double-float :in/out))
1263
1264 (defbinding matrix-transform-point () nil
1265   (matrix matrix)
1266   (x double-float :in/out)
1267   (y double-float :in/out))
1268
1269
1270 ;; Version information
1271
1272 (defbinding %version () int)
1273
1274 (defun version ()
1275   (let ((version (%version)))
1276     (values
1277      (mod (truncate version 10000) 100)
1278      (mod (truncate version 100) 100)
1279      (mod version 100))))
1280
1281 (defbinding version-string () (static string))