Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv24182/Backends/CLX
Modified Files: clim-extensions.lisp Log Message:
Added an extension function SHEET-RGB-IMAGE, which "screenshots" a sheet into an RGB-IMAGE; basically the opposite of MEDIUM-DRAW-RGB-IMAGE.
Implemented only for CLIM-CLX and only for true color visuals. * Backends/CLX/clim-extensions.lisp (ZIMAGE-TO-RGB): New helper function. (SHEET-RGB-DATA): New method. * Extensions/rgb-image.lisp (SHEET-RGB-IMAGE): New extension function. (SHEET-RGB-DATA): New backend protocol function.
--- /project/mcclim/cvsroot/mcclim/Backends/CLX/clim-extensions.lisp 2003/11/11 03:24:56 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/clim-extensions.lisp 2007/04/01 17:24:04 1.9 @@ -400,3 +400,43 @@ :clipping-region (sheet-region pane) :transformation (make-translation-transformation tx ty))))) ||# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; retrieve image + +(defun zimage-to-rgb (zimage) + (unless (eql (xlib:image-depth zimage) 24) + (error "sorry, only true color images supported in zimage-to-rgb")) + (let* ((data (xlib:image-z-pixarray zimage)) + (w (xlib:image-width zimage)) + (h (xlib:image-height zimage)) + (rbyte (mask->byte (xlib:image-red-mask zimage))) + (gbyte (mask->byte (xlib:image-green-mask zimage))) + (bbyte (mask->byte (xlib:image-blue-mask zimage))) + (result (make-array (list h w) + :element-type '(unsigned-byte 32)))) + (dotimes (y h) + (dotimes (x w) + (setf (aref result y x) + (let ((pixel (aref data y x))) + (dpb (the (unsigned-byte 8) (ldb rbyte pixel)) + (byte 8 0) + (dpb (the (unsigned-byte 8) (ldb gbyte pixel)) + (byte 8 8) + (dpb (the (unsigned-byte 8) (ldb bbyte pixel)) + (byte 8 16) + 0))))))) + result)) + +(defmethod climi::sheet-rgb-data ((port clx-port) sheet &key x y width height) + (let ((window (port-lookup-mirror port sheet))) + (values + (zimage-to-rgb + (xlib:get-image window + :format :z-pixmap + :x (or x 0) + :y (or y 0) + :width (or width (xlib:drawable-width window)) + :height (or height (xlib:drawable-height window)))) + nil)))