[cello-cvs] CVS cello/cl-magick

[ktilton]

Update of /project/cello/cvsroot/cello/cl-magick
In directory clnet:/tmp/cvs-serv637/cl-magick

Modified Files:
	cl-magick.lisp wand-image.lisp wand-texture.lisp 
Log Message:


--- /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp	2006/08/31 17:34:48	1.11
+++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp	2006/09/05 23:05:37	1.12
@@ -20,7 +20,7 @@
 ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 
 ;;; IN THE SOFTWARE.
 
-;;; $Id: cl-magick.lisp,v 1.11 2006/08/31 17:34:48 ktilton Exp $
+;;; $Id: cl-magick.lisp,v 1.12 2006/09/05 23:05:37 ktilton Exp $
 
 
 (defpackage :cl-magick
@@ -90,9 +90,9 @@
 
 (defun cl-magick-reset ()
   (wands-clear)
-  #+shhh (progn
-           (print `(magick-copyright ,(magick-get-copyright)))
-           (print `(magick-version ,(magick-get-version *mgk-version*))))
+  (progn
+    (print `(magick-copyright ,(magick-get-copyright)))
+    (print `(magick-version ,(magick-get-version *mgk-version*))))
   )
 
 (defun wands-loaded () *wands-loaded*)
@@ -103,15 +103,15 @@
 (defun wands-clear ()
   (loop for wand in *wands-loaded*
         do (wand-release (cdr wand)))
-  (setf *wands-loaded* nil))
+  (setf (wands-loaded) nil))
 
 (defun wand-ensure-typed (wand-type file-path$ &rest iargs)
   (when file-path$
     (cl-magick-init)
     (let ((key (list* wand-type (namestring file-path$) iargs)))
-      (or (let ((old (cdr (assoc key (wands-loaded) :test 'equal)))) ;;/// primitive test
-           #+shhhh (when old
-              (print `(wand-ensure-typed re-using prior load ,wand-type ,file-path$)))
+      (or (let ((old (cdr (assoc key (wands-loaded) :test 'equal))))
+            (when old
+              (print `(wand-ensure-typed re-using-prior-load ,wand-type ,file-path$)))
             old)
         (let ((wi (apply 'make-instance wand-type
                     :file-path$ file-path$
--- /project/cello/cvsroot/cello/cl-magick/wand-image.lisp	2006/08/31 17:34:48	1.7
+++ /project/cello/cvsroot/cello/cl-magick/wand-image.lisp	2006/09/05 23:05:37	1.8
@@ -91,7 +91,7 @@
   (if (zerop (* last-col last-row))
       (let* ((columns 64)(rows 64)
              (pixels (fgn-alloc :unsigned-char (* 3 columns rows) :wand-image)))
-        ;(print "wand-get-image-pixels > wand has zero pixels; did the load fail?")
+        (print "wand-get-image-pixels > wand has zero pixels; did the load fail?")
         (dotimes (pn (* columns rows))
           (setf (elti pixels pn) -1))
         (values pixels columns rows))
@@ -100,15 +100,37 @@
            (rows (- last-row first-row))
            (pixels (fgn-alloc :unsigned-char (* 3 columns rows) :wand-image)))
       (assert (not (zerop pixels))() "wand-get-image-pixels > fgn-alloc of ~a bytes failed" (* 3 columns rows))
-      ;;(print (list "wand-get-image-pixels got" wand (* 3 columns rows) pixels)) ;; frgo: debug ...
-      ;;(cells:trc "image format" wand (magick-get-image-format wand)) ;; frgo:debug...
+      (print (list "wand-get-image-pixels got" wand (* 3 columns rows) pixels)) ;; frgo: debug ...
+      (cells:trc "image format" wand (magick-get-image-format wand)) ;; frgo:debug...
+      ;
+      ; these next two are quite slow thx to FFI I guess
+      ;
+      #+pretty! ;; random noise texture and pixmap
+      (dotimes (off (* 3 columns rows))
+        (setf (eltuc pixels off) (random 256)))
+
+      #+zerosowecanseewhatreallygetsread
+      (dotimes (off (* 3 columns rows))
+        (setf (eltuc pixels off) 0))
+
       (magick-get-image-pixels wand first-col first-row columns rows "RGB" 0 pixels )
      ;;(print `(writeimage ,(magick-write-image wand "/tmp/wand-image-test.jpg")))
-      #+jesfoolinaround(loop for row below 16 do
-            (loop for col below 16 by 1
-                for offset = (+ (* row columns 3) (* col 3))
-                do (print (loop for bn below 3
-                               collecting (setf (elti pixels (+ offset bn)) 0)))))
+      (progn
+        ;
+        ; look at a few pixels
+        ;
+        (print (list "a few pixels from" wand))
+        (block sweet-16
+          (loop for row below rows do
+                (loop with bytes
+                    for bytecol below (* 3 columns)
+                    for offset = (+ (* row columns 3) bytecol)
+                    for char = (eltuc pixels offset)
+                    until (> (length bytes) 15)
+                    unless (zerop char)
+                    do (pushnew char bytes)
+                    finally (format t "~&sixteen bytes ~{~a ~}" bytes)
+                      (return-from sweet-16)))))
             
       (values pixels columns rows))))
 
--- /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp	2006/08/28 18:41:19	1.6
+++ /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp	2006/09/05 23:05:37	1.7
@@ -42,14 +42,14 @@
              (grow-sz (cons (expt 2 (ceiling (log (car (image-size self)) 2)))
 			    (expt 2 (ceiling (log (cdr (image-size self)) 2)))))
              (best-fit-sz (best-fit-cons trunc-sz (image-size self) grow-sz)))
-	;;(print `(texture-name> gennning texture ,self)) ;; frgo: debug...
+        (print `(texture-name> gennning texture ,self)) ;; frgo: debug...
         (unless (equal (image-size self) best-fit-sz)
-          ;;(print `(texture-name> tex-refit ,(image-size self) to ,best-fit-sz)) ;; frgo: debug...
+          (print `(texture-name> tex-refit ,(image-size self) to ,best-fit-sz)) ;; frgo: debug...
           (magick-scale-image (mgk-wand self) (car best-fit-sz) (cdr best-fit-sz))
 ;;; gaussian-filter 0)
           (setf (image-size self) best-fit-sz))
         
-       ;; (print `(texture-name> new image size , self ,(image-size self))) ;; frgo: debug...
+        (print `(texture-name> new image size , self ,(image-size self))) ;; frgo: debug...
         (let ((tx (wand-image-to-texture self)))
           (if (plusp tx)
               (setf (texture-name self) tx)
@@ -70,7 +70,7 @@
 				       (cdr (image-size self)))))
     ;;(assert (not *ogl-listing-p*))
     (assert (plusp tx))
-    ;;(cells:trc "!!!!wand-image-to-texture genning new tx: ~a" tx) ;; frgo: debug...
+    (cells:trc "!!!!wand-image-to-texture genning new tx: ~a" tx) ;; frgo: debug...
     (gl-bind-texture gl_texture_2d tx)
       
     (progn ;; useless??