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