Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv30632

Modified Files: wand-texture.lisp Log Message: Changed: Removed enclosing progn from file. All code was inside this progn. Why ?

--- /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2006/08/21 04:28:28 1.4 +++ /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2006/08/23 20:20:27 1.5 @@ -22,114 +22,111 @@

(in-package :cl-magick)

+(defclass wand-texture (wand-image ogl-texture)())

-(progn +(defmethod wand-release :after ((wand wand-texture)) + (when (slot-value wand 'texture-name) + (ogl-texture-delete (slot-value wand 'texture-name)))) + +(defun best-fit-cons (c1 c2 c3) + (flet ((bfit (a b c) + (if (> (/ c b)(/ b a)) + a c))) + (cons (bfit (car c1)(car c2)(car c3)) + (bfit (cdr c1)(cdr c2)(cdr c3)))))

- (defclass wand-texture (wand-image ogl-texture)()) - - (defmethod wand-release :after ((wand wand-texture)) - (when (slot-value wand 'texture-name) - (ogl-texture-delete (slot-value wand 'texture-name)))) - - (defun best-fit-cons (c1 c2 c3) - (flet ((bfit (a b c) - (if (> (/ c b)(/ b a)) - a c))) - (cons (bfit (car c1)(car c2)(car c3)) - (bfit (cdr c1)(cdr c2)(cdr c3))))) - - (defmethod texture-name :around ((self wand-texture)) - (or (call-next-method) +(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))))) + (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))))) + (expt 2 (ceiling (log (cdr (image-size self)) 2))))) (best-fit-sz (best-fit-cons trunc-sz (image-size self) grow-sz))) - #+shh (print `(texture-name> gennning texture ,self)) + #+shh (print `(texture-name> gennning texture ,self)) (unless (equal (image-size self) best-fit-sz) #+shhh (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) +;;; gaussian-filter 0) (setf (image-size self) best-fit-sz))

#+shhh (print `(texture-name> new image size , self ,(image-size 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)))))) + (break "bad tx name ~a for ~a" tx self))))))

- (defun wand-texture-activate (wand) - ;(print `(wand-texture-activate ,(texture-name wand))) - (ogl-tex-activate (texture-name wand))) - - (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))))) - ;; (assert (not *ogl-listing-p*)) - (assert (plusp tx)) - ;; (cells:trc "!!!!wand-image-to-texture genning new tx: ~a" tx) - (gl-bind-texture gl_texture_2d tx) +(defun wand-texture-activate (wand) + ;(print `(wand-texture-activate ,(texture-name wand))) + (ogl-tex-activate (texture-name wand))) + +(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))))) + ;; (assert (not *ogl-listing-p*)) + (assert (plusp tx)) + ;; (cells:trc "!!!!wand-image-to-texture genning new tx: ~a" tx) + (gl-bind-texture gl_texture_2d tx)

- (progn ;; useless?? - (gl-tex-parameteri gl_texture_2d gl_texture_wrap_s gl_repeat) - (gl-tex-parameteri gl_texture_2d gl_texture_wrap_t gl_repeat) ;-- + (progn ;; useless?? + (gl-tex-parameteri gl_texture_2d gl_texture_wrap_s gl_repeat) + (gl-tex-parameteri gl_texture_2d gl_texture_wrap_t gl_repeat) ;--

- (gl-tex-parameterf gl_texture_2d gl_texture_min_filter gl_linear ) - (gl-tex-parameterf gl_texture_2d gl_texture_mag_filter gl_linear )) + (gl-tex-parameterf gl_texture_2d gl_texture_min_filter gl_linear ) + (gl-tex-parameterf gl_texture_2d gl_texture_mag_filter gl_linear ))

- (gl-pixel-storei gl_pack_alignment 1 ) - (gl-pixel-storei gl_unpack_alignment 1 ) + (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) - (kt-opengl::glec :tex-image) - ;;(print `(wand-image-to-texture loaded texture sized ,(image-size self))) + (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) + (kt-opengl::glec :tex-image) + ;;(print `(wand-image-to-texture loaded texture sized ,(image-size self)))

- (fgn-free pixels) - tx)) + (fgn-free pixels) + tx))

- (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 - :size sz :bbox (list left top right bottom)) +(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 + :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) - (wand-texture-activate self) - #+slower - (ogl-tex-gen-setup gl_object_linear gl_modulate - (if (tile-p self) gl_repeat gl_clamp) - (/ 1 (max (car sz)(cdr sz))) - :s :tee :r) + (with-attrib (gl_texture_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) + (/ 1 (max (car sz)(cdr sz))) + :s :tee :r)

- (if (tile-p self) - (with-gl-begun (gl_quads) - (loop for y from top above bottom by (cdr sz) - for y-rem = (- bottom y) + (if (tile-p self) + (with-gl-begun (gl_quads) + (loop for y from top above bottom by (cdr sz) + for y-rem = (- bottom y)

- do (loop for x from left below right by (car sz) - for x-rem = (- right x) - do ;; (print `(tex tiling ,x ,y)) + do (loop for x from left below right by (car sz) + for x-rem = (- right x) + do ;; (print `(tex tiling ,x ,y))

- (flet ((vxy (tx ty) - (let ((x-fraction (min tx (/ x-rem (car sz)))) - (y-fraction (min ty (abs (/ y-rem (cdr sz)))))) - (gl-tex-coord2f x-fraction y-fraction) - (gl-vertex3f (+ x (* x-fraction (car sz))) - (+ y (downs (* y-fraction (cdr sz)))) 0)))) - (vxy 0 0)(vxy 1 0)(vxy 1 1)(vxy 0 1))))) + (flet ((vxy (tx ty) + (let ((x-fraction (min tx (/ x-rem (car sz)))) + (y-fraction (min ty (abs (/ y-rem (cdr sz)))))) + (gl-tex-coord2f x-fraction y-fraction) + (gl-vertex3f (+ x (* x-fraction (car sz))) + (+ y (downs (* y-fraction (cdr sz)))) 0)))) + (vxy 0 0)(vxy 1 0)(vxy 1 1)(vxy 0 1))))) (flet ((vxy (tx ty) (let ((abs-x (+ left (* tx (- right left)))) (abs-y (+ top (downs (* ty (abs (- top bottom))))))) - ;(print `(tex full,(cons tx ty) to-vertex ,(cons abs-x abs-y))) + ;(print `(tex full,(cons tx ty) to-vertex ,(cons abs-x abs-y))) (gl-tex-coord2f tx ty) (gl-vertex3f abs-x abs-y 0))))

(with-gl-begun (gl_quads) (vxy 0 0)(vxy 0 1)(vxy 1 1)(vxy 1 0))) - )))) \ No newline at end of file + ))) \ No newline at end of file