X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/8ac82923ec1f3812c5cd309773d847165949900b..72251c9edb6e094e977394a94dab2f49cf6ba4bf:/cairo/cairo.lisp

diff --git a/cairo/cairo.lisp b/cairo/cairo.lisp
index 3480ff7..2f99566 100644
--- a/cairo/cairo.lisp
+++ b/cairo/cairo.lisp
@@ -20,19 +20,14 @@
 ;; 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.9 2007/01/12 10:32:43 espen Exp $
+;; $Id: cairo.lisp,v 1.20 2008/01/10 13:31:39 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 svg-version :svg-1.1 :svg-1.2)
 
   (define-enum-type status
     :success :no-memory :invalid-restore :invalid-pop-group
@@ -45,7 +40,7 @@   (define-enum-type status
   (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
@@ -59,6 +54,18 @@   (define-enum-type subpixel-order :default :rgb :bgr :vrgb :vbgr)
   (define-enum-type hint-style :default :none :slight :medium :full)
   (define-enum-type hint-metrics :default :off :on)
 
+
+  (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 
@@ -133,6 +140,13 @@   (defclass matrix (struct)
 	 :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)
@@ -168,21 +182,66 @@   (defclass pattern (ref-counted-object)
 
 
   (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 
+    ((content 
       :allocation :virtual 
       :getter "cairo_surface_get_content"
       :reader surface-content
       :type content))
-    (:metaclass proxy-class)
-    (:ref %surface-reference)
-    (:unref %surface-destroy))
+    (: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 pdf-surface (surface)
+    ()
+    (:metaclass surface-class))
+  
+  (defclass ps-surface (surface)
+    ()
+    (:metaclass surface-class))
+    
+  (defclass svg-surface (surface)
+    ()
+    (:metaclass surface-class))
+
 
   (defclass context (ref-counted-object)
     ((target
@@ -240,15 +299,15 @@   (defclass context (ref-counted-object)
       :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 
@@ -256,6 +315,13 @@   (defclass context (ref-counted-object)
       :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"
@@ -273,30 +339,24 @@   (defclass context (ref-counted-object)
     (:ref %reference)
     (:unref %destroy))
 
-  (defclass image-surface (surface)
-    ((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))
-    (:metaclass proxy-class))
 
+   (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 path (proxy)
-;;     ()
-;;     (:metaclass proxy-class))
 
-)
+;;; Cairo context
 
+(defmethod allocate-foreign ((context context) &key target)
+  (%create-context target))
 
-;;; Cairo context
+(defbinding (%create-context "cairo_create") () pointer
+  (target surface))
 
-(defbinding %reference () nil
+(defbinding %reference () pointer
   (location pointer))
 
 (defbinding %destroy () nil
@@ -308,8 +368,8 @@ (defbinding (save-context "cairo_save") () nil
 (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
@@ -341,9 +401,9 @@ (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)))
-    (null (set-source-color cr 0.0 0.0 0.0))))
+    (vector (apply #'set-source-color cr (coerce source 'list)))))
 
 (defbinding set-dash (cr dashes &optional (offset 0.0)) nil
   (cr context)
@@ -385,7 +445,7 @@ 	       (defbinding ,tname () boolean
 		 (cr context)
 		 (x double-float)
 		 (y double-float))
-	       (defbinding ,ename () boolean
+	       (defbinding ,ename () nil
 		 (cr context)
 		 (x1 double-float :out)
 		 (y1 double-float :out)
@@ -408,6 +468,19 @@ (defbinding show-page () nil
 
 ;;; Paths
 
+(defbinding %path-destroy () nil
+  (location pointer))
+
+(defbinding copy-path () path
+  (cr context))
+
+(defbinding copy-path-flat () path
+  (cr context))
+
+(defbinding append-path () nil
+  (cr context)
+  (path path))
+
 (defbinding get-current-point () nil
   (cr context)
   (x double-float :out)
@@ -425,9 +498,9 @@ (defbinding close-path () nil
 
 (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))))
+ 	   `(progn
+ 	      ,(when (eq type 'optimized-double-float)
+ 		 `(declaim (inline ,(first name))))
 	      (defbinding ,name () nil
 		(cr context)
 		,@(mapcar #'(lambda (arg) (list arg type)) args)))))
@@ -453,8 +526,13 @@ (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)))
+(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 glyph-path (cr glyphs) nil
   (cr context)
@@ -502,7 +580,7 @@ (defbinding pattern-create-radial () pattern
   (cy1 double-float)
   (radius1 double-float))
 
-(defbinding %pattern-reference () nil
+(defbinding %pattern-reference () pointer
   (location pointer))
 
 (defbinding %pattern-destroy () nil
@@ -527,9 +605,12 @@ (defbinding scale (cr sx &optional (sy sx)) nil
 
 (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))
+      (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))))
 
@@ -581,17 +662,26 @@ (defbinding set-font-size () nil
   (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)
@@ -607,7 +697,7 @@ (defbinding glyph-extents (cr glyphs &optional (extents (make-instance 'text-ext
 
 ;;; Fonts
 
-(defbinding %font-face-reference () nil
+(defbinding %font-face-reference () pointer
   (location pointer))
 
 (defbinding %font-face-destroy () nil
@@ -620,7 +710,7 @@ (defbinding font-face-status () status
 
 ;;; Scaled Fonts
 
-(defbinding %scaled-font-reference () nil
+(defbinding %scaled-font-reference () pointer
   (location pointer))
 
 (defbinding %scaled-font-destroy () nil
@@ -683,12 +773,45 @@ (defbinding font-options-equal-p () boolean
 
 ;;; Surfaces
 
-(defbinding %surface-reference () nil
+(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-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
+  (surface pointer)
+  ((quark-intern key) pointer-data)
+  (data-id pointer-data)
+  (user-data-destroy-callback callback))
+
+(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)
   (format surface-format )
@@ -728,46 +851,166 @@ (defun surface-mark-dirty (surface &optional x y width height)
       (%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))
 
+(define-callback stream-write-func status 
+    ((stream-id pointer-data) (data pointer) (length unsigned-int))
+  (let ((stream (find-user-data stream-id)))
+    (typecase stream
+      (stream
+       (map-c-vector 'nil #'(lambda (octet) (write-byte octet stream))
+	data '(unsigned-byte 8) length))
+      ((or symbol function)
+       (funcall stream 
+	(map-c-vector 'vector #'identity data '(unsigned-byte 8) length)))))
+  :success)
+
+
+(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 allocate-foreign ((surface image-surface) 
-			     &key width height stride format data)
-  (if (not data)
-      (%image-surface-create format width height)
+			     &key filename width height stride format data)
+  (cond
+   (filename (%image-surface-create-from-png filename))
+   ((not data) (%image-surface-create format width height))
+   (t
     (%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)))))))
+	(ceiling (* width element-size))))))))
 
 
-(defbinding %image-surface-create () image-surface
+(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))
 
-
-;;; PNG Surface
-
-(defbinding image-surface-create-from-png (filename) image-surface
-  ((truename filename) pathname))
-
+(defbinding surface-write-to-png () status
+  (surface surface)
+  (filename pathname))
+
+
+;;; PDF Surface
+
+(defmethod allocate-foreign ((surface pdf-surface)
+			     &key filename stream width height)
+  (cond
+   ((and filename stream)
+    (error "Only one of the arguments :filename and :stream may be specified"))
+   (filename (%pdf-surface-create filename width height))
+   (stream 
+    (let* ((stream-id (register-user-data stream))
+	   (location (%pdf-surface-create-for-stream stream-id width height)))
+      (%surface-set-user-data location 'stream stream-id)
+      location))))
+
+
+(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) 
+			     &key filename stream width height)
+  (cond
+   ((and filename stream)
+    (error "Only one of the arguments :filename and :stream may be specified"))
+   (filename (%ps-surface-create filename width height))
+   (stream 
+    (let* ((stream-id (register-user-data stream))
+	   (location (%ps-surface-create-for-stream stream-id width height)))
+      (%surface-set-user-data location 'stream stream-id)
+      location))))
+
+(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) 
+			     &key filename stream width height)
+  (cond
+   ((and filename stream)
+    (error "Only one of the arguments :filename and :stream may be specified"))
+   (filename (%svg-surface-create filename width height))
+   (stream 
+    (let* ((stream-id (register-user-data stream))
+	   (location (%svg-surface-create-for-stream stream-id width height)))
+      (%surface-set-user-data location 'stream stream-id)
+      location))))
+
+(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))
 
 
 
@@ -779,15 +1022,21 @@ (defbinding matrix-init () nil
   (xy double-float) (yy double-float) 
   (x0 double-float) (y0 double-float))
 
-(defbinding matrix-init-identity () nil
+(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 :in/return)
   (tx double-float)
   (ty double-float))
 
-(defbinding matrix-init-scale () nil
+(defbinding matrix-init-scale (matrix sx &optional (sy sx)) nil
   (matrix matrix :in/return)
   (sx double-float)
   (sy double-float))
@@ -801,7 +1050,7 @@ (defbinding matrix-translate () nil
   (tx double-float)
   (ty double-float))
 
-(defbinding matrix-scale () nil
+(defbinding matrix-scale (matrix sx &optional (sy sx)) nil
   (matrix matrix :in/return)
   (sx double-float)
   (sy double-float))
@@ -818,15 +1067,12 @@ (defbinding matrix-multiply () nil
   (a matrix)
   (b matrix))
 
-(defbinding matrix-transform-distance () nil
-  (matrix matrix :in/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 :in/return)
-  (x double-float)
-  (y double-float))
-
-
-
+  (matrix matrix)
+  (x double-float :in/out)
+  (y double-float :in/out))