[cello-cvs] CVS cello/cl-magick
fgoenninger
fgoenninger at common-lisp.net
Wed Aug 23 20:20:27 UTC 2006
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
More information about the Cello-cvs
mailing list