[cello-cvs] CVS cello/cl-magick
ktilton
ktilton at common-lisp.net
Fri Apr 11 09:23:06 UTC 2008
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)
More information about the Cello-cvs
mailing list