X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/539851a836fe00f68002e8d2baaeccb4ce19d3f0..7d6c9b981633cd3105600a75c4abd53a8450ee88:/cairo/cairo.lisp diff --git a/cairo/cairo.lisp b/cairo/cairo.lisp index a87c6bb..c4d4f26 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.22 2008-10-08 16:24:11 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)) @@ -223,15 +230,20 @@ (defclass xlib-surface (surface) :type int)) (:metaclass surface-class)) - (defclass pdf-surface (surface) + (defclass vector-surface (surface) + ((width :allocation :virtual :getter surface-width) + (height :allocation :virtual :setter surface-height)) + (:metaclass surface-class)) + + (defclass pdf-surface (vector-surface) () (:metaclass surface-class)) - (defclass ps-surface (surface) + (defclass ps-surface (vector-surface) () (:metaclass surface-class)) - (defclass svg-surface (surface) + (defclass svg-surface (vector-surface) () (:metaclass surface-class)) @@ -292,15 +304,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 +320,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 +345,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 +473,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 +503,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 +610,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 +667,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) @@ -829,13 +873,36 @@ (define-callback stream-write-func status (map-c-vector 'vector #'identity data '(unsigned-byte 8) length))))) :success) +(define-callback stream-read-func status + ((stream-id pointer-data) (data pointer) (length unsigned-int)) + (let ((stream (find-user-data stream-id))) + (typecase stream + (stream + (loop for i below length do + (let ((byte (read-byte stream nil))) + (if byte + (setf (gffi::ref-uint-8 data i) byte) + (return-from stream-read-func :read-error))))) + ((or symbol function) (funcall stream data 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 filename width height stride format data) +(defmethod allocate-foreign ((surface image-surface) &key stream filename + width height stride format data) (cond + (stream + (let ((stream-id (register-user-data stream))) + (unwind-protect + (%image-surface-create-from-png-stream stream-id) + (destroy-user-data stream-id)))) (filename (%image-surface-create-from-png filename)) ((not data) (%image-surface-create format width height)) (t @@ -861,25 +928,64 @@ (defbinding %image-surface-create-for-data () pointer (defbinding %image-surface-create-from-png () pointer (filename pathname)) +(defbinding %image-surface-create-from-png-stream (stream) pointer + (stream-read-func callback) + (stream pointer-data)) + (defbinding surface-write-to-png () status (surface surface) (filename pathname)) -;;; PDF Surface +(defbinding %surface-write-to-png-stream (surface stream) status + (surface surface) + (stream-write-func callback) + (stream pointer-data)) -(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)))) +(defun surface-write-to-png-stream (surface stream) + (let ((stream-id (register-user-data stream))) + (unwind-protect + (%surface-write-to-png-stream surface stream-id) + (destroy-user-data stream-id)))) + + +;;; Virtual size surface (abstract class) +(defmethod initialize-instance :after ((surface vector-surface) &key + width height) + (setf (user-data surface 'width) width) + (setf (user-data surface 'height) height)) + +(defmethod surface-width ((surface vector-surface)) + (user-data surface 'width)) + +(defmethod surface-height ((surface vector-surface)) + (user-data surface 'height)) + + +(defun allocate-vector-surface (surface-create surface-create-for-stream + &key output filename stream width height) + (let ((location + (cond + ((/= (count-if #'identity (list output filename stream)) 1) + (error "One and only one of the arguments :OUTPUT, :FILENAME and :STREAM shoud be specified")) + (filename (funcall surface-create filename width height)) + ((typep output '(or string pathname)) + (%svg-surface-create output width height)) + (t + (let* ((stream-id (register-user-data (or stream output))) + (location (funcall surface-create-for-stream + stream-id width height))) + (%surface-set-user-data location 'stream stream-id) + location))))) + location)) + + +;;; PDF Surface + +(defmethod allocate-foreign ((surface pdf-surface) &rest args) + (apply #'allocate-vector-surface + #'%pdf-surface-create #'%pdf-surface-create-for-stream args)) (defbinding %pdf-surface-create () pointer (filename pathname) @@ -900,17 +1006,9 @@ (defbinding pdf-surface-set-size () nil ;;; 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)))) +(defmethod allocate-foreign ((surface ps-surface) &rest args) + (apply #'allocate-vector-surface + #'%ps-surface-create #'%ps-surface-create-for-stream args)) (defbinding %ps-surface-create () pointer (filename pathname) @@ -941,17 +1039,9 @@ (defbinding ps-surface-dsc-comment () nil ;;; 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)))) +(defmethod allocate-foreign ((surface svg-surface) &rest args) + (apply #'allocate-vector-surface + #'%svg-surface-create #'%svg-surface-create-for-stream args)) (defbinding %svg-surface-create () pointer (filename pathname) @@ -972,7 +1062,7 @@ (defbinding svg-surface-restrict-to-version () nil ;;; Matrices -(defbinding matrix-init () nil +(defbinding matrix-init (xx yx xy yy x0 y0 &optional (matrix (make-instance 'matrix))) nil (matrix matrix :in/return) (xx double-float) (yx double-float) (xy double-float) (yy double-float) @@ -981,33 +1071,39 @@ (defbinding matrix-init () nil (defbinding matrix-init-identity (&optional (matrix (make-instance 'matrix))) nil (matrix matrix :in/return)) -(defbinding matrix-init-translate () nil +(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 (tx ty &optional (matrix (make-instance 'matrix))) nil (matrix matrix :in/return) (tx double-float) (ty double-float)) -(defbinding matrix-init-scale () nil +(defbinding matrix-init-scale (sx &optional (sy sx) (matrix (make-instance 'matrix))) nil (matrix matrix :in/return) (sx double-float) (sy double-float)) -(defbinding matrix-init-rotate () nil +(defbinding matrix-init-rotate (rotation &optional (matrix (make-instance 'matrix))) nil (matrix matrix :in/return) - (radians double-float)) + (rotation double-float)) (defbinding matrix-translate () nil (matrix matrix :in/return) (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)) (defbinding matrix-rotate () nil (matrix matrix :in/return) - (radians double-float)) + (rotation double-float)) (defbinding matrix-invert () nil (matrix matrix :in/return)) @@ -1017,15 +1113,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))