X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/236e096ef31850942bb6563b3ed0a9b718392960..72251c9edb6e094e977394a94dab2f49cf6ba4bf:/cairo/cairo.lisp diff --git a/cairo/cairo.lisp b/cairo/cairo.lisp index 5b5db2c..2f99566 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.13 2007/06/04 10:42:53 espen Exp $ +;; $Id: cairo.lisp,v 1.20 2008/01/10 13:31:39 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 @@ -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))))) @@ -577,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 @@ -632,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) @@ -830,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? @@ -981,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)) @@ -1000,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)) @@ -1017,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))