[mcclim-cvs] CVS mcclim/Backends/CLX

[dlichteblau]

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)))