Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo
In directory cl-net:/tmp/cvs-serv21922
Modified Files:
cairo.lisp ffi.lisp
Log Message:
Added support for image design drawing in the gtkairo backend.
Thanks to Samium Gromoff for contributing this patch.
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2007/07/11 15:26:20 1.4
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2009/09/02 05:29:01 1.5
@@ -534,6 +534,103 @@
(cairo_move_to cr (df x) (df (+ y y2))))
(pango_cairo_show_layout cr layout))))))
+;; Stolen from the CLX backend.
+(defmethod climi::medium-draw-image-design*
+ ((medium cairo-medium) (design climi::rgb-image-design) x y)
+ (destructuring-bind (&optional surface buffer mask)
+ (slot-value design 'climi::medium-data)
+ (unless surface
+ (let* ((image (slot-value design 'climi::image)))
+ (setf (values surface buffer) (image-to-cairosurface image))
+ (when (climi::image-alpha-p image)
+ (error "~@<Drawing of images with alpha component is not supported.~:@>"))
+ (setf (slot-value design 'climi::medium-data) (list surface buffer mask))))
+ (when mask
+ (error "~@<A mask in your image design.~:@>"))
+ (with-medium (medium)
+ (multiple-value-bind (x y)
+ (transform-position
+ (sheet-device-transformation (medium-sheet medium))
+ x y)
+ (setf x (float x 0d0))
+ (setf y (float y 0d0))
+ (with-slots (cr) medium
+ (cairo_set_source_surface cr surface x y)
+ (cond
+ #+ (or)
+ (mask
+ (xlib:with-gcontext (gcontext
+ :clip-mask mask
+ :clip-x x
+ :clip-y y)
+ (xlib:copy-area pixmap gcontext 0 0 width height
+ da x y)))
+ (t
+ (cairo_paint cr))))))))
+
+(defmethod climi::medium-free-image-design
+ ((medium cairo-medium) (design climi::rgb-image-design))
+ (destructuring-bind (&optional surface buffer mask)
+ (slot-value design 'climi::medium-data)
+ (when surface
+ #+ (or)
+ ;; This one bites, no idea why.
+ (cairo_destroy surface)
+ (cffi:foreign-free buffer)
+ (setf (slot-value design 'climi::medium-data) nil))))
+
+;; Was: CLX/compute-rgb-image-mask
+#+ (or)
+(defun compute-rgb-image-mask (drawable image)
+ (let* ((width (climi::image-width image))
+ (height (climi::image-height image))
+ (bitmap (xlib:create-pixmap :drawable drawable
+ :width width
+ :height height
+ :depth 1))
+ (gc (xlib:create-gcontext :drawable bitmap
+ :foreground 1
+ :background 0))
+ (idata (climi::image-data image))
+ (xdata (make-array (list height width)
+ :element-type '(unsigned-byte 1)))
+ (im (xlib:create-image :width width
+ :height height
+ :depth 1
+ :data xdata)) )
+ (dotimes (y width)
+ (dotimes (x height)
+ (if (> (aref idata x y) #x80000000)
+ (setf (aref xdata x y) 0)
+ (setf (aref xdata x y) 1))))
+ (unless (or (>= width 2048) (>= height 2048)) ;### CLX breaks here
+ (xlib:put-image bitmap gc im :src-x 0 :src-y 0
+ :x 0 :y 0 :width width :height height
+ :bitmap-p nil))
+ (xlib:free-gcontext gc)
+ bitmap))
+
+;; Was: CLX/image-to-ximage
+(defun image-to-cairosurface (image)
+ (let* ((width (climi::image-width image))
+ (height (climi::image-height image))
+ (idata (climi::image-data image))
+ (stride (cairo_format_stride_for_width :rgb24 width))
+ (cairodata (cffi:foreign-alloc :uint8 :count (* stride height))))
+ (declare (type (simple-array (unsigned-byte 32) (* *)) idata))
+ (loop :for row-offset :from 0 :by stride
+ :for y :from 0 :below height
+ :do (loop :for offset :from row-offset :by 4
+ :for x :from 0 :below width
+ :do (let ((px (aref idata y x)))
+ (setf (cffi:mem-ref cairodata :uint32 offset)
+ (dpb (ldb (byte 8 0) px) (byte 8 16)
+ (dpb (ldb (byte 8 8) px) (byte 8 8)
+ (dpb (ldb (byte 8 16) px) (byte 8 0)
+ 0)))))))
+ (values (cairo_image_surface_create_for_data cairodata :rgb24 width height stride)
+ cairodata)))
+
(defmethod medium-finish-output ((medium cairo-medium))
(with-medium (medium)
(when (cr medium)
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2007/03/03 12:09:51 1.18
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2009/09/02 05:29:01 1.19
@@ -333,6 +333,12 @@
(arg0 :pointer) ;cairo_font_face_t *
)
+(defcfun "cairo_format_stride_for_width"
+ :int
+ (arg0 cairo_format_t)
+ (arg1 :int)
+ )
+
(defcfun "cairo_get_font_face"
:pointer
(arg0 :pointer) ;cairo_t *
@@ -643,6 +649,14 @@
(arg4 :double) ;double
)
+(defcfun "cairo_set_source_surface"
+ :void
+ (arg0 :pointer) ;cairo_t *
+ (arg1 :pointer) ;cairo_surface_t *
+ (arg2 :double)
+ (arg3 :double)
+ )
+
(defcfun "cairo_set_tolerance"
:void
(arg0 :pointer) ;cairo_t *
