Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv18071/Backends/CLX

Modified Files: medium.lisp Log Message:

Add a new class RGB-IMAGE (renamed from closure's IMAGELIB:AIMAGE) and RGB-IMAGE-DESIGN (used to implement CLOSURE/CLIM-DEVICE::RO/IMG).

Drawing code implemented only in CLIM-CLX, and only for true color visuals.

* Examples/rgb-image.lisp: New file, from closure/src/imagelib/basic.lisp. * Backends/CLX/medium.lisp (MEDIUM-DRAW-IMAGE-DESIGN*, MEDIUM-FREE-IMAGE-DESIGN, COMPUTE-RGB-IMAGE-PIXMAP, COMPUTE-RGB-IMAGE-MASK, IMAGE-TO-XIMAGE-FOR-DRAWABLE, IMAGE-TO-XIMAGE, MASK->BYTE, PIXEL-TRANSLATOR): Methods and functions, renamed from original closure code.

--- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/12/28 19:30:40 1.78 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2007/01/07 19:32:28 1.79 @@ -6,6 +6,7 @@ ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr) ;;; Robert Strandh (strandh@labri.u-bordeaux.fr) ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet@emi.u-bordeaux.fr) +;;; (c) copyright 1998,1999 by Gilbert Baumann

;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -1151,3 +1152,152 @@ (setf (medium-buffer medium) nil))) (funcall continuation)))

+ +;;; RGB-IMAGE support, from Closure + +(defmethod climi::medium-draw-image-design* + ((medium clx-medium) (design climi::rgb-image-design) x y) + (let* ((da (sheet-direct-mirror (medium-sheet medium))) + (image (slot-value design 'climi::image)) + (width (climi::image-height image)) + (height (climi::image-height image))) + (destructuring-bind (&optional pixmap mask) + (slot-value design 'climi::medium-data) + (unless pixmap + (setf pixmap (compute-rgb-image-pixmap da image)) + (when (climi::image-alpha-p image) + (setf mask (compute-rgb-image-mask da image))) + (setf (slot-value design 'climi::medium-data) (list pixmap mask))) + (multiple-value-bind (x y) + (transform-position + (sheet-device-transformation (medium-sheet medium)) + x y) + (setf x (round x)) + (setf y (round y)) + (let ((gcontext (xlib:create-gcontext :drawable da))) + (cond + (mask + (xlib:with-gcontext (gcontext + :clip-mask mask + :clip-x x + :clip-y (- y height)) + (xlib:copy-area pixmap gcontext 0 0 width height + da x (- y height)))) + (t + (xlib:copy-area pixmap gcontext 0 0 width height + da x (- y height))))))))) + +(defmethod climi::medium-free-image-design + ((medium clx-medium) (design climi::rgb-image-design)) + (destructuring-bind (&optional pixmap mask) + (slot-value design 'climi::medium-data) + (when pixmap + (xlib:free-pixmap pixmap) + (when mask + (xlib:free-pixmap mask)) + (setf (slot-value design 'climi::medium-data) nil)))) + +(defun compute-rgb-image-pixmap (drawable image) + (let* ((width (climi::image-width image)) + (height (climi::image-height image)) + (depth (xlib:drawable-depth drawable)) + (im (image-to-ximage-for-drawable drawable image))) + (setf width (max width 1)) + (setf height (max height 1)) + (let* ((pixmap (xlib:create-pixmap :drawable drawable + :width width + :height height + :depth depth)) + (gc (xlib:create-gcontext :drawable pixmap))) + (unless (or (>= width 2048) (>= height 2048)) ;### CLX bug + (xlib:put-image pixmap gc im + :src-x 0 :src-y 0 + :x 0 :y 0 + :width width :height height)) + (xlib:free-gcontext gc) + pixmap))) + +(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)) + +(defun image-to-ximage-for-drawable (drawable image) + (image-to-ximage image + (xlib:drawable-depth drawable) + (pixel-translator (xlib:window-colormap drawable)))) + +(defun image-to-ximage (image depth translator) + (let* ((width (climi::image-width image)) + (height (climi::image-height image)) + (idata (climi::image-data image)) + ;; FIXME: this (and the :BITS-PER-PIXEL, below) is a hack on + ;; top of a hack. At some point in the past, XFree86 and/or + ;; X.org decided that they would no longer support pixmaps + ;; with 24 bpp, which seems to be what most AIMAGEs want to + ;; be. For now, force everything to a 32-bit pixmap. + (xdata (make-array (list height width) :element-type '(unsigned-byte 32))) + (ximage (xlib:create-image :width width + :height height + :depth depth + :bits-per-pixel 32 + :data xdata))) + (declare (type (simple-array (unsigned-byte 32) (* *)) idata)) + (loop for x fixnum from 0 below width do + (loop for y fixnum from 0 below height do + (setf (aref xdata y x) + (funcall translator + x y + (ldb (byte 24 0) (aref idata y x)))))) + ximage)) + +(defun mask->byte (mask) + (let ((h (integer-length mask))) + (let ((l (integer-length (logxor mask (1- (ash 1 h)))))) + (byte (- h l) l)))) + +;; fixme! This is not just incomplete, but also incorrect: The original +;; true color code knew how to deal with non-linear RGB value +;; allocation. +(defun pixel-translator (colormap) + (unless (eq (xlib:visual-info-class (xlib:colormap-visual-info colormap)) + :true-color) + (error "sorry, cannot draw rgb image for non-true-color drawable yet")) + colormap + (let* ((info (xlib:colormap-visual-info colormap)) + (rbyte (mask->byte (xlib:visual-info-red-mask info))) + (gbyte (mask->byte (xlib:visual-info-green-mask info))) + (bbyte (mask->byte (xlib:visual-info-blue-mask info)))) + (lambda (x y sample) + (declare (ignore x y)) + (dpb (the (unsigned-byte 8) (ldb (byte 8 0) sample)) + rbyte + (dpb (the (unsigned-byte 8) (ldb (byte 8 8) sample)) + gbyte + (dpb (the (unsigned-byte 8) (ldb (byte 8 16) sample)) + bbyte + 0))))))