X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/4f4f0dc5f48441bc6dffd95ee69548fa57f2fcb1..b921bad3af5e725709cd2fc2ff8229af5104ff96:/cairo/cairo.lisp diff --git a/cairo/cairo.lisp b/cairo/cairo.lisp index f550888..8e72a06 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.19 2007-12-02 14:50:41 espen Exp $ +;; $Id: cairo.lisp,v 1.25 2009-02-09 11:45:03 espen Exp $ (in-package "CAIRO") @@ -230,15 +230,20 @@ :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)) @@ -345,7 +350,37 @@ (data :allocation :alien :type pointer) (length :allocation :alien :type int)) (:metaclass proxy-class) - (:unref %path-destroy))) + (:unref %path-destroy)) + + (defclass jpeg-parameter (struct) + ((quality + :allocation :alien + :initarg :quality + :initform 75 + :type int) + (interlace + :allocation :alien + :initarg :interlace + :initform t + :type boolean)) + (:metaclass struct-class))) + + +(define-condition cairo-error (error) + ((status :initarg :status :reader cairo-status)) + (:report (lambda (condition stream) + (format stream "Cairo function returned with status code: ~A" + (cairo-status condition))))) + +(deftype status-signal () 'status) + +(define-type-method from-alien-form ((type status-signal) status &key ref) + (declare (ignore type ref)) + `(let ((status ,(from-alien-form 'status status))) + (unless (eq status :success) + (error 'cairo-error :status status)) + status)) + ;;; Cairo context @@ -676,7 +711,7 @@ (defbinding show-glyphs () nil (cr context) - (glyphs (vector glyph)) + (glyphs (vector (inlined glyph))) ((length glyphs) int)) (defbinding font-extents (cr &optional (extents (make-instance 'font-extents))) nil @@ -773,6 +808,9 @@ ;;; Surfaces +(defgeneric user-data (surface key)) +(defgeneric (setf user-data) (value surface key)) + (defmethod make-proxy-instance :around ((class surface-class) location &rest initargs) (let ((class (find-class (%surface-get-type location)))) @@ -787,6 +825,17 @@ (defbinding %surface-destroy () nil (location pointer)) +(defbinding %surface-status () status + pointer) + +(defmethod allocate-foreign :around ((surface surface) &key) + (let ((location (call-next-method))) + (cond + ((not (eq (%surface-status location) :success)) + (%surface-destroy location) + (error 'cairo-error :status (%surface-status location))) + (t location)))) + (defmethod reference-function ((class surface-class)) (declare (ignore class)) #'%surface-reference) @@ -795,7 +844,7 @@ (declare (ignore class)) #'%surface-destroy) -(defbinding %surface-set-user-data (surface key data-id) status +(defbinding %surface-set-user-data (surface key data-id) status-signal (surface pointer) ((quark-intern key) pointer-data) (data-id pointer-data) @@ -856,18 +905,48 @@ (x-pixels-per-inch double-float) (y-pixels-per-inch double-float)) +(defun %stream-write-func (stream-id data length) + (let ((stream (find-user-data stream-id)) + (sequence + (map-c-vector 'vector #'identity data '(unsigned-byte 8) length))) + (handler-case (etypecase stream + (stream + (write-sequence sequence stream) + length) + ((or symbol function) + (funcall stream sequence))) + (serious-condition (condition) + (declare (ignore condition)) + 0)))) + (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) - + (if (= (%stream-write-func stream-id data length) length) + :success + :write-error)) + +(defun %stream-read-func (stream-id data length) + (let* ((stream (find-user-data stream-id))) + (handler-case + (multiple-value-bind (sequence bytes-read) + (etypecase stream + (stream + (let ((sequence (make-array length + :element-type '(unsigned-byte 8)))) + (values sequence (read-sequence sequence stream)))) + ((or symbol function) (funcall stream length))) + (make-c-vector '(unsigned-byte 8) (or bytes-read (length sequence)) + :content sequence :location data) + (or bytes-read (length sequence))) + (serious-condition (condition) + (declare (ignore condition)) + 0)))) + +(define-callback stream-read-func status + ((stream-id pointer-data) (data pointer) (length unsigned-int)) + (if (= (%stream-read-func stream-id data length) length) + :success + :read-error)) (defmacro with-surface ((surface cr) &body body) `(let ((,cr (make-instance 'context :target ,surface))) @@ -876,18 +955,41 @@ ;; 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) - (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)))))))) +(defmethod allocate-foreign ((surface image-surface) &key source type + width height stride format) + (etypecase source + (null (%image-surface-create format width height)) + ((or stream function symbol) + (let ((stream-id (register-user-data source))) + (unwind-protect + (cond + ((member type '("png" "image/png") :test #'equal) + (%image-surface-create-from-png-stream stream-id)) + ((member type '("jpeg" "image/jpeg") :test #'equal) + (%image-surface-create-from-jpeg-stream stream-id)) + ((not type) (error "Image type must be specified")) + ((error "Can't handle image type ~A" type))) + (destroy-user-data stream-id)))) + ((or string pathname) + (cond + ((member type '("png" "image/png") :test #'equal) + (%image-surface-create-from-png source)) + ((member type '("jpeg" "image/jpeg") :test #'equal) + (%image-surface-create-from-jpeg source)) + ((not type) (error "Image type must be specified")) + ((error "Can't handle image type ~A" type)))) + (pointer + (%image-surface-create-for-data source format width height + (or stride (format-stride-for-width format width)))))) + +#?(pkg-exists-p "cairo" :atleast-version "1.6") +(defbinding format-stride-for-width () int + surface-format (width int)) + +#?-(pkg-exists-p "cairo" :atleast-version "1.6") +(defun format-stride-for-width (format width) + (let ((element-size (cdr (assoc format '((:argb32 . 4) (:rgb24 . 4) (:a8 . 1) (:a1 1/8)))))) + (ceiling (* width element-size)))) (defbinding %image-surface-create () pointer @@ -905,26 +1007,130 @@ (defbinding %image-surface-create-from-png () pointer (filename pathname)) -(defbinding surface-write-to-png () status +(defbinding %image-surface-create-from-png-stream (stream) pointer + (stream-read-func callback) + (stream pointer-data)) + +(defbinding %surface-write-to-png () status-signal (surface surface) (filename pathname)) +(defbinding %surface-write-to-png-stream (surface stream) status-signal + (surface surface) + (stream-write-func callback) + (stream pointer-data)) + +(defgeneric surface-write-to-png (surface dest)) -;;; PDF Surface +(defmethod surface-write-to-png (surface filename) + (%surface-write-to-png surface filename)) -(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)))) +(defmethod surface-write-to-png (surface (stream stream)) + (let ((stream-id (register-user-data stream))) + (unwind-protect + (%surface-write-to-png-stream surface stream-id) + (destroy-user-data stream-id)))) +;;; JPEG support + +(define-callback jpeg-stream-write-func unsigned + ((stream-id pointer-data) (data pointer) (length unsigned-int)) + (%stream-write-func stream-id data length)) + +(define-callback jpeg-stream-read-func unsigned + ((stream-id pointer-data) (data pointer) (length unsigned-int)) + (%stream-read-func stream-id data length)) + +(defbinding %image-surface-create-from-jpeg () pointer + (filename pathname) + (status status-signal :out)) + +(defbinding %image-surface-create-from-jpeg-stream (stream) pointer + (jpeg-stream-read-func callback) + (stream pointer-data) + (status status-signal :out)) + +(defgeneric surface-write-to-jpeg (surface dest &key quality interlace)) + +(defun %surface-acquire-image (surface) + (typecase surface + (image-surface surface) + ((let ((image (make-instance 'image-surface + :width (surface-width surface) + :height (surface-height surface) + :format :argb32))) + (with-surface (image cr) + (set-source-surface cr surface) + (setf (operator cr) :source) + (paint cr)) + image)))) + +(defbinding %surface-write-to-jpeg () status-signal + (surface image-surface) + (filename pathname) + (param jpeg-parameter)) + +(defmethod surface-write-to-jpeg (surface filename &key + (quality 75) (interlace t)) + (let ((param (make-instance 'jpeg-parameter + :quality quality :interlace interlace))) + (%surface-write-to-jpeg (%surface-acquire-image surface) filename param))) + +(defbinding %surface-write-to-jpeg-stream (surface stream param) status-signal + (surface surface) + (jpeg-stream-write-func callback) + (stream pointer-data) + (param jpeg-parameter)) + +(defmethod surface-write-to-jpeg (surface (stream stream) &key + (quality 75) (interlace t)) + (let ((stream-id (register-user-data stream)) + (param (make-instance 'jpeg-parameter + :quality quality :interlace interlace))) + (unwind-protect + (%surface-write-to-jpeg-stream (%surface-acquire-image surface) stream-id param) + (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) @@ -944,17 +1150,9 @@ ;;; 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) @@ -985,17 +1183,9 @@ ;;; 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) @@ -1016,7 +1206,7 @@ ;;; 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) @@ -1031,19 +1221,19 @@ (= 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) @@ -1057,7 +1247,7 @@ (defbinding matrix-rotate () nil (matrix matrix :in/return) - (radians double-float)) + (rotation double-float)) (defbinding matrix-invert () nil (matrix matrix :in/return)) @@ -1076,3 +1266,17 @@ (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))