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