X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/5bd7dddb550da6068bf09b1d7c493eab44a88f1e..8ac82923ec1f3812c5cd309773d847165949900b:/cairo/cairo.lisp

diff --git a/cairo/cairo.lisp b/cairo/cairo.lisp
index 8e7f7a2..3480ff7 100644
--- a/cairo/cairo.lisp
+++ b/cairo/cairo.lisp
@@ -20,12 +20,19 @@
 ;; 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.9 2007/01/12 10:32:43 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
@@ -52,7 +59,7 @@
   (define-enum-type hint-style :default :none :slight :medium :full)
   (define-enum-type hint-metrics :default :off :on)
 
-  (defclass glyph (proxy)
+  (defclass glyph (struct)
     ((index 
       :allocation :alien 
       :initarg :index 
@@ -70,11 +77,13 @@
       :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"
@@ -99,11 +108,15 @@
       :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
@@ -130,7 +143,7 @@
      (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"
@@ -149,9 +162,29 @@
       :setter "cairo_pattern_set_matrix"
       :accessor pattern-matrix
       :type matrix))
-    (:metaclass proxy-class))
+    (:metaclass proxy-class)
+    (:ref %pattern-reference)
+    (:unref %pattern-destroy))
+
 
-  (defclass context (proxy)
+  (defclass surface (ref-counted-object)
+    (#?(pkg-exists-p "cairo" :atleast-version "1.2")
+     (type
+      :allocation :virtual 
+      :getter "cairo_surface_get_tyoe"
+      :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 (ref-counted-object)
     ((target
       :allocation :virtual 
       :getter "cairo_get_target"
@@ -236,11 +269,9 @@
       :writer (setf matrix)
       :type matrix)
      )
-    (:metaclass proxy-class))
-
-  (defclass surface (proxy)
-    ()
-    (:metaclass proxy-class))
+    (:metaclass proxy-class)
+    (:ref %reference)
+    (:unref %destroy))
 
   (defclass image-surface (surface)
     ((width
@@ -255,6 +286,7 @@
       :type int))
     (:metaclass proxy-class))
 
+
 ;;   (defclass path (proxy)
 ;;     ()
 ;;     (:metaclass proxy-class))
@@ -270,12 +302,6 @@
 (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))
 
@@ -293,19 +319,32 @@
 (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))
+    (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))
@@ -377,61 +416,46 @@
 (defbinding new-path () nil
   (cr context))
 
-(defbinding close-path () nil
+#?(pkg-exists-p "cairo" :atleast-version "1.2")
+(defbinding new-sub-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 close-path () nil
+  (cr context))
 
-(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))
@@ -449,17 +473,17 @@
     (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))
@@ -484,12 +508,6 @@
 (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))
 
@@ -502,11 +520,19 @@
   (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))
@@ -517,30 +543,30 @@
 
 (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
@@ -570,13 +596,13 @@
 (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
@@ -587,12 +613,6 @@
 (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))
 
@@ -606,24 +626,18 @@
 (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)
@@ -631,11 +645,8 @@
   (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))
 
 
 
@@ -648,24 +659,17 @@
 (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
@@ -685,12 +689,6 @@
 (defbinding %surface-destroy () nil
   (location pointer))
 
-(defmethod reference-foreign ((class (eql (find-class 'surface))) location)
-  (%surface-reference location))
-
-(defmethod unreference-foreign ((class (eql (find-class 'surface))) location)
-  (%surface-destroy location))
-
 (defbinding surface-create-similar () surface
   (other surface)
   (format surface-format )
@@ -705,7 +703,7 @@
 
 (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)
@@ -730,23 +728,25 @@
       (%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
 
 ;; 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))
+(defmethod allocate-foreign ((surface image-surface) 
+			     &key width height stride format data)
+  (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)))))))
 
 
 (defbinding %image-surface-create () image-surface
@@ -774,44 +774,44 @@
 ;;; Matrices
 
 (defbinding matrix-init () nil
-  (matrix matrix :return)
+  (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))
+  (matrix matrix :in/return))
 
 (defbinding matrix-init-translate () nil
-  (matrix matrix :return)
+  (matrix matrix :in/return)
   (tx double-float)
   (ty double-float))
 
 (defbinding matrix-init-scale () nil
-  (matrix matrix :return)
+  (matrix matrix :in/return)
   (sx double-float)
   (sy double-float))
 
 (defbinding matrix-init-rotate () nil
-  (matrix matrix :return)
+  (matrix matrix :in/return)
   (radians 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)
+  (matrix matrix :in/return)
   (sx double-float)
   (sy double-float))
 
 (defbinding matrix-rotate () nil
-  (matrix matrix :return)
+  (matrix matrix :in/return)
   (radians double-float))
 
 (defbinding matrix-invert () nil
-  (matrix matrix :return))
+  (matrix matrix :in/return))
 
 (defbinding matrix-multiply () nil
   (result matrix :out)
@@ -819,12 +819,12 @@
   (b matrix))
 
 (defbinding matrix-transform-distance () nil
-  (matrix matrix :return)
+  (matrix matrix :in/return)
   (dx double-float)
   (dy double-float))
 
 (defbinding matrix-transform-point () nil
-  (matrix matrix :return)
+  (matrix matrix :in/return)
   (x double-float)
   (y double-float))