[pal-cvs] CVS pal - pal-cvs@common-lisp.net - mailman3.common-lisp.net

19 Jul 2007

Update of /project/pal/cvsroot/pal
In directory clnet:/tmp/cvs-serv32635
Modified Files:
    ffi.lisp package.lisp pal.lisp todo.txt 
Log Message:
Added SCREEN-TO-ARRAY

--- /project/pal/cvsroot/pal/ffi.lisp	2007/07/19 16:37:25	1.10
+++ /project/pal/cvsroot/pal/ffi.lisp	2007/07/19 18:51:37	1.11
@@ -672,6 +672,7 @@
 (defconstant +gl-line-loop+ #x2)
 (defconstant +gl-polygon+ #x9)
 (defconstant +gl-quads+ #x7)
+(defconstant +gl-PACK-ALIGNMENT+ #xD05)
 (defconstant +gl-blend+ #xBE2)
 (defconstant +gl-src-alpha+ #x302)
 (defconstant +gl-dst-alpha+ #x304)
@@ -888,6 +889,19 @@
     (%gl-get-integer value data)
     (cffi:mem-ref data :int)))
+(cffi:defcfun ("glReadPixels" gl-read-pixels) :void
+  (x :int)
+  (y :int)
+  (width :int)
+  (height :int)
+  (format :int)
+  (type :int)
+  (data :pointer))
+
+(cffi:defcfun ("glPixelStorei" gl-pixel-store) :void
+  (pack :int)
+  (value :int))
+
#+win32 (cffi:defcfun "SHGetFolderPathA" :int (owner :pointer) (folder :int) (handle :pointer) (flags :int) (path :pointer))
@@ -901,8 +915,4 @@
;; SDL_SysWMinfo wmInfo;
 ;; SDL_GetWMInfo(&wmInfo);
-;; HWND hWnd = wmInfo.window;
-
-;; image = (GLubyte *) malloc(width * height * sizeof(GLubyte) * 3) ;
-;; glPixelStorei(GL_PACK_ALIGNMENT, 1)                              ;
-;; glReadPixels(x, y, width, height, GL_RGB, GL_UNSIGNED_BYTE, image) ;
\ No newline at end of file
+;; HWND hWnd = wmInfo.window;
\ No newline at end of file
--- /project/pal/cvsroot/pal/package.lisp	2007/07/19 16:37:25	1.10
+++ /project/pal/cvsroot/pal/package.lisp	2007/07/19 18:51:37	1.11
@@ -5,6 +5,9 @@
   (:export #:+NO-EVENT+
            #:+gl-line-smooth+
            #:make-font
+           #:+gl-pack-alignment+
+           #:gl-read-pixels
+           #:gl-pixel-store
            #:+gl-scissor-test+
            #:free-surface
            #:gl-get-integer
@@ -421,6 +424,7 @@
            #:image-from-array
            #:image-from-fn
            #:load-image-to-array
+           #:screen-to-array
#:load-image
            #:image-width
--- /project/pal/cvsroot/pal/pal.lisp	2007/07/19 16:37:25	1.16
+++ /project/pal/cvsroot/pal/pal.lisp	2007/07/19 18:51:37	1.17
@@ -1,9 +1,10 @@
 ;; Notes:
-;; tags-resources-free?
-;; save-screen
+;; tags-resources-free
 ;; raise on top on windows
 ;; smoothed polygons, guess circle segment count
 ;; defunct
+;; calculate max-texture-size
+;; fix the fps
(declaim (optimize (speed 3)
@@ -58,7 +59,7 @@
   (pal-ffi:open-audio 22050 pal-ffi:+audio-s16+ 2 2048)
   (pal-ffi:gl-set-attribute pal-ffi:+gl-depth-size+ 0)
   (pal-ffi:gl-set-attribute pal-ffi:+gl-doublebuffer+ 1)
-
+  (pal-ffi:gl-pixel-store pal-ffi:+gl-pack-alignment+ 1)
   (let ((surface (pal-ffi::set-video-mode
                   width
                   height
@@ -395,7 +396,8 @@
       (do-n (x width y height)
         (multiple-value-bind (r g b a) (funcall fn x y)
           (let ((a (or a 255))
-                (p (the fixnum (+ (* y (the u16 (* (the u11 texture-width) 4))) (the u16 (* 4 x))))))
+                (p (the fixnum (+ (* y texture-width 4)
+                                  (the u16 (* 4 x))))))
             (when (< a 255)
               (setf mode pal-ffi:+gl-rgba+))
             (setf (cffi:mem-ref tdata :uint8 p) (the u8 r)
@@ -443,6 +445,27 @@
     (pal-ffi::free-surface surface)
     image))
+(defun screen-to-array (pos width 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)
+                              width height
+                              pal-ffi:+gl-rgb+ 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)))
+      array)))
+
 (defun draw-image (image pos &key angle scale valign halign)
   (declare (type image image) (type vec pos) (type (or boolean single-float) angle scale) (type symbol halign valign))
   (set-image image)
--- /project/pal/cvsroot/pal/todo.txt	2007/07/19 16:37:25	1.11
+++ /project/pal/cvsroot/pal/todo.txt	2007/07/19 18:51:37	1.12
@@ -4,17 +4,12 @@
- Implement image mirroring.
-- Box/box/line/circle etc. overlap functions, faster v-dist
+- Box/box/line/circle etc. overlap functions, faster v-dist.
-- Improved texture handling
-
-- image-to-array/screen-to-array etc.
+- Improved texture handling.
- Fix the FPS limiter, the results could be a lot smoother.
-- Check the sanity of vector.lisp and add some operations, esp. bounding-boxes
-  etc.
-
 - Correct aspect ratio when fullscreen on widescreen displays.
- I would really like to see it run on OS X.

    