X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/355283f625ca83ba32d886425e3a702b16d333bd..7d6c9b981633cd3105600a75c4abd53a8450ee88:/cairo/cairo.lisp diff --git a/cairo/cairo.lisp b/cairo/cairo.lisp index b743c77..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.17 2007-10-19 10:12:25 espen Exp $ +;; $Id: cairo.lisp,v 1.22 2008-10-08 16:24:11 espen Exp $ (in-package "CAIRO") @@ -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) @@ -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" @@ -648,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) @@ -845,6 +873,19 @@ (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))) @@ -854,9 +895,14 @@ (defmacro with-surface ((surface cr) &body 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 @@ -882,26 +928,65 @@ (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) (width double-float) @@ -921,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) @@ -962,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) @@ -993,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) @@ -1008,19 +1077,19 @@ (defun identity-matrix-p (matrix) (= xx 1.0d0) (= yx 0.0d0) (= xy 0.0d0) (= yy 1.0d0) (= x0 0.0d0) (= y0 0.0d0)))) -(defbinding matrix-init-translate () nil +(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 (matrix sx &optional (sy sx)) 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) @@ -1034,7 +1103,7 @@ (defbinding matrix-scale (matrix sx &optional (sy sx)) nil (defbinding matrix-rotate () nil (matrix matrix :in/return) - (radians double-float)) + (rotation double-float)) (defbinding matrix-invert () nil (matrix matrix :in/return)) @@ -1053,3 +1122,17 @@ (defbinding matrix-transform-point () nil (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))