X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/2e86f0c9cfe59239f2256a1e384c61a8b7fcf206..9d1e38a03763a96dfa28ac42640623913a000c84:/cairo/cairo.lisp?ds=sidebyside

diff --git a/cairo/cairo.lisp b/cairo/cairo.lisp
index 993d0f1..824939f 100644
--- a/cairo/cairo.lisp
+++ b/cairo/cairo.lisp
@@ -20,7 +20,7 @@
 ;; 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.11 2007-02-19 14:37:52 espen Exp $
+;; $Id: cairo.lisp,v 1.21 2008-01-10 13:32:34 espen Exp $
 
 (in-package "CAIRO")
 
@@ -40,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
@@ -58,7 +58,7 @@   (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)
+    directfb-surface svg-surface os2-surface)
 
   (defclass surface-class (proxy-class)
     ())
@@ -140,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)
@@ -206,7 +213,7 @@   (defclass image-surface (surface)
      (stride
       :allocation :virtual 
       :getter "cairo_image_surface_get_stride"
-      :reader surface-height
+      :reader surface-stride
       :type int))
     (:metaclass surface-class))
 
@@ -292,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 
@@ -308,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"
@@ -326,11 +340,12 @@   (defclass context (ref-counted-object)
     (:unref %destroy))
 
 
-;;   (defclass path (proxy)
-;;     ()
-;;     (: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)))
 
 
 ;;; Cairo context
@@ -453,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)
@@ -470,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)))))
@@ -498,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)
@@ -572,11 +605,13 @@ (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))
-;      (identity-matrix cr)
-      (setf (matrix cr) (matrix-init-identity))
+      (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
@@ -627,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)
@@ -825,6 +869,11 @@ (define-callback stream-write-func status
   :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?
@@ -976,12 +1025,18 @@ (defbinding matrix-init () 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))
@@ -995,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))
@@ -1012,15 +1067,26 @@ (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))
+
+
+;; 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))