Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv2070/cl-magick
Modified Files: cl-magick.lisp cl-magick.lpr drawing-wand.lisp magick-wand.lisp mgk-utils.lisp pixel-wand.lisp wand-image.lisp wand-pixels.lisp wand-texture.lisp Log Message:
--- /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/11/13 05:29:28 1.14 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2007/02/02 20:11:09 1.15 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-magick; -*- ;;; -;;; Copyright © 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal @@ -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.14 2006/11/13 05:29:28 ktilton Exp $ +;;; $Id: cl-magick.lisp,v 1.15 2007/02/02 20:11:09 ktilton Exp $
(defpackage :cl-magick @@ -28,9 +28,10 @@ (:use #:common-lisp #:gui-geometry - #-(or cormanlisp ccl sbcl) #:clos + #-(or cormanlisp ccl sbcl openmcl) #:clos #:cffi #:cffi-extender + #:utils-kt #+kt-opengl #:kt-opengl ;; wands as opengl textures ) @@ -70,7 +71,9 @@ (defparameter *mgk-version* (fgn-alloc :unsigned-long 1))
(cffi:define-foreign-library Magick - (:darwin (:or "/usr/local/lib/libMagick.dylib")) + (: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")))
@@ -105,21 +108,21 @@ do (wand-release (cdr wand))) (setf (wands-loaded) nil))
-(defun wand-ensure-typed (wand-type file-path$ &rest iargs) - (when file-path$ +(defun wand-ensure-typed (wand-type path &rest iargs) + (when path (cl-magick-init) - (let ((key (list* wand-type (namestring file-path$) iargs))) + (let ((key (list* wand-type (namestring path) iargs))) (or (let ((old (cdr (assoc key (wands-loaded) :test 'equal)))) - #+shhh (when old - (print `(wand-ensure-typed re-using-prior-load ,wand-type ,file-path$))) + #+shhh (when old + (format t "!&wand-ensure-typed re-using cached ~a ~a" path wand-type)) old) (let ((wi (apply 'make-instance wand-type - :file-path$ file-path$ + :image-path path iargs))) - ;;(print `(wand-ensure-typed forced-to-load ,wand-type ,file-path$)) + ;;(print `(wand-ensure-typed forced-to-load ,wand-type ,path)) (push (cons key wi) (wands-loaded)) wi) - (error "Unable to load image file ~a" file-path$))))) + (error "Unable to load image file ~a" path)))))
#+allegro (defun xim () --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2006/11/13 05:29:28 1.9 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2007/02/02 20:11:09 1.10 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jan 29, 2007 18:02)"; cg: "1.81"; -*-
(in-package :cg-user)
--- /project/cello/cvsroot/cello/cl-magick/drawing-wand.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-magick/drawing-wand.lisp 2007/02/02 20:11:09 1.2 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-magick; -*- ;;; -;;; Copyright © 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal --- /project/cello/cvsroot/cello/cl-magick/magick-wand.lisp 2006/08/21 04:28:28 1.3 +++ /project/cello/cvsroot/cello/cl-magick/magick-wand.lisp 2007/02/02 20:11:09 1.4 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-magick; -*- ;;; -;;; Copyright © 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal --- /project/cello/cvsroot/cello/cl-magick/mgk-utils.lisp 2006/07/06 22:09:11 1.2 +++ /project/cello/cvsroot/cello/cl-magick/mgk-utils.lisp 2007/02/02 20:11:09 1.3 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-magick; -*- ;;; -;;; Copyright © 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal @@ -36,7 +36,7 @@ (wand-images-write (recording-wand recording) (namestring (recording-pathname recording)) - 1)) + t))
(defun recording-destroy (recording) (when (recording-wand recording) @@ -94,7 +94,7 @@ (error "MagickSetImagePixels failed preparing ~a" (namestring path$)) (magick-flip-image wand)))))
-(defun wand-images-write (mgk-wand path$ adjoin) +(defun wand-images-write (mgk-wand path$ &optional adjoin) (print `(wand-images-write ,(magick-get-image-index mgk-wand))) (when (zerop (magick-write-images mgk-wand (namestring path$) (if adjoin 1 0))) - (error "MagickWriteImage failed writing ~a" (namestring path$)))) \ No newline at end of file + (break "MagickWriteImage failed writing ~a" (namestring path$)))) \ No newline at end of file --- /project/cello/cvsroot/cello/cl-magick/pixel-wand.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-magick/pixel-wand.lisp 2007/02/02 20:11:09 1.2 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-magick; -*- ;;; -;;; Copyright © 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal --- /project/cello/cvsroot/cello/cl-magick/wand-image.lisp 2006/10/02 02:59:18 1.9 +++ /project/cello/cvsroot/cello/cl-magick/wand-image.lisp 2007/02/02 20:11:09 1.10 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-magick; -*- ;;; -;;; Copyright © 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal @@ -22,15 +22,19 @@
(in-package :cl-magick)
+(export! wand-direction image-path image-size tilep) + (defclass wand-image () - ((direction :initarg :direction :initform :input :accessor direction) - (file-path$ :initarg :file-path$ :initform nil :accessor file-path$) + ((wand-direction :initarg :wand-direction :initform :input :accessor wand-direction) + (image-path :initarg :image-path :initform nil :accessor image-path) (mgk-wand :initarg :mgk-wand :initform nil :accessor mgk-wand) (image-size :initarg :image-size :initform nil :accessor image-size) - (tile-p :initarg :tile-p :initform t :accessor tile-p))) + (storage :initarg :storage :initform GL_RGB :accessor storage) + (tilep :initarg :tilep :initform t :accessor tilep) + ))
(defmethod initialize-instance :after ((self wand-image) &key) - (ecase (direction self) + (ecase (wand-direction self) (:output (progn (assert (pixels self)) (assert (image-size self)) @@ -42,11 +46,11 @@ (magick-set-image-type (mgk-wand self) 3) )) (:input - (assert (probe-file (file-path$ self)) () - "Image file ~a not found initializing wand" (file-path$ self)) + (assert (probe-file (image-path self)) () + "Image file ~a not found initializing wand" (image-path self)) (assert (not (mgk-wand self))) ;; make sure not leaking - (setf (mgk-wand self) (path-to-wand (file-path$ self))) - ;;(mgk-wand-dump (mgk-wand self) (file-path$ self)) + (setf (mgk-wand self) (path-to-wand (image-path self))) + ;;(mgk-wand-dump (mgk-wand self) (image-path self)) (when (and (mgk-wand self) (not (image-size self))) (setf (image-size self) (cons (magick-get-image-width (mgk-wand self)) @@ -67,70 +71,93 @@ (assert (probe-file p)) (let ((stat (magick-read-image wand p))) (if (zerop stat) - (format t "~&magick-read jpeg failed on ~a" p) - #+shhh (format t "~&magick-read-OK ~a" p))) - wand)) - -(defparameter *mgk-columns* - (fgn-alloc :unsigned-long 1 :ignore)) - -(defparameter *mgk-rows* - (fgn-alloc :unsigned-long 1 :ignore)) - -(defun wand-image-size (wand) - (magick-get-size wand - *mgk-columns* - *mgk-rows*) - (cons (ff-elt *mgk-columns* :unsigned-long 0) - (ff-elt *mgk-rows* :unsigned-long 0))) - -(defun wand-get-image-pixels (wand - &optional (first-col 0) (first-row 0) - (last-col (magick-get-image-width wand)) - (last-row (magick-get-image-height wand))) + (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))))) + +(defun wand-get-image-pixels (self &optional (first-col 0) (first-row 0) + (last-col (magick-get-image-width (mgk-wand self))) + (last-row (magick-get-image-height (mgk-wand self))) + &aux (wand (mgk-wand self)) + (bytes-per-pixel (ecase (storage self) (#.gl_rgb 3)(#.gl_rgba 4)))) + (declare (fixnum bytes-per-pixel)) (if (zerop (* last-col last-row)) (let* ((columns 64)(rows 64) - (pixels (fgn-alloc :unsigned-char (* 3 columns rows) :wand-image))) + (pixels (fgn-alloc :unsigned-char (* bytes-per-pixel columns rows) :wand-image))) (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)) - + (let* ((columns (- last-col first-col)) (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 nil "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"))) - #+shhh (progn + (fmt (intern (string-upcase (magick-get-image-format wand)) :mgk)) + (storage$ (ecase (storage self) (#.gl_rgb "RGB")(#.gl_rgba "RGBA"))) + (pixels (fgn-alloc :unsigned-char (* bytes-per-pixel columns rows) :wand-image))) + (declare (ignorable fmt)) + (assert (not (null-pointer-p pixels))() "wand-get-image-pixels > fgn-alloc of ~a bytes failed" (* bytes-per-pixel columns rows)) + #+shhh (cells:trc nil "cols, rows, image format" last-col last-row wand fmt bytes-per-pixel storage$) + + + (magick-get-image-pixels wand first-col first-row columns rows storage$ 0 pixels ) + + #+shhh (cells:trc "doing cols rows image!!!!!!!!!!!!!" rows columns (* columns rows) + :img-type (magick-get-image-type (mgk-wand self))) + + + (when (find fmt '(gif png)) ; - ; look at a few pixels + ; fix alpha channel which gets written out inverted for some strange reason I forget ; - (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))))) - + (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) + (return-from detect-converted t))) + (cells:trc "converting alpha channel!!!!!!!!!!!!!!!!!!!" self) + + (loop with pix1 + for row fixnum below rows + do (loop for pixel-col fixnum below columns + for pixel-offset fixnum = (the fixnum (+ 3 (the fixnum (* (+ (* row columns) pixel-col) bytes-per-pixel)))) + do (let ((alpha (eltuc pixels pixel-offset))) + (unless pix1 + (when (zerop alpha) + (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))) + + finally + ; + ; in place... + ; + (magick-set-image-pixels wand 0 0 columns rows storage$ 0 pixels) + (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)) + (setf (image-size self) (cons columns rows)) + (magick-resize-image wand columns rows cubic-filter 0) + (wand-images-write wand (image-path self)))) + ; + ; flopped... + ; + (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-flop-image cw) + (wand-images-write cw (merge-pathnames (conc$ (pathname-name (image-path self)) "-flop") + (image-path self))) + (cells:trc "local magick" (list columns rows) + (list (magick-get-image-width wand) + (magick-get-image-height wand))))))) + (values pixels columns rows))))
--- /project/cello/cvsroot/cello/cl-magick/wand-pixels.lisp 2006/08/21 04:28:28 1.3 +++ /project/cello/cvsroot/cello/cl-magick/wand-pixels.lisp 2007/02/02 20:11:09 1.4 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-magick; -*- ;;; -;;; Copyright © 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal @@ -26,9 +26,10 @@ ((pixels :initarg :pixels :accessor pixels :initform nil)))
(defmethod initialize-instance :after ((self wand-pixels) &key) - (when (and (mgk-wand self) (eql :input (direction self))) + (when (and (mgk-wand self) (eql :input (wand-direction self))) (magick-flip-image (mgk-wand self)) - (setf (pixels self) (wand-get-image-pixels (mgk-wand self))))) + (cells::trc "getting pixels for" (image-path self)) + (setf (pixels self) (wand-get-image-pixels self))))
(defmethod wand-release :after ((wand wand-pixels)) (when (pixels wand) @@ -46,7 +47,7 @@ (let ((y-move (downs (+ 0 (abs (- top bottom)))))) (with-bitmap-shifted (0 y-move) (cells:trc nil "wand-render pixels move" 0 y-move :top top :bottom bottom) - + (if (ogl-get-boolean gl_current_raster_position_valid) (progn #+shh (format t "~&rasterpos ~a OK: ~a" @@ -55,7 +56,7 @@ (ogl-raster-pos-get) self )) #+wait (gl-pixel-zoom (/ (- right left) (car sz)) (/ (abs (- top bottom)) (cdr sz))) - #+not (print (list "draw pixels sz, lbox" left right (file-path$ self) sz + #+not (print (list "draw pixels sz, lbox" left right (image-path self) sz :tby top bottom y-move))
#+shh (unless (zerop (gl-is-enabled gl_scissor_test)) @@ -67,13 +68,18 @@ ;(gl-scalef 1000 1000 1000) ;(gl-disable gl_scissor_test) ;; debugging try (gl-enable gl_blend) ;; debugging try - (gl-blend-func gl_src_alpha gl_one) - (gl-blend-func gl_dst_alpha gl_one_minus_src_alpha) + ;(gl-blend-func gl_src_alpha gl_one) + ;(gl-blend-func gl_dst_alpha gl_one_minus_src_alpha) + (gl-blend-func gl_src_alpha gl_one_minus_src_alpha) ;;(cells:trc "drew pixels " gl_src_alpha gl_zero) (gl-polygon-mode gl_front_and_back gl_fill) #+not (cells:trc nil "wand-pixelling" (ogl-raster-pos-get)) (gl-pixel-storei gl_unpack_alignment 1) - (gl-draw-pixels (+ (car sz) 0) (cdr sz) - gl_rgb gl_unsigned_byte (pixels self)) - (ogl::glec :draw-pixels)))) \ No newline at end of file + (storage self) gl_unsigned_byte (pixels self)) + (ogl::gl-pixel-transferf gl_alpha_scale 1) + (ogl::glec :draw-pixels)))) + + + + --- /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2006/10/13 05:57:27 1.8 +++ /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2007/02/02 20:11:10 1.9 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-magick; -*- ;;; -;;; Copyright © 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal @@ -37,23 +37,33 @@
(defmethod texture-name :around ((self wand-texture)) (or (call-next-method) - (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)) ;; 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... - (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 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))))))
(defun wand-texture-activate (wand) @@ -63,11 +73,9 @@ (defparameter *textures-1* (fgn-alloc 'kt-opengl::gluint 1 :ignore))
(defun wand-image-to-texture (self) - (let ((tx (ogl-texture-gen) #+not (progn (gl-gen-textures 1 *textures-1*) - (ff-elt *textures-1* gluint 0))) - (pixels (wand-get-image-pixels (mgk-wand self) 0 0 - (car (image-size self)) - (cdr (image-size self))))) + ;;(cells::trcx wand-image-to-texture (image-path self)) + (let ((tx (ogl-texture-gen)) + (pixels (wand-get-image-pixels self))) ;;(assert (not *ogl-listing-p*)) (assert (plusp tx)) (cells:trc nil "!!!!wand-image-to-texture genning new tx: ~a" tx) ;; frgo: debug... @@ -82,30 +90,50 @@
(gl-pixel-storei gl_pack_alignment 1 ) (gl-pixel-storei gl_unpack_alignment 1 ) - - (gllog :texture tx (* 3 (car (image-size self)) (cdr (image-size self))) :wim2tex) - (gl-tex-image2d gl_texture_2d 0 3 (car (image-size self)) (cdr (image-size self)) - 0 gl_rgb gl_unsigned_byte pixels) + + (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) + ;;(print `(wand-image-to-texture loaded texture sized ,(image-size self))) ;; frgo: debug...
(fgn-free pixels) tx)) + +#| + +To avoid changing the texture, use GL_MODULATE mode (glTexEnv) +and use glColor4f (1.0, 1.0, 1.0, alpha). + +This multiplies 'alpha' by the alpha in the RGBA texture map +before blending into the frame buffer. The constants you mentioned +are for that later blending stage. + +|#
(defmethod wand-render ((self wand-texture) left top right bottom &aux (sz (image-size self))) - #+not (cells:trc nil "wand-render tex-name:" (texture-name self) (tile-p self) self + #+not (cells:trc nil "wand-render tex-name:" (texture-name self) (tilep self) self :size sz :bbox (list left top right bottom))
- (with-attrib (gl_texture_bit) ;; gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) + (with-attrib (gl_texture_bit gl_color_buffer_bit) ;; gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) (wand-texture-activate self) - #+slower - (ogl-tex-gen-setup gl_object_linear gl_modulate - (if (tile-p self) gl_repeat gl_clamp) + + (gl-enable gl_blend) + (gl-blend-func gl_src_alpha gl_one_minus_src_alpha) + + (gl-enable gl_alpha_test) + (gl-alpha-func gl_greater 0.0) + + #+not + (progn + (ogl-tex-gen-setup gl_object_linear gl_modulate + (if (tilep self) gl_repeat gl_clamp) (/ 1 (max (car sz)(cdr sz))) :s :tee :r) - - (if (tile-p self) + (gl-rectf left top right bottom)) + + (if (tilep self) (with-gl-begun (gl_quads) (loop for y from top above bottom by (cdr sz) for y-rem = (- bottom y)