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)
