Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv7403/cl-magick
Modified Files: cl-magick.lisp cl-magick.lpr mgk-utils.lisp wand-image.lisp wand-texture.lisp Log Message:
--- /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2007/02/02 20:11:09 1.15 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2008/04/11 09:23:01 1.16 @@ -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.15 2007/02/02 20:11:09 ktilton Exp $ +;;; $Id: cl-magick.lisp,v 1.16 2008/04/11 09:23:01 ktilton Exp $
(defpackage :cl-magick @@ -71,11 +71,14 @@ (defparameter *mgk-version* (fgn-alloc :unsigned-long 1))
(cffi:define-foreign-library Magick - (:darwin #-(and)(:framework "GraphicsMagick") - "libGraphicsMagick.dylib" - "libGraphicsMagickWand.dylib") - (:windows (:or #+not "C:\Program Files\ImageMagick-6.2.7-Q8\CORE_RL_wand_.dll" - "C:\Program Files\GraphicsMagick-1.1.7-Q8\CORE_RL_wand_.dll"))) +;;; patches welcomes on this next bit +;;; (:darwin #-(and)(:framework "GraphicsMagick") +;;; "libGraphicsMagick.dylib" +;;; "libGraphicsMagickWand.dylib") + (:windows (:or "CORE_RL_wand_.dll" ))) + +#+test +(probe-file (cells:exe-dll "CORE_RL_wand_"))
(cffi:define-foreign-library Wand (:darwin (:or "/usr/local/lib/libWand.dylib"))) @@ -85,6 +88,7 @@ #+macosx (cffi:use-foreign-library Wand)
+ (cffi:use-foreign-library Magick)
;------------------------------------------------------------------- @@ -108,6 +112,9 @@ do (wand-release (cdr wand))) (setf (wands-loaded) nil))
+#+doit +(wands-clear) + (defun wand-ensure-typed (wand-type path &rest iargs) (when path (cl-magick-init) --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2007/02/02 20:11:09 1.10 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2008/04/11 09:23:02 1.11 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jan 29, 2007 18:02)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Mar 7, 2007 14:53)"; cg: "1.81"; -*-
(in-package :cg-user)
--- /project/cello/cvsroot/cello/cl-magick/mgk-utils.lisp 2007/02/02 20:11:09 1.3 +++ /project/cello/cvsroot/cello/cl-magick/mgk-utils.lisp 2008/04/11 09:23:02 1.4 @@ -66,8 +66,9 @@ ;;; gaussian-filter ;; /// any faster? mode doesn't matter, about to stomp pix ;;; 0))
- (if (zerop (magick-set-image-pixels wand 0 0 - width height "RGB" short-pixel pixels)) + (if (zerop ;; the GM doc seems in error when it says zero is success + (magick-set-image-pixels wand 0 0 + width height "RGB" short-pixel pixels)) (error "MagickSetImagePixels failed: ~a" wand) (magick-flip-image wand) ;; /// necessary? ) --- /project/cello/cvsroot/cello/cl-magick/wand-image.lisp 2007/02/02 20:11:09 1.10 +++ /project/cello/cvsroot/cello/cl-magick/wand-image.lisp 2008/04/11 09:23:02 1.11 @@ -30,8 +30,7 @@ (mgk-wand :initarg :mgk-wand :initform nil :accessor mgk-wand) (image-size :initarg :image-size :initform nil :accessor image-size) (storage :initarg :storage :initform GL_RGB :accessor storage) - (tilep :initarg :tilep :initform t :accessor tilep) - )) + (tilep :initarg :tilep :initform t :accessor tilep)))
(defmethod initialize-instance :after ((self wand-image) &key) (ecase (wand-direction self) @@ -40,11 +39,11 @@ (assert (image-size self)) (setf (mgk-wand self) (new-magick-wand)) (destructuring-bind (columns . rows) (image-size self) - (assert (zerop (magick-set-image-pixels - (setf (mgk-wand self) (new-magick-wand)) - 0 0 columns rows "CRGB" 3 (pixels self))))) - (magick-set-image-type (mgk-wand self) 3) - )) + (progn ;; assert (zerop ... well, the doc says zero=sucess, but not the GM.c code (or flop writes) + (magick-set-image-pixels + (setf (mgk-wand self) (new-magick-wand)) + 0 0 columns rows "CRGB" 3 (pixels self)))) + (magick-set-image-type (mgk-wand self) 3))) (:input (assert (probe-file (image-path self)) () "Image file ~a not found initializing wand" (image-path self)) @@ -62,8 +61,7 @@ (when (mgk-wand wand) ;(print (list "destroying magick wand" wand)) ;(describe wand) - (destroy-magick-wand (mgk-wand wand)) - )) + (destroy-magick-wand (mgk-wand wand))))
(defun path-to-wand (path) (let ((wand (new-magick-wand)) @@ -71,10 +69,9 @@ (assert (probe-file p)) (let ((stat (magick-read-image wand p))) (if (zerop stat) - (format t "~&magick-read-image failed on ~a" p) ;; and return NIL ;; kt 2006-11-21 - (progn - #+shhh (format t "~&magick-read-OK ~a" p) - wand))))) + (format t "~&magick-read-image failed on ~a" p) + (format nil "~&magick-read-OK ~a" p)) + wand)))
(defun wand-get-image-pixels (self &optional (first-col 0) (first-row 0) (last-col (magick-get-image-width (mgk-wand self))) @@ -113,10 +110,13 @@ (unless (block detect-converted (loop for pixel-col fixnum below columns for pixel-offset fixnum = (the fixnum (+ 3 (* pixel-col bytes-per-pixel))) - when (/= 255 (eltuc pixels (the fixnum pixel-offset))) - do (cells:trc "image alpha already converted. I see non-255" (eltuc pixels (the fixnum pixel-offset)) :at-col pixel-col) + when (> 96 ;; rough guess at how to detect: can't always get perfect alpha w eraser: /= 255 + (eltuc pixels (the fixnum pixel-offset))) + do (cells:trc "image alpha already converted. I see non-255" + (image-path self) + (eltuc pixels (the fixnum pixel-offset)) :at-col pixel-col) (return-from detect-converted t))) - (cells:trc "converting alpha channel!!!!!!!!!!!!!!!!!!!" self) + ;;(cells:trc "converting alpha channel!!!!!!!!!!!!!!!!!!!" self)
(loop with pix1 for row fixnum below rows @@ -125,7 +125,7 @@ do (let ((alpha (eltuc pixels pixel-offset))) (unless pix1 (when (zerop alpha) - (cells::trcx binogo-pix1 pixel-col row) + ;;(cells::trcx binogo-pix1 pixel-col row) (setf pix1 (cons pixel-col row)))) (setf (eltuc pixels (the fixnum pixel-offset)) (- 255 alpha)))) ;;when (zerop (eltuc pixels (the fixnum pixel-offset))) @@ -135,7 +135,7 @@ ; in place... ; (magick-set-image-pixels wand 0 0 columns rows storage$ 0 pixels) - (let ((reduction (max 1 (sqrt (/ (* columns rows) 200000))))) + #+no(let ((reduction (max 1 (sqrt (/ (* columns rows) 200000))))) (unless (= reduction 1) (cells:trc "reduction factor!!!!!!!" reduction) (setf columns (round columns reduction) rows (round rows reduction)) @@ -148,9 +148,7 @@ (let ((cw (clone-magick-wand wand))) (magick-set-image-type cw (magick-get-image-type wand)) (magick-get-image-pixels wand 0 0 columns rows storage$ 0 pixels ) ;; get resized pixels - (let ((e (magick-set-image-pixels cw 0 0 columns rows storage$ 0 pixels))) - (unless (zerop e) - (cells:trc "Error setting pixels!!!!!!!!" e))) + (magick-set-image-pixels cw 0 0 columns rows storage$ 0 pixels)
(magick-flop-image cw) (wand-images-write cw (merge-pathnames (conc$ (pathname-name (image-path self)) "-flop") --- /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2007/02/02 20:11:10 1.9 +++ /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2008/04/11 09:23:02 1.10 @@ -37,33 +37,33 @@
(defmethod texture-name :around ((self wand-texture)) (or (call-next-method) - (let ((tx (wand-image-to-texture self))) - (if (plusp tx) - (setf (texture-name self) tx) - (break "bad tx name ~a for ~a" tx self))))) - -;;; -;;; this next stuff converts image to 2^n dimensions and may still be necessary -;;; on older graphics cards. /// test for this on old or lame PCs -;;; -;;; (let* ((trunc-sz (cons (expt 2 (floor (log (car (image-size self)) 2))) -;;; (expt 2 (floor (log (cdr (image-size self)) 2))))) -;;; (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... -;;; -;;; (unless t ;; (equal (image-size self) best-fit-sz) -;;; ;(print `(texture-name> tex-refit ,(image-size self) to ,best-fit-sz)) -;;; (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... -;;; (let ((tx (wand-image-to-texture self))) -;;; (if (plusp tx) -;;; (setf (texture-name self) tx) -;;; (break "bad tx name ~a for ~a" tx self)))))) + ;;; (let ((tx (wand-image-to-texture self))) + ;;; (if (plusp tx) + ;;; (setf (texture-name self) tx) + ;;; (break "bad tx name ~a for ~a" tx self))))) + + ;;; + ;;; this next stuff converts image to 2^n dimensions and may still be necessary + ;;; on older graphics cards. /// test for this on old or lame PCs + ;;; + (let* ((trunc-sz (cons (expt 2 (floor (log (car (image-size self)) 2))) + (expt 2 (floor (log (cdr (image-size self)) 2))))) + (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... + + (unless (equal (image-size self) best-fit-sz) + ;(print `(texture-name> tex-refit ,(image-size self) to ,best-fit-sz)) + (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... + (let ((tx (wand-image-to-texture self))) + (if (plusp tx) + (setf (texture-name self) tx) + (break "bad tx name ~a for ~a" tx self))))))
(defun wand-texture-activate (wand) @@ -90,7 +90,8 @@
(gl-pixel-storei gl_pack_alignment 1 ) (gl-pixel-storei gl_unpack_alignment 1 ) - + (cells::trc nil "wand-image-to-texture> tex-iage2d-ing" (image-path self)(image-size self)) + (kt-opengl::glec :tex-image-before) (gl-tex-image2d gl_texture_2d 0 gl_rgba (car (image-size self)) (cdr (image-size self)) 0 (storage self) gl_unsigned_byte pixels) (kt-opengl::glec :tex-image)
-
ktilton