[pal-cvs] CVS pal

[tneste]

Update of /project/pal/cvsroot/pal
In directory clnet:/tmp/cvs-serv15516

Modified Files:
	pal.lisp 
Log Message:
Cleaned up and fixed SCREEN-TO-ARRAY

--- /project/pal/cvsroot/pal/pal.lisp	2007/07/27 21:25:40	1.21
+++ /project/pal/cvsroot/pal/pal.lisp	2007/07/27 22:48:40	1.22
@@ -452,24 +452,32 @@
 
 (defunct screen-to-array (pos width height)
     (vec pos u16 width u16 height)
-  (let ((array (make-array (list width height))))
-    (cffi:with-foreign-object (image :unsigned-char (* width height 3))
-      (pal-ffi:gl-read-pixels (truncate (vx pos))
-                              (- *height* (truncate (vy pos)) height)
+  (let* ((x (truncate (vx pos)))
+         (y (truncate (vy pos)))
+         (rowsize (* width 4))
+         (array (make-array (list width height))))
+    (cffi:with-foreign-object (image :unsigned-char (* (1+ width) (1+ height) 4))
+      (pal-ffi:gl-read-pixels x
+                              (- *height* y height)
                               width height
-                              pal-ffi:+gl-rgb+ pal-ffi:+gl-unsigned-byte+
+                              pal-ffi:+gl-rgba+ pal-ffi:+gl-unsigned-byte+
                               image)
       (do-n (x width y height)
-        (setf (aref array x (- height y 1))
-              (list (cffi:mem-aref image :unsigned-char (+ (* y width 3)
-                                                           (* x 3)))
-                    (cffi:mem-aref image :unsigned-char (+ (* y width 3)
-                                                           (* x 3)
-                                                           1))
-                    (cffi:mem-aref image :unsigned-char (+ (* y width 3)
-                                                           (* x 3)
-                                                           2))
-                    255)))
+        (let ((yrow (* y rowsize)))
+          (declare (type fixnum yrow))
+          (setf (aref array x (- height y 1))
+                (list (cffi:mem-aref image :unsigned-char (+ yrow
+                                                             (* x 4)
+                                                             0))
+                      (cffi:mem-aref image :unsigned-char (+ yrow
+                                                             (* x 4)
+                                                             1))
+                      (cffi:mem-aref image :unsigned-char (+ yrow
+                                                             (* x 4)
+                                                             2))
+                      (cffi:mem-aref image :unsigned-char (+ yrow
+                                                             (* x 4)
+                                                             3))))))
       array)))
 
 
@@ -596,10 +604,7 @@
        (with-gl pal-ffi:+gl-line-loop+
          (pal-ffi:gl-vertex2f (vx pos) (vy pos))
          (pal-ffi:gl-vertex2f (+ (vx pos) width) (vy pos))
-         (pal-ffi:gl-vertex2f (+ (vx pos) width) (vy pos))
-         (pal-ffi:gl-vertex2f (+ (vx pos) width) (+ (vy pos) height))
          (pal-ffi:gl-vertex2f (+ (vx pos) width) (+ (vy pos) height))
-         (pal-ffi:gl-vertex2f (vx pos) (+ (vy pos) height))
          (pal-ffi:gl-vertex2f (vx pos) (+ (vy pos) height)))))
     (t
      (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-current-bit+ pal-ffi:+gl-enable-bit+))