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.20 2008/01/10 13:31:39 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 pdf-surface (surface)
 234     ()
 235     (:metaclass surface-class))
 236
 237   (defclass ps-surface (surface)
 238     ()
 239     (:metaclass surface-class))
 240
 241   (defclass svg-surface (surface)
 242     ()
 243     (:metaclass surface-class))
 244
 245
 246   (defclass context (ref-counted-object)
 247     ((target
 248       :allocation :virtual
 249       :getter "cairo_get_target"
 250       :reader target
 251       :type surface)
 252      (source
 253       :allocation :virtual
 254       :getter "cairo_get_source"
 255       :setter "cairo_set_source"
 256       :accessor source
 257       :type pattern)
 258      (antialias
 259       :allocation :virtual
 260       :getter "cairo_get_antialias"
 261       :setter "cairo_set_antialias"
 262       :accessor antialias
 263       :type antialias)
 264      (tolerance
 265       :allocation :virtual
 266       :getter "cairo_get_tolerance"
 267       :setter "cairo_set_tolerance"
 268       :accessor tolerance
 269       :type double-float)
 270      (fill-rule
 271       :allocation :virtual
 272       :getter "cairo_get_fill_rule"
 273       :setter "cairo_set_fill_rule"
 274       :accessor fill-rule
 275       :type fill-rule)
 276      (line-width
 277       :allocation :virtual
 278       :getter "cairo_get_line_width"
 279       :setter "cairo_set_line_width"
 280       :accessor line-width
 281       :type double-float)
 282      (line-cap
 283       :allocation :virtual
 284       :getter "cairo_get_line_cap"
 285       :setter "cairo_set_line_cap"
 286       :accessor line-cap
 287       :type line-cap)
 288      (line-join
 289       :allocation :virtual
 290       :getter "cairo_get_line_join"
 291       :setter "cairo_set_line_join"
 292       :accessor line-join
 293       :type line-join)
 294      (miter-limit
 295       :allocation :virtual
 296       :getter "cairo_get_miter_limit"
 297       :setter "cairo_set_miter_limit"
 298       :accessor miter-limit
 299       :type double-float)
 300      (font-matrix
 301       :allocation :virtual
 302       :getter font-matrix
 303       :setter "cairo_set_font_matrix"
 304       :writer (setf font-matrix)
 305       :type matrix)
 306      (font-options
 307       :allocation :virtual
 308       :getter font-options
 309       :setter "cairo_set_font_options"
 310       :writer (setf font-options)
 311       :type font-options)
 312      (font-face
 313       :allocation :virtual
 314       :getter "cairo_get_font_face"
 315       :setter "cairo_set_font_face"
 316       :accessor font-face
 317       :type font-face)
 318      #?(pkg-exists-p "cairo" :atleast-version "1.4")
 319      (scaled-font
 320       :allocation :virtual
 321       :getter "cairo_get_scaled_font"
 322       :setter "cairo_set_scaled_font"
 323       :accessor scaled-font
 324       :type scaled-font)
 325      (operator
 326       :allocation :virtual
 327       :getter "cairo_get_operator"
 328       :setter "cairo_set_operator"
 329       :accessor operator
 330       :type operator)
 331      (matrix
 332       :allocation :virtual
 333       :getter matrix
 334       :setter "cairo_set_matrix"
 335       :writer (setf matrix)
 336       :type matrix)
 337      )
 338     (:metaclass proxy-class)
 339     (:ref %reference)
 340     (:unref %destroy))
 341
 342
 343    (defclass path (struct)
 344      ((status :allocation :alien :type status)
 345       (data :allocation :alien :type pointer)
 346       (length :allocation :alien :type int))
 347      (:metaclass proxy-class)
 348      (:unref %path-destroy)))
 349
 350
 351 ;;; Cairo context
 352
 353 (defmethod allocate-foreign ((context context) &key target)
 354   (%create-context target))
 355
 356 (defbinding (%create-context "cairo_create") () pointer
 357   (target surface))
 358
 359 (defbinding %reference () pointer
 360   (location pointer))
 361
 362 (defbinding %destroy () nil
 363   (location pointer))
 364
 365 (defbinding (save-context "cairo_save") () nil
 366   (cr context))
 367
 368 (defbinding (restore-context "cairo_restore") () nil
 369   (cr context))
 370
 371 (defmacro with-context ((cr &optional var) &body body)
 372   (let ((context (or var (make-symbol "CONTEXT"))))
 373     `(let ((,context ,cr))
 374        (save-context ,context)
 375        (unwind-protect
 376            (progn ,@body)
 377          (restore-context ,context)))))
 378
 379 (defbinding status () status
 380   (cr context))
 381
 382 (defun ensure-color-component (component)
 383   (etypecase component
 384     (float component)
 385     (integer (/ component 256.0))))
 386
 387 (defbinding (set-source-color "cairo_set_source_rgba") (cr red green blue &optional (alpha 1.0)) nil
 388   (cr context)
 389   ((ensure-color-component red) double-float)
 390   ((ensure-color-component green) double-float)
 391   ((ensure-color-component blue) double-float)
 392   ((ensure-color-component alpha) double-float))
 393
 394 (defbinding set-source-surface (cr surface &optional (x 0.0) (y 0.0)) nil
 395   (cr context)
 396   (surface surface)
 397   (x double-float)
 398   (y double-float))
 399
 400 (defun set-source (cr source)
 401   (etypecase source
 402     (pattern (setf (source cr) source))
 403     (surface (set-source-surface cr source))
 404     (null (set-source-color cr 0.0 0.0 0.0))
 405     (list (apply #'set-source-color cr source))
 406     (vector (apply #'set-source-color cr (coerce source 'list)))))
 407
 408 (defbinding set-dash (cr dashes &optional (offset 0.0)) nil
 409   (cr context)
 410   (dashes (vector double-float))
 411   ((length dashes) int)
 412   (offset double-float))
 413
 414 (defbinding (paint "cairo_paint_with_alpha") (cr &optional (alpha 1.0)) nil
 415   (cr context)
 416   (alpha double-float))
 417
 418 (defbinding mask () nil
 419   (cr context)
 420   (pattern pattern))
 421
 422 (defbinding mask-surface () nil
 423   (cr context)
 424   (surface surface)
 425   (surface-x double-float)
 426   (surface-y double-float))
 427
 428 (defmacro defoperator (name &optional clip-p)
 429   (let ((iname (intern (format nil "%~A" name)))
 430         (pname (intern (format nil "%~A-PRESERVE" name))))
 431     `(progn
 432        (defbinding ,iname () nil
 433          (cr context))
 434        (defbinding ,pname () nil
 435          (cr context))
 436        (defun ,name (cr &optional preserve)
 437          (if preserve
 438              (,pname cr)
 439            (,iname cr)))
 440        ,(unless clip-p
 441           (let ((tname (intern (format nil "IN-~A-P" name)))
 442                 (ename (intern (format nil "~A-EXTENTS" name))))
 443             `(progn
 444                (defbinding ,tname () boolean
 445                  (cr context)
 446                  (x double-float)
 447                  (y double-float))
 448                (defbinding ,ename () nil
 449                  (cr context)
 450                  (x1 double-float :out)
 451                  (y1 double-float :out)
 452                  (x2 double-float :out)
 453                  (y2 double-float :out))))))))
 454
 455 (defoperator clip t)
 456 (defoperator stroke)
 457 (defoperator fill)
 458
 459 (defbinding reset-clip () nil
 460   (cr context))
 461
 462 (defbinding copy-page () nil
 463   (cr context))
 464
 465 (defbinding show-page () nil
 466   (cr context))
 467
 468
 469 ;;; Paths
 470
 471 (defbinding %path-destroy () nil
 472   (location pointer))
 473
 474 (defbinding copy-path () path
 475   (cr context))
 476
 477 (defbinding copy-path-flat () path
 478   (cr context))
 479
 480 (defbinding append-path () nil
 481   (cr context)
 482   (path path))
 483
 484 (defbinding get-current-point () nil
 485   (cr context)
 486   (x double-float :out)
 487   (y double-float :out))
 488
 489 (defbinding new-path () nil
 490   (cr context))
 491
 492 #?(pkg-exists-p "cairo" :atleast-version "1.2")
 493 (defbinding new-sub-path () nil
 494   (cr context))
 495
 496 (defbinding close-path () nil
 497   (cr context))
 498
 499 (defmacro defpath (name args &optional relative-p)
 500   (flet ((def (name type)
 501            `(progn
 502               ,(when (eq type 'optimized-double-float)
 503                  `(declaim (inline ,(first name))))
 504               (defbinding ,name () nil
 505                 (cr context)
 506                 ,@(mapcar #'(lambda (arg) (list arg type)) args)))))
 507
 508   `(progn
 509      ,(def name 'double-float)
 510      ,(let ((name (intern (format nil "FAST-~A" name)))
 511             (cname (gffi::default-alien-fname name)))
 512         (def (list name cname) 'optimized-double-float))
 513      ,@(when relative-p
 514          (let* ((rel-name (intern (format nil "REL-~A" name)))
 515                 (fast-rel-name (intern (format nil "FAST-REL-~A" name)))
 516                 (cname (gffi::default-alien-fname rel-name)))
 517            (list
 518             (def rel-name 'double-float)
 519             (def (list fast-rel-name cname) 'optimized-double-float)))))))
 520
 521
 522 (defpath arc (xc yc radius angle1 angle2))
 523 (defpath arc-negative (xc yc radius angle1 angle2))
 524 (defpath curve-to (x1 y1 x2 y2 x3 y3) t)
 525 (defpath line-to (x y) t)
 526 (defpath move-to (x y) t)
 527 (defpath rectangle (x y width height))
 528
 529 (defun circle (cr x y radius &optional negative-p)
 530   (move-to cr radius 0.0d0)
 531   (if negative-p
 532       (arc-negative cr x y radius (* pi 2) 0.0d0)
 533     (arc cr x y radius 0.0d0 (* pi 2)))
 534   (close-path cr))
 535
 536
 537 (defbinding glyph-path (cr glyphs) nil
 538   (cr context)
 539   (glyphs (vector glyph))
 540   ((length glyphs) int))
 541
 542 (defbinding text-path () nil
 543   (cr context)
 544   (text string))
 545
 546
 547
 548 ;;; Patterns
 549
 550 (defbinding (pattern-add-color-stop "cairo_pattern_add_color_stop_rgba")
 551     (pattern offset red green blue &optional (alpha 1.0)) nil
 552   (pattern pattern)
 553   (offset double-float)
 554   ((ensure-color-component red) double-float)
 555   ((ensure-color-component green) double-float)
 556   ((ensure-color-component blue) double-float)
 557   ((ensure-color-component alpha) double-float))
 558
 559 (defbinding (pattern-create "cairo_pattern_create_rgba")
 560     (red green blue &optional (alpha 1.0)) pattern
 561   ((ensure-color-component red) double-float)
 562   ((ensure-color-component green) double-float)
 563   ((ensure-color-component blue) double-float)
 564   ((ensure-color-component alpha) double-float))
 565
 566 (defbinding pattern-create-for-surface () pattern
 567   (surface surface))
 568
 569 (defbinding pattern-create-linear () pattern
 570   (x0 double-float)
 571   (y0 double-float)
 572   (x1 double-float)
 573   (y1 double-float))
 574
 575 (defbinding pattern-create-radial () pattern
 576   (cx0 double-float)
 577   (cy0 double-float)
 578   (radius0 double-float)
 579   (cx1 double-float)
 580   (cy1 double-float)
 581   (radius1 double-float))
 582
 583 (defbinding %pattern-reference () pointer
 584   (location pointer))
 585
 586 (defbinding %pattern-destroy () nil
 587   (location pointer))
 588
 589 (defbinding pattern-status () status
 590   (pattern pattern))
 591
 592
 593
 594 ;;; Transformations
 595
 596 (defbinding translate () nil
 597   (cr context)
 598   (tx double-float)
 599   (ty double-float))
 600
 601 (defbinding scale (cr sx &optional (sy sx)) nil
 602   (cr context)
 603   (sx double-float)
 604   (sy double-float))
 605
 606 (defun scale-to-device (cr &optional keep-rotation-p)
 607   (if keep-rotation-p
 608       (multiple-value-bind (dx dy) (device-to-user-distance cr 1.0 0.0)
 609         (scale cr (sqrt (+ (* dx dx) (* dy dy)))))
 610     (multiple-value-bind (x y)
 611         (with-context (cr)
 612           (move-to cr 0.0 0.0)
 613           (multiple-value-call #'user-to-device cr (get-current-point cr)))
 614       (identity-matrix cr)
 615       (translate cr x y))))
 616
 617 (defbinding rotate () nil
 618   (cr context)
 619   (angle double-float))
 620
 621 (defbinding transform () nil
 622   (cr context)
 623   (matrix matrix))
 624
 625 (defbinding (matrix "cairo_get_matrix") () nil
 626   (cr context)
 627   ((make-instance 'matrix) matrix :in/return))
 628
 629 (defbinding identity-matrix () nil
 630   (cr context))
 631
 632 (defbinding user-to-device () nil
 633   (cr context)
 634   (x double-float :in/out)
 635   (y double-float :in/out))
 636
 637 (defbinding user-to-device-distance (cr dx &optional (dy dx)) nil
 638   (cr context)
 639   (dx double-float :in/out)
 640   (dy double-float :in/out))
 641
 642 (defbinding device-to-user () nil
 643   (cr context)
 644   (x double-float :in/out)
 645   (y double-float :in/out))
 646
 647 (defbinding device-to-user-distance (cr dx &optional (dy dx)) nil
 648   (cr context)
 649   (dx double-float :in/out)
 650   (dy double-float :in/out))
 651
 652
 653 ;;; Text
 654
 655 (defbinding select-font-face () nil
 656   (cr context)
 657   (family string)
 658   (slant font-slant)
 659   (weight font-weight))
 660
 661 (defbinding set-font-size () nil
 662   (cr context)
 663   (size double-float))
 664
 665 (defbinding (font-matrix "cairo_get_font_matrix") () nil
 666   (cr context)
 667   ((make-instance 'matrix) matrix :in/return))
 668
 669 (defbinding (font-options "cairo_get_font_options") () nil
 670   (cr context)
 671   ((make-instance 'font-options) font-options :in/return))
 672
 673 (defbinding show-text () nil
 674   (cr context)
 675   (text string))
 676
 677 (defbinding show-glyphs () nil
 678   (cr context)
 679   (glyphs (vector (inlined glyph)))
 680   ((length glyphs) int))
 681
 682 (defbinding font-extents (cr &optional (extents (make-instance 'font-extents))) nil
 683   (cr context)
 684   (extents font-extents :in/return))
 685
 686 (defbinding text-extents (cr text &optional (extents (make-instance 'text-extents))) nil
 687   (cr context)
 688   (text string)
 689   (extents text-extents :in/return))
 690
 691 (defbinding glyph-extents (cr glyphs &optional (extents (make-instance 'text-extents))) nil
 692   (cr context)
 693   (glyphs (vector glyph))
 694   ((length glyphs) int)
 695   (extents text-extents :in/return))
 696
 697
 698 ;;; Fonts
 699
 700 (defbinding %font-face-reference () pointer
 701   (location pointer))
 702
 703 (defbinding %font-face-destroy () nil
 704   (location pointer))
 705
 706 (defbinding font-face-status () status
 707   (font-face font-face))
 708
 709
 710
 711 ;;; Scaled Fonts
 712
 713 (defbinding %scaled-font-reference () pointer
 714   (location pointer))
 715
 716 (defbinding %scaled-font-destroy () nil
 717   (location pointer))
 718
 719 (defbinding scaled-font-status () status
 720   (scaled-font scaled-font))
 721
 722 (defbinding scaled-font-extents (scaled-font &optional (extents (make-instance 'text-extents))) nil
 723   (scaled-font scaled-font)
 724   (extents text-extents :in/return))
 725
 726 (defbinding scaled-font-glyph-extents (scaled-font glyphs &optional (extents (make-instance 'text-extents))) nil
 727   (scaled-font scaled-font)
 728   (glyphs (vector glyph))
 729   ((length glyphs) int)
 730   (extents text-extents :in/return))
 731
 732 (defbinding %scaled-font-create () pointer
 733   (font-face font-face)
 734   (font-matrix matrix)
 735   (ctm matrix)
 736   (options font-options))
 737
 738 (defmethod allocate-foreign ((scaled-font scaled-font) &key font-face font-matrix cmt options)
 739   (%scaled-font-create font-face font-matrix cmt options))
 740
 741
 742
 743 ;;; Font Options
 744
 745
 746 (defbinding %font-options-copy () nil
 747   (location pointer))
 748
 749 (defbinding %font-options-destroy () nil
 750   (location pointer))
 751
 752 (defbinding font-options-status () status
 753   (font-options font-options))
 754
 755 (defbinding %font-options-create () pointer)
 756
 757 (defmethod allocate-foreign ((font-options font-options) &rest initargs)
 758   (declare (ignore initargs))
 759   (%font-options-create))
 760
 761 (defbinding font-options-merge () nil
 762   (options1 font-options :in/return)
 763   (options2 font-options))
 764
 765 (defbinding font-options-hash () unsigned-int
 766   (options font-options))
 767
 768 (defbinding font-options-equal-p () boolean
 769   (options1 font-options)
 770   (options2 font-options))
 771
 772
 773
 774 ;;; Surfaces
 775
 776 (defmethod make-proxy-instance :around ((class surface-class) location
 777                                         &rest initargs)
 778   (let ((class (find-class (%surface-get-type location))))
 779     (apply #'call-next-method class location initargs)))
 780
 781 (defbinding %surface-get-type () surface-type
 782   (location pointer))
 783
 784 (defbinding %surface-reference () pointer
 785   (location pointer))
 786
 787 (defbinding %surface-destroy () nil
 788   (location pointer))
 789
 790 (defmethod reference-function ((class surface-class))
 791   (declare (ignore class))
 792   #'%surface-reference)
 793
 794 (defmethod unreference-function ((class surface-class))
 795   (declare (ignore class))
 796   #'%surface-destroy)
 797
 798 (defbinding %surface-set-user-data (surface key data-id) status
 799   (surface pointer)
 800   ((quark-intern key) pointer-data)
 801   (data-id pointer-data)
 802   (user-data-destroy-callback callback))
 803
 804 (defmethod (setf user-data) (data (surface surface) key)
 805   (%surface-set-user-data (foreign-location surface) key (register-user-data data))
 806   data)
 807
 808 (defbinding %surface-get-user-data () pointer-data
 809   (surface surface)
 810   (key pointer-data))
 811
 812 (defmethod user-data ((surface surface) key)
 813   (find-user-data (%surface-get-user-data surface (quark-intern key))))
 814
 815 (defbinding surface-create-similar () surface
 816   (other surface)
 817   (format surface-format )
 818   (width int)
 819   (height int))
 820
 821 (defbinding surface-finish () nil
 822   (surface surface))
 823
 824 (defbinding surface-flush () nil
 825   (surface surface))
 826
 827 (defbinding surface-get-font-options () nil
 828   (surface surface)
 829   ((make-instance 'font-options) font-options :in/return))
 830
 831 (defbinding surface-set-device-offset () nil
 832   (surface surface)
 833   (x-offset double-float)
 834   (y-offset double-float))
 835
 836 (defbinding surface-status () status
 837   (surface surface))
 838
 839 (defbinding %surface-mark-dirty () nil
 840   (surface surface))
 841
 842 (defbinding %surface-mark-dirty-rectangle () nil
 843   (surface surface)
 844   (x int)
 845   (y int)
 846   (width int)
 847   (height int))
 848
 849 (defun surface-mark-dirty (surface &optional x y width height)
 850   (if x
 851       (%surface-mark-dirty-rectangle surface x y width height)
 852     (%surface-mark-dirty surface)))
 853
 854 (defbinding surface-set-fallback-resolution () nil
 855   (surface surface)
 856   (x-pixels-per-inch double-float)
 857   (y-pixels-per-inch double-float))
 858
 859 (define-callback stream-write-func status
 860     ((stream-id pointer-data) (data pointer) (length unsigned-int))
 861   (let ((stream (find-user-data stream-id)))
 862     (typecase stream
 863       (stream
 864        (map-c-vector 'nil #'(lambda (octet) (write-byte octet stream))
 865         data '(unsigned-byte 8) length))
 866       ((or symbol function)
 867        (funcall stream
 868         (map-c-vector 'vector #'identity data '(unsigned-byte 8) length)))))
 869   :success)
 870
 871
 872 (defmacro with-surface ((surface cr) &body body)
 873   `(let ((,cr (make-instance 'context :target ,surface)))
 874      ,@body))
 875
 876
 877 ;; Image Surface
 878
 879 ;; Should data be automatically freed when the surface is GCed?
 880 (defmethod allocate-foreign ((surface image-surface)
 881                              &key filename width height stride format data)
 882   (cond
 883    (filename (%image-surface-create-from-png filename))
 884    ((not data) (%image-surface-create format width height))
 885    (t
 886     (%image-surface-create-for-data data format width height
 887      (or
 888       stride
 889       (let ((element-size (cdr (assoc format '((:argb32 . 4) (:rgb24 . 4) (:a8 . 1) (:a1 1/8))))))
 890         (ceiling (* width element-size))))))))
 891
 892
 893 (defbinding %image-surface-create () pointer
 894   (format surface-format)
 895   (width int)
 896   (hegit int))
 897
 898 (defbinding %image-surface-create-for-data () pointer
 899   (data pointer)
 900   (format surface-format)
 901   (width int)
 902   (hegit int)
 903   (stride int))
 904
 905 (defbinding %image-surface-create-from-png () pointer
 906   (filename pathname))
 907
 908 (defbinding surface-write-to-png () status
 909   (surface surface)
 910   (filename pathname))
 911
 912
 913 ;;; PDF Surface
 914
 915 (defmethod allocate-foreign ((surface pdf-surface)
 916                              &key filename stream width height)
 917   (cond
 918    ((and filename stream)
 919     (error "Only one of the arguments :filename and :stream may be specified"))
 920    (filename (%pdf-surface-create filename width height))
 921    (stream
 922     (let* ((stream-id (register-user-data stream))
 923            (location (%pdf-surface-create-for-stream stream-id width height)))
 924       (%surface-set-user-data location 'stream stream-id)
 925       location))))
 926
 927
 928 (defbinding %pdf-surface-create () pointer
 929   (filename pathname)
 930   (width double-float)
 931   (height double-float))
 932
 933 (defbinding %pdf-surface-create-for-stream (stream width height) pointer
 934   (stream-write-func callback)
 935   (stream pointer-data)
 936   (width double-float)
 937   (height double-float))
 938
 939 (defbinding pdf-surface-set-size () nil
 940   (surface pdf-surface)
 941   (width double-float)
 942   (height double-float))
 943
 944
 945 ;;; PS Surface
 946
 947 (defmethod allocate-foreign ((surface ps-surface)
 948                              &key filename stream width height)
 949   (cond
 950    ((and filename stream)
 951     (error "Only one of the arguments :filename and :stream may be specified"))
 952    (filename (%ps-surface-create filename width height))
 953    (stream
 954     (let* ((stream-id (register-user-data stream))
 955            (location (%ps-surface-create-for-stream stream-id width height)))
 956       (%surface-set-user-data location 'stream stream-id)
 957       location))))
 958
 959 (defbinding %ps-surface-create () pointer
 960   (filename pathname)
 961   (width double-float)
 962   (height double-float))
 963
 964 (defbinding %ps-surface-create-for-stream (stream width height) pointer
 965   (stream-write-func callback)
 966   (stream pointer-data)
 967   (width double-float)
 968   (height double-float))
 969
 970 (defbinding ps-surface-set-size () nil
 971   (surface ps-surface)
 972   (width double-float)
 973   (height double-float))
 974
 975 (defbinding ps-surface-dsc-begin-setup () nil
 976   (surface ps-surface))
 977
 978 (defbinding ps-surface-dsc-begin-page-setup () nil
 979   (surface ps-surface))
 980
 981 (defbinding ps-surface-dsc-comment () nil
 982   (surface ps-surface)
 983   (comment string))
 984
 985
 986 ;;; SVG Surface
 987
 988 (defmethod allocate-foreign ((surface svg-surface)
 989                              &key filename stream width height)
 990   (cond
 991    ((and filename stream)
 992     (error "Only one of the arguments :filename and :stream may be specified"))
 993    (filename (%svg-surface-create filename width height))
 994    (stream
 995     (let* ((stream-id (register-user-data stream))
 996            (location (%svg-surface-create-for-stream stream-id width height)))
 997       (%surface-set-user-data location 'stream stream-id)
 998       location))))
 999
1000 (defbinding %svg-surface-create () pointer
1001   (filename pathname)
1002   (width double-float)
1003   (height double-float))
1004
1005 (defbinding %svg-surface-create-for-stream (stream width height) pointer
1006   (stream-write-func callback)
1007   (stream pointer-data)
1008   (width double-float)
1009   (height double-float))
1010
1011 (defbinding svg-surface-restrict-to-version () nil
1012   (surface svg-surface)
1013   (version svg-version))
1014
1015
1016
1017 ;;; Matrices
1018
1019 (defbinding matrix-init () nil
1020   (matrix matrix :in/return)
1021   (xx double-float) (yx double-float)
1022   (xy double-float) (yy double-float)
1023   (x0 double-float) (y0 double-float))
1024
1025 (defbinding matrix-init-identity (&optional (matrix (make-instance 'matrix))) nil
1026   (matrix matrix :in/return))
1027
1028 (defun identity-matrix-p (matrix)
1029   (with-slots (xx yx xy yy x0 y0) matrix
1030     (and
1031      (= xx 1.0d0) (= yx 0.0d0) (= xy 0.0d0)
1032      (= yy 1.0d0) (= x0 0.0d0) (= y0 0.0d0))))
1033
1034 (defbinding matrix-init-translate () nil
1035   (matrix matrix :in/return)
1036   (tx double-float)
1037   (ty double-float))
1038
1039 (defbinding matrix-init-scale (matrix sx &optional (sy sx)) nil
1040   (matrix matrix :in/return)
1041   (sx double-float)
1042   (sy double-float))
1043
1044 (defbinding matrix-init-rotate () nil
1045   (matrix matrix :in/return)
1046   (radians double-float))
1047
1048 (defbinding matrix-translate () nil
1049   (matrix matrix :in/return)
1050   (tx double-float)
1051   (ty double-float))
1052
1053 (defbinding matrix-scale (matrix sx &optional (sy sx)) nil
1054   (matrix matrix :in/return)
1055   (sx double-float)
1056   (sy double-float))
1057
1058 (defbinding matrix-rotate () nil
1059   (matrix matrix :in/return)
1060   (radians double-float))
1061
1062 (defbinding matrix-invert () nil
1063   (matrix matrix :in/return))
1064
1065 (defbinding matrix-multiply () nil
1066   (result matrix :out)
1067   (a matrix)
1068   (b matrix))
1069
1070 (defbinding matrix-transform-distance (matrix dx &optional (dy dx)) nil
1071   (matrix matrix)
1072   (dx double-float :in/out)
1073   (dy double-float :in/out))
1074
1075 (defbinding matrix-transform-point () nil
1076   (matrix matrix)
1077   (x double-float :in/out)
1078   (y double-float :in/out))