;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: cairo.lisp,v 1.2 2005-11-15 10:03:04 espen Exp $
+;; $Id: cairo.lisp,v 1.25 2009-02-09 11:45:03 espen Exp $
(in-package "CAIRO")
(eval-when (:compile-toplevel :load-toplevel :execute)
(define-enum-type surface-format :argb32 :rgb24 :a8 :a1)
+ (define-enum-type content :color :alpha :color-alpha)
+ (define-enum-type svg-version :svg-1.1 :svg-1.2)
(define-enum-type status
:success :no-memory :invalid-restore :invalid-pop-group
(define-enum-type fill-rule :winding :even-odd)
(define-enum-type line-cap :butt :round :square)
(define-enum-type line-join :miter :round :bevel)
- (define-enum-type font-slant :normal :itaic :oblique)
+ (define-enum-type font-slant :normal :italic :oblique)
(define-enum-type font-weight :normal :bold)
(define-enum-type operator
(define-enum-type hint-style :default :none :slight :medium :full)
(define-enum-type hint-metrics :default :off :on)
- (defclass glyph (proxy)
+
+ (define-enum-type surface-type
+ image-surface pdf-surface ps-surface xlib-surface xcb-surface
+ glitz-surface quartz-surface win32-surface beos-surface
+ directfb-surface svg-surface os2-surface)
+
+ (defclass surface-class (proxy-class)
+ ())
+
+ (defmethod validate-superclass ((class surface-class) (super standard-class))
+ (subtypep (class-name super) 'surface))
+
+ (defclass glyph (struct)
((index
:allocation :alien
:initarg :index
:type double-float))
(:metaclass struct-class))
- (defclass font-face (proxy)
+ (defclass font-face (ref-counted-object)
()
- (:metaclass proxy-class))
+ (:metaclass proxy-class)
+ (:ref %font-face-reference)
+ (:unref %font-face-destroy))
- (defclass font-options (proxy)
+ (defclass font-options (ref-counted-object)
((antialias
:allocation :virtual
:getter "font_options_get_antialias"
:setter "font_options_set_hint_metrics"
:accessor font-options-hint-metrics
:type hint-metrics))
- (:metaclass proxy-class))
+ (:metaclass proxy-class)
+ (:ref %font-options-reference)
+ (:unref %font-options-destroy))
- (defclass scaled-font (proxy)
+ (defclass scaled-font (ref-counted-object)
()
- (:metaclass proxy-class))
+ (:metaclass proxy-class)
+ (:ref %scaled-font-reference)
+ (:unref %scaled-font-destroy))
(defclass matrix (struct)
((xx :allocation :alien :initarg :xx :initform 1.0
:accessor matrix-y0 :type double-float))
(:metaclass struct-class))
+ (defclass font-extents (struct)
+ ((ascent :allocation :alien :reader font-extents-ascent :type double-float)
+ (descent :allocation :alien :reader font-extents-descent :type double-float)
+ (height :allocation :alien :reader font-extents-height :type double-float)
+ (max-x-advance :allocation :alien :reader font-extents-max-x-advance :type double-float)
+ (max-y-advance :allocation :alien :reader font-extents-max-y-advance :type double-float))
+ (:metaclass struct-class))
(defclass text-extents (struct)
((x-bearing :allocation :alien :reader text-extents-x-bearing :type double-float)
(y-advance :allocation :alien :reader text-extents-y-advance :type double-float))
(:metaclass struct-class))
- (defclass pattern (proxy)
+ (defclass pattern (ref-counted-object)
((extend
:allocation :virtual
:getter "cairo_pattern_get_extend"
:setter "cairo_pattern_set_matrix"
:accessor pattern-matrix
:type matrix))
- (:metaclass proxy-class))
+ (:metaclass proxy-class)
+ (:ref %pattern-reference)
+ (:unref %pattern-destroy))
+
+
+ (defclass surface (ref-counted-object)
+ ((content
+ :allocation :virtual
+ :getter "cairo_surface_get_content"
+ :reader surface-content
+ :type content))
+ (:metaclass surface-class))
+
+ (defclass image-surface (surface)
+ ((data
+ :allocation :virtual
+ :getter "cairo_image_surface_get_data"
+ :reader surface-data
+ :type pointer)
+ (format
+ :allocation :virtual
+ :getter "cairo_image_surface_get_format"
+ :reader surface-format
+ :type surface-format)
+ (width
+ :allocation :virtual
+ :getter "cairo_image_surface_get_width"
+ :reader surface-width
+ :type int)
+ (height
+ :allocation :virtual
+ :getter "cairo_image_surface_get_height"
+ :reader surface-height
+ :type int)
+ (stride
+ :allocation :virtual
+ :getter "cairo_image_surface_get_stride"
+ :reader surface-stride
+ :type int))
+ (:metaclass surface-class))
+
+ (defclass xlib-surface (surface)
+ ((width
+ :allocation :virtual
+ :getter "cairo_xlib_surface_get_width"
+ :reader surface-width
+ :type int)
+ (height
+ :allocation :virtual
+ :getter "cairo_xlib_surface_get_height"
+ :reader surface-height
+ :type int))
+ (:metaclass surface-class))
+
+ (defclass vector-surface (surface)
+ ((width :allocation :virtual :getter surface-width)
+ (height :allocation :virtual :setter surface-height))
+ (:metaclass surface-class))
+
+ (defclass pdf-surface (vector-surface)
+ ()
+ (:metaclass surface-class))
+
+ (defclass ps-surface (vector-surface)
+ ()
+ (:metaclass surface-class))
+
+ (defclass svg-surface (vector-surface)
+ ()
+ (:metaclass surface-class))
+
- (defclass context (proxy)
+ (defclass context (ref-counted-object)
((target
:allocation :virtual
:getter "cairo_get_target"
:type double-float)
(font-matrix
:allocation :virtual
- :getter "cairo_get_font_matrix"
+ :getter font-matrix
:setter "cairo_set_font_matrix"
- :accessor font-matrix
+ :writer (setf font-matrix)
:type matrix)
(font-options
:allocation :virtual
- :getter "cairo_get_font_options"
+ :getter font-options
:setter "cairo_set_font_options"
- :accessor font-options
+ :writer (setf font-options)
:type font-options)
(font-face
:allocation :virtual
:setter "cairo_set_font_face"
:accessor font-face
:type font-face)
+ #?(pkg-exists-p "cairo" :atleast-version "1.4")
+ (scaled-font
+ :allocation :virtual
+ :getter "cairo_get_scaled_font"
+ :setter "cairo_set_scaled_font"
+ :accessor scaled-font
+ :type scaled-font)
(operator
:allocation :virtual
:getter "cairo_get_operator"
:writer (setf matrix)
:type matrix)
)
- (:metaclass proxy-class))
+ (:metaclass proxy-class)
+ (:ref %reference)
+ (:unref %destroy))
- (defclass surface (proxy)
- ()
- (:metaclass proxy-class))
- (defclass image-surface (surface)
- ((width
- :allocation :virtual
- :getter "cairo_image_surface_get_width"
- :reader surface-width
+ (defclass path (struct)
+ ((status :allocation :alien :type status)
+ (data :allocation :alien :type pointer)
+ (length :allocation :alien :type int))
+ (:metaclass proxy-class)
+ (:unref %path-destroy))
+
+ (defclass jpeg-parameter (struct)
+ ((quality
+ :allocation :alien
+ :initarg :quality
+ :initform 75
:type int)
- (height
- :allocation :virtual
- :getter "cairo_image_surface_get_height"
- :reader surface-height
- :type int))
- (:metaclass proxy-class))
+ (interlace
+ :allocation :alien
+ :initarg :interlace
+ :initform t
+ :type boolean))
+ (:metaclass struct-class)))
+
+
+(define-condition cairo-error (error)
+ ((status :initarg :status :reader cairo-status))
+ (:report (lambda (condition stream)
+ (format stream "Cairo function returned with status code: ~A"
+ (cairo-status condition)))))
-;; (defclass path (proxy)
-;; ()
-;; (:metaclass proxy-class))
+(deftype status-signal () 'status)
+
+(define-type-method from-alien-form ((type status-signal) status &key ref)
+ (declare (ignore type ref))
+ `(let ((status ,(from-alien-form 'status status)))
+ (unless (eq status :success)
+ (error 'cairo-error :status status))
+ status))
-)
;;; Cairo context
-(defbinding %reference () nil
+(defmethod allocate-foreign ((context context) &key target)
+ (%create-context target))
+
+(defbinding (%create-context "cairo_create") () pointer
+ (target surface))
+
+(defbinding %reference () pointer
(location pointer))
(defbinding %destroy () nil
(location pointer))
-(defmethod reference-foreign ((class (eql (find-class 'context))) location)
- (%reference location))
-
-(defmethod unreference-foreign ((class (eql (find-class 'context))) location)
- (%destroy location))
-
(defbinding (save-context "cairo_save") () nil
(cr context))
(defbinding (restore-context "cairo_restore") () nil
(cr context))
-(defmacro with-context ((cr) &body body)
- (let ((context (make-symbol "CONTEXT")))
+(defmacro with-context ((cr &optional var) &body body)
+ (let ((context (or var (make-symbol "CONTEXT"))))
`(let ((,context ,cr))
(save-context ,context)
(unwind-protect
(defbinding status () status
(cr context))
+(defun ensure-color-component (component)
+ (etypecase component
+ (float component)
+ (integer (/ component 256.0))))
+
(defbinding (set-source-color "cairo_set_source_rgba") (cr red green blue &optional (alpha 1.0)) nil
(cr context)
- (red double-float)
- (green double-float)
- (blue double-float)
- (alpha double-float))
+ ((ensure-color-component red) double-float)
+ ((ensure-color-component green) double-float)
+ ((ensure-color-component blue) double-float)
+ ((ensure-color-component alpha) double-float))
-(defbinding set-source-surface () nil
+(defbinding set-source-surface (cr surface &optional (x 0.0) (y 0.0)) nil
(cr context)
(surface surface)
(x double-float)
(y double-float))
+(defun set-source (cr source)
+ (etypecase source
+ (pattern (setf (source cr) source))
+ (surface (set-source-surface cr source))
+ (null (set-source-color cr 0.0 0.0 0.0))
+ (list (apply #'set-source-color cr source))
+ (vector (apply #'set-source-color cr (coerce source 'list)))))
+
(defbinding set-dash (cr dashes &optional (offset 0.0)) nil
(cr context)
(dashes (vector double-float))
(cr context)
(x double-float)
(y double-float))
- (defbinding ,ename () boolean
+ (defbinding ,ename () nil
(cr context)
(x1 double-float :out)
(y1 double-float :out)
;;; Paths
-(defbinding get-current-point () nil
- (cr context)
- (x double-float :out)
- (y double-float :out))
+(defbinding %path-destroy () nil
+ (location pointer))
-(defbinding new-path () nil
+(defbinding copy-path () path
(cr context))
-(defbinding close-path () nil
+(defbinding copy-path-flat () path
(cr context))
-(defbinding arc () nil
+(defbinding append-path () nil
(cr context)
- (xc double-float)
- (yc double-float)
- (radius double-float)
- (angle1 double-float)
- (angle2 double-float))
+ (path path))
-(defbinding arc-negative () nil
+(defbinding get-current-point () nil
(cr context)
- (xc double-float)
- (yc double-float)
- (radius double-float)
- (angle1 double-float)
- (angle2 double-float))
+ (x double-float :out)
+ (y double-float :out))
-(defun circle (cr x y radius)
- (arc cr x y radius 0.0 (* pi 2)))
+(defbinding new-path () nil
+ (cr context))
-(defmacro defpath (name &rest args)
- (let ((relname (intern (format nil "REL-~A" name))))
- `(progn
- (defbinding ,name () nil
- (cr context)
- ,@args)
- (defbinding ,relname () nil
- (cr context)
- ,@args))))
-
-(defpath curve-to
- (x1 double-float)
- (y1 double-float)
- (x2 double-float)
- (y2 double-float)
- (x3 double-float)
- (y3 double-float))
+#?(pkg-exists-p "cairo" :atleast-version "1.2")
+(defbinding new-sub-path () nil
+ (cr context))
-(defpath line-to
- (x double-float)
- (y double-float))
+(defbinding close-path () nil
+ (cr context))
-(defpath move-to
- (x double-float)
- (y double-float))
+(defmacro defpath (name args &optional relative-p)
+ (flet ((def (name type)
+ `(progn
+ ,(when (eq type 'optimized-double-float)
+ `(declaim (inline ,(first name))))
+ (defbinding ,name () nil
+ (cr context)
+ ,@(mapcar #'(lambda (arg) (list arg type)) args)))))
+
+ `(progn
+ ,(def name 'double-float)
+ ,(let ((name (intern (format nil "FAST-~A" name)))
+ (cname (gffi::default-alien-fname name)))
+ (def (list name cname) 'optimized-double-float))
+ ,@(when relative-p
+ (let* ((rel-name (intern (format nil "REL-~A" name)))
+ (fast-rel-name (intern (format nil "FAST-REL-~A" name)))
+ (cname (gffi::default-alien-fname rel-name)))
+ (list
+ (def rel-name 'double-float)
+ (def (list fast-rel-name cname) 'optimized-double-float)))))))
+
+
+(defpath arc (xc yc radius angle1 angle2))
+(defpath arc-negative (xc yc radius angle1 angle2))
+(defpath curve-to (x1 y1 x2 y2 x3 y3) t)
+(defpath line-to (x y) t)
+(defpath move-to (x y) t)
+(defpath rectangle (x y width height))
+
+(defun circle (cr x y radius &optional negative-p)
+ (move-to cr radius 0.0d0)
+ (if negative-p
+ (arc-negative cr x y radius (* pi 2) 0.0d0)
+ (arc cr x y radius 0.0d0 (* pi 2)))
+ (close-path cr))
-(defbinding rectangle () nil
- (cr context)
- (x double-float)
- (y double-float)
- (width double-float)
- (height double-float))
(defbinding glyph-path (cr glyphs) nil
(cr context)
(pattern offset red green blue &optional (alpha 1.0)) nil
(pattern pattern)
(offset double-float)
- (red double-float)
- (green double-float)
- (blue double-float)
- (alpha double-float))
+ ((ensure-color-component red) double-float)
+ ((ensure-color-component green) double-float)
+ ((ensure-color-component blue) double-float)
+ ((ensure-color-component alpha) double-float))
(defbinding (pattern-create "cairo_pattern_create_rgba")
(red green blue &optional (alpha 1.0)) pattern
- (red double-float)
- (green double-float)
- (blue double-float)
- (alpha double-float))
+ ((ensure-color-component red) double-float)
+ ((ensure-color-component green) double-float)
+ ((ensure-color-component blue) double-float)
+ ((ensure-color-component alpha) double-float))
(defbinding pattern-create-for-surface () pattern
(surface surface))
(cy1 double-float)
(radius1 double-float))
-(defbinding %pattern-reference () nil
+(defbinding %pattern-reference () pointer
(location pointer))
(defbinding %pattern-destroy () nil
(location pointer))
-(defmethod reference-foreign ((class (eql (find-class 'pattern))) location)
- (%pattern-reference location))
-
-(defmethod unreference-foreign ((class (eql (find-class 'pattern))) location)
- (%pattern-destroy location))
-
(defbinding pattern-status () status
(pattern pattern))
(tx double-float)
(ty double-float))
-(defbinding scale () nil
+(defbinding scale (cr sx &optional (sy sx)) nil
(cr context)
(sx double-float)
(sy double-float))
+(defun scale-to-device (cr &optional keep-rotation-p)
+ (if keep-rotation-p
+ (multiple-value-bind (dx dy) (device-to-user-distance cr 1.0 0.0)
+ (scale cr (sqrt (+ (* dx dx) (* dy dy)))))
+ (multiple-value-bind (x y)
+ (with-context (cr)
+ (move-to cr 0.0 0.0)
+ (multiple-value-call #'user-to-device cr (get-current-point cr)))
+ (identity-matrix cr)
+ (translate cr x y))))
+
(defbinding rotate () nil
(cr context)
(angle double-float))
(defbinding (matrix "cairo_get_matrix") () nil
(cr context)
- ((make-instance 'matrix) matrix :return))
+ ((make-instance 'matrix) matrix :in/return))
(defbinding identity-matrix () nil
(cr context))
(defbinding user-to-device () nil
(cr context)
- (x double-float :in-out)
- (y double-float :in-out))
+ (x double-float :in/out)
+ (y double-float :in/out))
-(defbinding user-to-device-distance () nil
+(defbinding user-to-device-distance (cr dx &optional (dy dx)) nil
(cr context)
- (dx double-float :in-out)
- (dy double-float :in-out))
+ (dx double-float :in/out)
+ (dy double-float :in/out))
(defbinding device-to-user () nil
(cr context)
- (x double-float :in-out)
- (y double-float :in-out))
+ (x double-float :in/out)
+ (y double-float :in/out))
-(defbinding device-to-user-distance () nil
+(defbinding device-to-user-distance (cr dx &optional (dy dx)) nil
(cr context)
- (dx double-float :in-out)
- (dy double-float :in-out))
+ (dx double-float :in/out)
+ (dy double-float :in/out))
;;; Text
(cr context)
(size double-float))
+(defbinding (font-matrix "cairo_get_font_matrix") () nil
+ (cr context)
+ ((make-instance 'matrix) matrix :in/return))
+
+(defbinding (font-options "cairo_get_font_options") () nil
+ (cr context)
+ ((make-instance 'font-options) font-options :in/return))
+
(defbinding show-text () nil
(cr context)
(text string))
(defbinding show-glyphs () nil
(cr context)
- (glyphs (vector glyph))
+ (glyphs (vector (inlined glyph)))
((length glyphs) int))
-(defbinding font-extents () boolean
- (cr context))
+(defbinding font-extents (cr &optional (extents (make-instance 'font-extents))) nil
+ (cr context)
+ (extents font-extents :in/return))
(defbinding text-extents (cr text &optional (extents (make-instance 'text-extents))) nil
(cr context)
(text string)
- (extents text-extents :return))
+ (extents text-extents :in/return))
(defbinding glyph-extents (cr glyphs &optional (extents (make-instance 'text-extents))) nil
(cr context)
(glyphs (vector glyph))
((length glyphs) int)
- (extents text-extents :return))
+ (extents text-extents :in/return))
;;; Fonts
-(defbinding %font-face-reference () nil
+(defbinding %font-face-reference () pointer
(location pointer))
(defbinding %font-face-destroy () nil
(location pointer))
-(defmethod reference-foreign ((class (eql (find-class 'font-face))) location)
- (%font-face-reference location))
-
-(defmethod unreference-foreign ((class (eql (find-class 'font-face))) location)
- (%font-face-destroy location))
-
(defbinding font-face-status () status
(font-face font-face))
;;; Scaled Fonts
-(defbinding %scaled-font-reference () nil
+(defbinding %scaled-font-reference () pointer
(location pointer))
(defbinding %scaled-font-destroy () nil
(location pointer))
-(defmethod reference-foreign ((class (eql (find-class 'scaled-font))) location)
- (%scaled-font-reference location))
-
-(defmethod unreference-foreign ((class (eql (find-class 'scaled-font))) location)
- (%scaled-font-destroy location))
-
(defbinding scaled-font-status () status
(scaled-font scaled-font))
(defbinding scaled-font-extents (scaled-font &optional (extents (make-instance 'text-extents))) nil
(scaled-font scaled-font)
- (extents text-extents :return))
+ (extents text-extents :in/return))
(defbinding scaled-font-glyph-extents (scaled-font glyphs &optional (extents (make-instance 'text-extents))) nil
(scaled-font scaled-font)
(glyphs (vector glyph))
((length glyphs) int)
- (extents text-extents :return))
+ (extents text-extents :in/return))
(defbinding %scaled-font-create () pointer
(font-face font-face)
(ctm matrix)
(options font-options))
-(defmethod initialize-instance ((scaled-font scaled-font) &key font-face font-matrix cmt options)
- (setf
- (slot-value scaled-font 'location)
- (%scaled-font-create font-face font-matrix cmt options))
- (call-next-method))
+(defmethod allocate-foreign ((scaled-font scaled-font) &key font-face font-matrix cmt options)
+ (%scaled-font-create font-face font-matrix cmt options))
(defbinding %font-options-destroy () nil
(location pointer))
-(defmethod reference-foreign ((class (eql (find-class 'font-options))) location)
- (%font-options-reference location))
-
-(defmethod unreference-foreign ((class (eql (find-class 'font-options))) location)
- (%font-options-destroy location))
-
(defbinding font-options-status () status
(font-options font-options))
(defbinding %font-options-create () pointer)
-(defmethod initialize-instance ((font-options font-options) &rest initargs)
+(defmethod allocate-foreign ((font-options font-options) &rest initargs)
(declare (ignore initargs))
- (setf (slot-value font-options 'location) (%font-options-create))
- (call-next-method))
+ (%font-options-create))
(defbinding font-options-merge () nil
- (options1 font-options :return)
+ (options1 font-options :in/return)
(options2 font-options))
(defbinding font-options-hash () unsigned-int
;;; Surfaces
-(defbinding %surface-reference () nil
+(defgeneric user-data (surface key))
+(defgeneric (setf user-data) (value surface key))
+
+(defmethod make-proxy-instance :around ((class surface-class) location
+ &rest initargs)
+ (let ((class (find-class (%surface-get-type location))))
+ (apply #'call-next-method class location initargs)))
+
+(defbinding %surface-get-type () surface-type
+ (location pointer))
+
+(defbinding %surface-reference () pointer
(location pointer))
(defbinding %surface-destroy () nil
(location pointer))
-(defmethod reference-foreign ((class (eql (find-class 'surface))) location)
- (%surface-reference location))
+(defbinding %surface-status () status
+ pointer)
+
+(defmethod allocate-foreign :around ((surface surface) &key)
+ (let ((location (call-next-method)))
+ (cond
+ ((not (eq (%surface-status location) :success))
+ (%surface-destroy location)
+ (error 'cairo-error :status (%surface-status location)))
+ (t location))))
+
+(defmethod reference-function ((class surface-class))
+ (declare (ignore class))
+ #'%surface-reference)
+
+(defmethod unreference-function ((class surface-class))
+ (declare (ignore class))
+ #'%surface-destroy)
+
+(defbinding %surface-set-user-data (surface key data-id) status-signal
+ (surface pointer)
+ ((quark-intern key) pointer-data)
+ (data-id pointer-data)
+ (user-data-destroy-callback callback))
-(defmethod unreference-foreign ((class (eql (find-class 'surface))) location)
- (%surface-destroy location))
+(defmethod (setf user-data) (data (surface surface) key)
+ (%surface-set-user-data (foreign-location surface) key (register-user-data data))
+ data)
+
+(defbinding %surface-get-user-data () pointer-data
+ (surface surface)
+ (key pointer-data))
+
+(defmethod user-data ((surface surface) key)
+ (find-user-data (%surface-get-user-data surface (quark-intern key))))
(defbinding surface-create-similar () surface
(other surface)
(defbinding surface-get-font-options () nil
(surface surface)
- ((make-instance 'font-options) font-options :return))
+ ((make-instance 'font-options) font-options :in/return))
(defbinding surface-set-device-offset () nil
(surface surface)
(%surface-mark-dirty-rectangle surface x y width height)
(%surface-mark-dirty surface)))
+(defbinding surface-set-fallback-resolution () nil
+ (surface surface)
+ (x-pixels-per-inch double-float)
+ (y-pixels-per-inch double-float))
+
+(defun %stream-write-func (stream-id data length)
+ (let ((stream (find-user-data stream-id))
+ (sequence
+ (map-c-vector 'vector #'identity data '(unsigned-byte 8) length)))
+ (handler-case (etypecase stream
+ (stream
+ (write-sequence sequence stream)
+ length)
+ ((or symbol function)
+ (funcall stream sequence)))
+ (serious-condition (condition)
+ (declare (ignore condition))
+ 0))))
+
+(define-callback stream-write-func status
+ ((stream-id pointer-data) (data pointer) (length unsigned-int))
+ (if (= (%stream-write-func stream-id data length) length)
+ :success
+ :write-error))
+
+(defun %stream-read-func (stream-id data length)
+ (let* ((stream (find-user-data stream-id)))
+ (handler-case
+ (multiple-value-bind (sequence bytes-read)
+ (etypecase stream
+ (stream
+ (let ((sequence (make-array length
+ :element-type '(unsigned-byte 8))))
+ (values sequence (read-sequence sequence stream))))
+ ((or symbol function) (funcall stream length)))
+ (make-c-vector '(unsigned-byte 8) (or bytes-read (length sequence))
+ :content sequence :location data)
+ (or bytes-read (length sequence)))
+ (serious-condition (condition)
+ (declare (ignore condition))
+ 0))))
+
+(define-callback stream-read-func status
+ ((stream-id pointer-data) (data pointer) (length unsigned-int))
+ (if (= (%stream-read-func stream-id data length) length)
+ :success
+ :read-error))
+
+(defmacro with-surface ((surface cr) &body body)
+ `(let ((,cr (make-instance 'context :target ,surface)))
+ ,@body))
;; Image Surface
-;; Should data be automatically freed when the surface is GCed?
-(defmethod initialize-instance ((surface image-surface)
- &key width height stride format data)
- (setf
- (slot-value surface 'location)
- (if (not data)
- (%image-surface-create format width height)
- (%image-surface-create-for-data data format width height
- (or
- stride
- (let ((element-size (cdr (assoc format '((:argb32 . 4) (:rgb24 . 4) (:a8 . 1) (:a1 1/8))))))
- (ceiling (* width element-size)))))))
- (call-next-method))
-
-
-(defbinding %image-surface-create () image-surface
+(defmethod allocate-foreign ((surface image-surface) &key source type
+ width height stride format)
+ (etypecase source
+ (null (%image-surface-create format width height))
+ ((or stream function symbol)
+ (let ((stream-id (register-user-data source)))
+ (unwind-protect
+ (cond
+ ((member type '("png" "image/png") :test #'equal)
+ (%image-surface-create-from-png-stream stream-id))
+ ((member type '("jpeg" "image/jpeg") :test #'equal)
+ (%image-surface-create-from-jpeg-stream stream-id))
+ ((not type) (error "Image type must be specified"))
+ ((error "Can't handle image type ~A" type)))
+ (destroy-user-data stream-id))))
+ ((or string pathname)
+ (cond
+ ((member type '("png" "image/png") :test #'equal)
+ (%image-surface-create-from-png source))
+ ((member type '("jpeg" "image/jpeg") :test #'equal)
+ (%image-surface-create-from-jpeg source))
+ ((not type) (error "Image type must be specified"))
+ ((error "Can't handle image type ~A" type))))
+ (pointer
+ (%image-surface-create-for-data source format width height
+ (or stride (format-stride-for-width format width))))))
+
+#?(pkg-exists-p "cairo" :atleast-version "1.6")
+(defbinding format-stride-for-width () int
+ surface-format (width int))
+
+#?-(pkg-exists-p "cairo" :atleast-version "1.6")
+(defun format-stride-for-width (format width)
+ (let ((element-size (cdr (assoc format '((:argb32 . 4) (:rgb24 . 4) (:a8 . 1) (:a1 1/8))))))
+ (ceiling (* width element-size))))
+
+
+(defbinding %image-surface-create () pointer
(format surface-format)
(width int)
(hegit int))
-(defbinding %image-surface-create-for-data () image-surface
+(defbinding %image-surface-create-for-data () pointer
(data pointer)
(format surface-format)
(width int)
(hegit int)
(stride int))
+(defbinding %image-surface-create-from-png () pointer
+ (filename pathname))
+(defbinding %image-surface-create-from-png-stream (stream) pointer
+ (stream-read-func callback)
+ (stream pointer-data))
-;;; PNG Surface
+(defbinding %surface-write-to-png () status-signal
+ (surface surface)
+ (filename pathname))
-(defbinding image-surface-create-from-png (filename) image-surface
- ((truename filename) pathname))
+(defbinding %surface-write-to-png-stream (surface stream) status-signal
+ (surface surface)
+ (stream-write-func callback)
+ (stream pointer-data))
+
+(defgeneric surface-write-to-png (surface dest))
+
+(defmethod surface-write-to-png (surface filename)
+ (%surface-write-to-png surface filename))
+
+(defmethod surface-write-to-png (surface (stream stream))
+ (let ((stream-id (register-user-data stream)))
+ (unwind-protect
+ (%surface-write-to-png-stream surface stream-id)
+ (destroy-user-data stream-id))))
+
+
+;;; JPEG support
+
+(define-callback jpeg-stream-write-func unsigned
+ ((stream-id pointer-data) (data pointer) (length unsigned-int))
+ (%stream-write-func stream-id data length))
+
+(define-callback jpeg-stream-read-func unsigned
+ ((stream-id pointer-data) (data pointer) (length unsigned-int))
+ (%stream-read-func stream-id data length))
+
+(defbinding %image-surface-create-from-jpeg () pointer
+ (filename pathname)
+ (status status-signal :out))
+
+(defbinding %image-surface-create-from-jpeg-stream (stream) pointer
+ (jpeg-stream-read-func callback)
+ (stream pointer-data)
+ (status status-signal :out))
+
+(defgeneric surface-write-to-jpeg (surface dest &key quality interlace))
+
+(defun %surface-acquire-image (surface)
+ (typecase surface
+ (image-surface surface)
+ ((let ((image (make-instance 'image-surface
+ :width (surface-width surface)
+ :height (surface-height surface)
+ :format :argb32)))
+ (with-surface (image cr)
+ (set-source-surface cr surface)
+ (setf (operator cr) :source)
+ (paint cr))
+ image))))
+
+(defbinding %surface-write-to-jpeg () status-signal
+ (surface image-surface)
+ (filename pathname)
+ (param jpeg-parameter))
+
+(defmethod surface-write-to-jpeg (surface filename &key
+ (quality 75) (interlace t))
+ (let ((param (make-instance 'jpeg-parameter
+ :quality quality :interlace interlace)))
+ (%surface-write-to-jpeg (%surface-acquire-image surface) filename param)))
+
+(defbinding %surface-write-to-jpeg-stream (surface stream param) status-signal
+ (surface surface)
+ (jpeg-stream-write-func callback)
+ (stream pointer-data)
+ (param jpeg-parameter))
+
+(defmethod surface-write-to-jpeg (surface (stream stream) &key
+ (quality 75) (interlace t))
+ (let ((stream-id (register-user-data stream))
+ (param (make-instance 'jpeg-parameter
+ :quality quality :interlace interlace)))
+ (unwind-protect
+ (%surface-write-to-jpeg-stream (%surface-acquire-image surface) stream-id param)
+ (destroy-user-data stream-id))))
+
+
+;;; Virtual size surface (abstract class)
+
+(defmethod initialize-instance :after ((surface vector-surface) &key
+ width height)
+ (setf (user-data surface 'width) width)
+ (setf (user-data surface 'height) height))
+
+(defmethod surface-width ((surface vector-surface))
+ (user-data surface 'width))
+
+(defmethod surface-height ((surface vector-surface))
+ (user-data surface 'height))
+
+
+(defun allocate-vector-surface (surface-create surface-create-for-stream
+ &key output filename stream width height)
+ (let ((location
+ (cond
+ ((/= (count-if #'identity (list output filename stream)) 1)
+ (error "One and only one of the arguments :OUTPUT, :FILENAME and :STREAM shoud be specified"))
+ (filename (funcall surface-create filename width height))
+ ((typep output '(or string pathname))
+ (%svg-surface-create output width height))
+ (t
+ (let* ((stream-id (register-user-data (or stream output)))
+ (location (funcall surface-create-for-stream
+ stream-id width height)))
+ (%surface-set-user-data location 'stream stream-id)
+ location)))))
+ location))
+
+
+;;; PDF Surface
+
+(defmethod allocate-foreign ((surface pdf-surface) &rest args)
+ (apply #'allocate-vector-surface
+ #'%pdf-surface-create #'%pdf-surface-create-for-stream args))
+
+(defbinding %pdf-surface-create () pointer
+ (filename pathname)
+ (width double-float)
+ (height double-float))
+
+(defbinding %pdf-surface-create-for-stream (stream width height) pointer
+ (stream-write-func callback)
+ (stream pointer-data)
+ (width double-float)
+ (height double-float))
+
+(defbinding pdf-surface-set-size () nil
+ (surface pdf-surface)
+ (width double-float)
+ (height double-float))
+;;; PS Surface
+
+(defmethod allocate-foreign ((surface ps-surface) &rest args)
+ (apply #'allocate-vector-surface
+ #'%ps-surface-create #'%ps-surface-create-for-stream args))
+
+(defbinding %ps-surface-create () pointer
+ (filename pathname)
+ (width double-float)
+ (height double-float))
+
+(defbinding %ps-surface-create-for-stream (stream width height) pointer
+ (stream-write-func callback)
+ (stream pointer-data)
+ (width double-float)
+ (height double-float))
+
+(defbinding ps-surface-set-size () nil
+ (surface ps-surface)
+ (width double-float)
+ (height double-float))
+
+(defbinding ps-surface-dsc-begin-setup () nil
+ (surface ps-surface))
+
+(defbinding ps-surface-dsc-begin-page-setup () nil
+ (surface ps-surface))
+
+(defbinding ps-surface-dsc-comment () nil
+ (surface ps-surface)
+ (comment string))
+
+
+;;; SVG Surface
+
+(defmethod allocate-foreign ((surface svg-surface) &rest args)
+ (apply #'allocate-vector-surface
+ #'%svg-surface-create #'%svg-surface-create-for-stream args))
+
+(defbinding %svg-surface-create () pointer
+ (filename pathname)
+ (width double-float)
+ (height double-float))
+
+(defbinding %svg-surface-create-for-stream (stream width height) pointer
+ (stream-write-func callback)
+ (stream pointer-data)
+ (width double-float)
+ (height double-float))
+
+(defbinding svg-surface-restrict-to-version () nil
+ (surface svg-surface)
+ (version svg-version))
+
;;; Matrices
-(defbinding matrix-init () nil
- (matrix matrix :return)
+(defbinding matrix-init (xx yx xy yy x0 y0 &optional (matrix (make-instance 'matrix))) nil
+ (matrix matrix :in/return)
(xx double-float) (yx double-float)
(xy double-float) (yy double-float)
(x0 double-float) (y0 double-float))
-(defbinding matrix-init-identity () nil
- (matrix matrix :return))
+(defbinding matrix-init-identity (&optional (matrix (make-instance 'matrix))) nil
+ (matrix matrix :in/return))
+
+(defun identity-matrix-p (matrix)
+ (with-slots (xx yx xy yy x0 y0) matrix
+ (and
+ (= xx 1.0d0) (= yx 0.0d0) (= xy 0.0d0)
+ (= yy 1.0d0) (= x0 0.0d0) (= y0 0.0d0))))
-(defbinding matrix-init-translate () nil
- (matrix matrix :return)
+(defbinding matrix-init-translate (tx ty &optional (matrix (make-instance 'matrix))) nil
+ (matrix matrix :in/return)
(tx double-float)
(ty double-float))
-(defbinding matrix-init-scale () nil
- (matrix matrix :return)
+(defbinding matrix-init-scale (sx &optional (sy sx) (matrix (make-instance 'matrix))) nil
+ (matrix matrix :in/return)
(sx double-float)
(sy double-float))
-(defbinding matrix-init-rotate () nil
- (matrix matrix :return)
- (radians double-float))
+(defbinding matrix-init-rotate (rotation &optional (matrix (make-instance 'matrix))) nil
+ (matrix matrix :in/return)
+ (rotation double-float))
(defbinding matrix-translate () nil
- (matrix matrix :return)
+ (matrix matrix :in/return)
(tx double-float)
(ty double-float))
-(defbinding matrix-scale () nil
- (matrix matrix :return)
+(defbinding matrix-scale (matrix sx &optional (sy sx)) nil
+ (matrix matrix :in/return)
(sx double-float)
(sy double-float))
(defbinding matrix-rotate () nil
- (matrix matrix :return)
- (radians double-float))
+ (matrix matrix :in/return)
+ (rotation double-float))
(defbinding matrix-invert () nil
- (matrix matrix :return))
+ (matrix matrix :in/return))
(defbinding matrix-multiply () nil
(result matrix :out)
(a matrix)
(b matrix))
-(defbinding matrix-transform-distance () nil
- (matrix matrix :return)
- (dx double-float)
- (dy double-float))
+(defbinding matrix-transform-distance (matrix dx &optional (dy dx)) nil
+ (matrix matrix)
+ (dx double-float :in/out)
+ (dy double-float :in/out))
(defbinding matrix-transform-point () nil
- (matrix matrix :return)
- (x double-float)
- (y double-float))
+ (matrix matrix)
+ (x double-float :in/out)
+ (y double-float :in/out))
+
+
+;; Version information
+(defbinding %version () int)
+(defun version ()
+ (let ((version (%version)))
+ (values
+ (mod (truncate version 10000) 100)
+ (mod (truncate version 100) 100)
+ (mod version 100))))
+(defbinding version-string () (static string))
~mdw / clg / blobdiff