;; 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.7 2006/12/24 14:28:20 espen Exp $
+;; $Id: cairo.lisp,v 1.10 2007/01/13 00:15:36 espen Exp $
(in-package "CAIRO")
(eval-when (:compile-toplevel :load-toplevel :execute)
(define-enum-type surface-format :argb32 :rgb24 :a8 :a1)
+ #?(pkg-exists-p "cairo" :atleast-version "1.2")
+ (define-enum-type content :color :alpha :color-alpha)
+ #?(pkg-exists-p "cairo" :atleast-version "1.2")
+ (define-enum-type surface-type
+ :image :pdf :ps :xlib :xcb :glitz :quartz :win32 :beos :directfb
+ :svg :nquartz :os2)
+
(define-enum-type status
:success :no-memory :invalid-restore :invalid-pop-group
:type double-float))
(:metaclass struct-class))
- (defclass font-face (proxy)
+ (defclass font-face (ref-counted-object)
()
(: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"
(:ref %font-options-reference)
(:unref %font-options-destroy))
- (defclass scaled-font (proxy)
+ (defclass scaled-font (ref-counted-object)
()
(:metaclass proxy-class)
(:ref %scaled-font-reference)
(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"
(:unref %pattern-destroy))
- (defclass surface (proxy)
- ()
+ (defclass surface (ref-counted-object)
+ (#?(pkg-exists-p "cairo" :atleast-version "1.2")
+ (type
+ :allocation :virtual
+ :getter "cairo_surface_get_type"
+ :reader surface-type
+ :type surface-type)
+ #?(pkg-exists-p "cairo" :atleast-version "1.2")
+ (content
+ :allocation :virtual
+ :getter "cairo_surface_get_content"
+ :reader surface-content
+ :type content))
(:metaclass proxy-class)
(:ref %surface-reference)
(:unref %surface-destroy))
- (defclass context (proxy)
+ (defclass context (ref-counted-object)
((target
:allocation :virtual
:getter "cairo_get_target"
(:unref %destroy))
(defclass image-surface (surface)
- ((width
+ (#?(pkg-exists-p "cairo" :atleast-version "1.2")
+ (data
+ :allocation :virtual
+ :getter "cairo_image_surface_get_data"
+ :reader surface-data
+ :type pointer)
+ #?(pkg-exists-p "cairo" :atleast-version "1.2")
+ (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
:allocation :virtual
:getter "cairo_image_surface_get_height"
:reader surface-height
+ :type int)
+ #?(pkg-exists-p "cairo" :atleast-version "1.2")
+ (stride
+ :allocation :virtual
+ :getter "cairo_image_surface_get_stride"
+ :reader surface-height
:type int))
- (:metaclass proxy-class)
- (:ref %surface-reference)
- (:unref %surface-destroy))
+ (:metaclass proxy-class))
+
+ #?(pkg-exists-p "cairo" :atleast-version "1.2")
+ (progn
+ (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 proxy-class))
+
+ (defclass pdf-surface (surface)
+ ()
+ (:metaclass proxy-class))
+
+ (defclass ps-surface (surface)
+ ()
+ (:metaclass proxy-class))
+
+ (defclass svg-surface (surface)
+ ()
+ (:metaclass proxy-class)))
+
;; (defclass path (proxy)
;;; Cairo context
-(defbinding %reference () nil
+(defbinding %reference () pointer
(location pointer))
(defbinding %destroy () nil
((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))
+ (list (apply #'set-source-color cr source))
+ (vector (apply #'set-source-color cr (coerce source 'list)))
+ (null (set-source-color cr 0.0 0.0 0.0))))
+
(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)
(defbinding close-path () nil
(cr context))
-(defbinding arc () nil
- (cr context)
- (xc double-float)
- (yc double-float)
- (radius double-float)
- (angle1 double-float)
- (angle2 double-float))
-
-(defbinding arc-negative () nil
- (cr context)
- (xc double-float)
- (yc double-float)
- (radius double-float)
- (angle1 double-float)
- (angle2 double-float))
+(defmacro defpath (name args &optional relative-p)
+ (flet ((def (name type)
+ `(progn
+ ,(when (eq type 'optimized-double-float)
+ `(declaim (ftype (function (context ,@(loop repeat (length args) collect 'double-float))) ,(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)
(arc cr x y radius 0.0 (* pi 2)))
-(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))
-
-(defpath line-to
- (x double-float)
- (y double-float))
-
-(defpath move-to
- (x double-float)
- (y double-float))
-
-(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)
(glyphs (vector glyph))
(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
(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-call #'scale cr (device-to-user-distance cr 1.0))
+ (multiple-value-bind (x y)
+ (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))
(x double-float :in/out)
(y double-float :in/out))
-(defbinding user-to-device-distance (cr dx &optional (dy 0.0)) nil
+(defbinding user-to-device-distance (cr dx &optional (dy dx)) nil
(cr context)
(dx double-float :in/out)
(dy double-float :in/out))
(x double-float :in/out)
(y double-float :in/out))
-(defbinding device-to-user-distance (cr dx &optional (dy 0.0)) nil
+(defbinding device-to-user-distance (cr dx &optional (dy dx)) nil
(cr context)
(dx double-float :in/out)
(dy double-float :in/out))
;;; Fonts
-(defbinding %font-face-reference () nil
+(defbinding %font-face-reference () pointer
(location pointer))
(defbinding %font-face-destroy () nil
;;; Scaled Fonts
-(defbinding %scaled-font-reference () nil
+(defbinding %scaled-font-reference () pointer
(location pointer))
(defbinding %scaled-font-destroy () nil
;;; Surfaces
-(defbinding %surface-reference () nil
+(defbinding %surface-reference () pointer
(location pointer))
(defbinding %surface-destroy () nil
(%surface-mark-dirty-rectangle surface x y width height)
(%surface-mark-dirty surface)))
+#?(pkg-exists-p "cairo" :atleast-version "1.2")
+(defbinding surface-set-fallback-resolution () nil
+ (surface surface)
+ (x-pixels-per-inch double-float)
+ (y-pixels-per-inch double-float))
;; Image Surface