Update of /project/cells/cvsroot/cell-cultures/cl-magick In directory common-lisp.net:/tmp/cvs-serv2293/cl-magick
Modified Files: cl-magick.lpr mgk-test.lisp wand-image.lisp wand-pixels.lisp wand-texture.lisp Log Message: A couple of simple fixes to get the pixel and texture wands (GraphicksMagic stuff) working again and now Cello is pretty much back in business. Date: Fri Oct 1 06:01:20 2004 Author: ktilton
Index: cell-cultures/cl-magick/cl-magick.lpr diff -u cell-cultures/cl-magick/cl-magick.lpr:1.1 cell-cultures/cl-magick/cl-magick.lpr:1.2 --- cell-cultures/cl-magick/cl-magick.lpr:1.1 Sat Jun 26 20:38:39 2004 +++ cell-cultures/cl-magick/cl-magick.lpr Fri Oct 1 06:01:19 2004 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "6.2 [Windows] (Jun 26, 2002 11:39)"; common-graphics: "1.389.2.105.2.14"; -*- +;; -*- lisp-version: "6.2 [Windows] (Sep 3, 2004 12:04)"; common-graphics: "1.389.2.105.2.14"; -*-
(in-package :common-graphics-user)
Index: cell-cultures/cl-magick/mgk-test.lisp diff -u cell-cultures/cl-magick/mgk-test.lisp:1.1 cell-cultures/cl-magick/mgk-test.lisp:1.2 --- cell-cultures/cl-magick/mgk-test.lisp:1.1 Sat Jun 26 20:38:39 2004 +++ cell-cultures/cl-magick/mgk-test.lisp Fri Oct 1 06:01:19 2004 @@ -208,6 +208,7 @@ ) )))
+(defvar *grace*)
(defun r6w () (gl-load-identity) @@ -258,7 +259,8 @@ (gl-tex-coord2f 1 0) (v3f -1 -1 1) (gl-tex-coord2f 1 1) (v3f -1 1 1) (gl-tex-coord2f 0 1) (v3f -1 1 -1) - ))) + )) + (wand-render *grace* 0 0 1 -1)) (glut-swap-buffers) (glut-post-redisplay) ) @@ -281,7 +283,9 @@ (gl-depth-func gl_lequal) (gl-hint gl_perspective_correction_hint gl_nicest) (setf *skin6* (mgk:wand-ensure-typed 'wand-texture - (test-image 'jmcbw512 'jpg)))) + (clo::demo-image-file 'shapers "jmcbw512.jpg"))) + (setf *grace* (mgk:wand-ensure-typed 'wand-pixels + (clo::demo-image-file 'shapers "grace.jpg"))))
#+test @@ -300,26 +304,27 @@ (gl-load-identity)))
(defun cl-magick-test () - (wands-clear) - (setf *skin6* nil) - - (cl-glut-init) - (glut-set-option glut_action_on_window_close glut_action_glutmainloop_returns) - - (glut-init-display-mode (+ glut_rgb glut_double)) ;; Display Mode (Rgb And Double Buffered) - (glut-init-window-size wcx wcy) ;; Window Size If We Start In Windowed Mode - - (let ((key "NeHe's OpenGL Framework")) - (uffi:with-cstring (key-native key) - (glut-create-window key-native))) - - (r6init) - (r6reshape wcx wcy) - - (glut-display-func (ff-register-callable 'r6wffx)) - (glut-reshape-func (ff-register-callable 'r6-reshape)) - (glut-keyboard-func (ff-register-callable 'mgwkey)) - (glutmainloop)) + (let ((ogl::*gl-begun* nil)) + (wands-clear) + (setf *skin6* nil) + + (cl-glut-init) + (glut-set-option glut_action_on_window_close glut_action_glutmainloop_returns) + + (glut-init-display-mode (+ glut_rgb glut_double)) ;; Display Mode (Rgb And Double Buffered) + (glut-init-window-size wcx wcy) ;; Window Size If We Start In Windowed Mode + + (let ((key "NeHe's OpenGL Framework")) + (uffi:with-cstring (key-native key) + (glut-create-window key-native))) + + (r6init) + (r6reshape wcx wcy) + + (glut-display-func (ff-register-callable 'r6wffx)) + (glut-reshape-func (ff-register-callable 'r6-reshape)) + (glut-keyboard-func (ff-register-callable 'mgwkey)) + (glutmainloop)))
#+test (cl-magic-test)
Index: cell-cultures/cl-magick/wand-image.lisp diff -u cell-cultures/cl-magick/wand-image.lisp:1.1 cell-cultures/cl-magick/wand-image.lisp:1.2 --- cell-cultures/cl-magick/wand-image.lisp:1.1 Sat Jun 26 20:38:39 2004 +++ cell-cultures/cl-magick/wand-image.lisp Fri Oct 1 06:01:19 2004 @@ -94,22 +94,23 @@ (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))) - (let* ((columns (- last-col first-col)) - (rows (- last-row first-row)) - (pixels (fgn-alloc :unsigned-char (* 3 columns rows) :wand-image))) - ;;(print (list "wand-get-image-pixels got" (* 3 columns rows) pixels)) - (uffi:with-cstring (rgbc "RGB") - (magick-get-image-pixels wand first-col first-row columns rows rgbc 0 pixels )) - #+works (progn - (uffi:with-cstring (cpath "C:\TEST.JPG") ;; p) - (print `(writeimage ,(magick-write-image wand cpath)))) - (uffi:with-cstring (cpath "C:\TEST.GIF") ;; p) - (print `(writeimage ,(magick-write-image wand cpath)))) - (uffi:with-cstring (cpath "C:\TEST.BMP") ;; p) - (print `(writeimage ,(magick-write-image wand cpath))))) - - (values pixels columns rows))) + &optional (first-col 0) (first-row 0) + (last-col (magick-get-image-width wand)) + (last-row (magick-get-image-height wand))) + (let* ((columns (- last-col first-col)) + (rows (- last-row first-row)) + (pixels (fgn-alloc :unsigned-char (* 3 columns rows) :wand-image))) + ;;(print (list "wand-get-image-pixels got" wand (* 3 columns rows) pixels)) + (uffi:with-cstring (rgbc "RGB") + (magick-get-image-pixels wand first-col first-row columns rows rgbc 0 pixels )) + #+testing (progn + (incf testn) + (uffi:with-cstring (cpath (format nil "C:\TEST~a.JPG" testn)) ;; p) + (print `(writeimage ,(magick-write-image wand cpath)))) + (uffi:with-cstring (cpath (format nil "C:\TEST~a.GIF" testn)) ;; p) + (print `(writeimage ,(magick-write-image wand cpath)))) + #+not (uffi:with-cstring (cpath "C:\TEST.BMP") ;; p) + (print `(writeimage ,(magick-write-image wand cpath))))) + + (values pixels columns rows)))
Index: cell-cultures/cl-magick/wand-pixels.lisp diff -u cell-cultures/cl-magick/wand-pixels.lisp:1.1 cell-cultures/cl-magick/wand-pixels.lisp:1.2 --- cell-cultures/cl-magick/wand-pixels.lisp:1.1 Sat Jun 26 20:38:39 2004 +++ cell-cultures/cl-magick/wand-pixels.lisp Fri Oct 1 06:01:19 2004 @@ -39,34 +39,37 @@ "only works in ortho mode I think; abstract out raster-pos for perspective" (declare (ignorable right left)) (assert (pixels self)) - + (ukt::trc nil "!!!! pixelrender entry rasterpos:" + (ogl-raster-pos-get) :lrtb (list left right top bottom) + :image-sz sz) (let ((y-move (downs (+ 0 (abs (- top bottom)))))) - (gl-disable gl_texture_2d) - (gl-disable gl_blend) - ;;(clo::trc "wand-render move" 0 y-move top bottom (- top bottom)) - (ogl-pen-move 0 y-move) - - (if (ogl-get-boolean gl_current_raster_position_valid) - (progn #+not (format nil "~&rasterpos ~a OK: ~a" - (ogl-raster-pos-get)ogl::*ogl-pen* #+nah (list left right top bottom) )) - (format t "~&in ~a rasterpos ~a invalid, goffset is ???" - (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 - :tby top bottom y-move)) + (with-bitmap-shifted (0 y-move) + (clo::trc nil "wand-render pixels move" 0 y-move :top top :bottom bottom) + #+hush + (if (ogl-get-boolean gl_current_raster_position_valid) + (progn + (format t "~&rasterpos ~a OK: ~a" + (ogl-raster-pos-get) (list left right top bottom) )) + (format t "~&in wand-render rasterpos ~a invalid, goffset is ???" + (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 + :tby top bottom y-move))
- (unless (zerop (gl-is-enabled gl_scissor_test)) - (print `(scissor-box2 ,(ogl-bounds (ogl-scissor-box))))) - ;;(gl-disable GL_LIGHTING) - ;;(gl-disable GL_COLOR_MATERIAL) - ;;(gl-disable GL_DEPTH_TEST) - ;;(gl-disable GL_cull_face - ;;(gl-scalef 1000 1000 1000) - (gl-blend-func gl_src_alpha gl_one_minus_src_alpha) - (gl-polygon-mode gl_front_and_back gl_fill) - ;;(cells::trc nil "wand-pixelling" ogl::*ogl-pen* (ogl-raster-pos-get)) - (gl-draw-pixels (car sz) (cdr sz) - gl_rgb gl_unsigned_byte (pixels self)) - (ogl::glec :draw-pixels) - (ogl-pen-move 0 (- y-move)))) \ No newline at end of file + #+shh (unless (zerop (gl-is-enabled gl_scissor_test)) + (print `(scissor-box2 ,(ogl-bounds (ogl-scissor-box))))) + (gl-disable GL_LIGHTING) + (gl-disable GL_COLOR_MATERIAL) + (gl-disable GL_DEPTH_TEST) + (gl-disable GL_cull_face) + ;(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_minus_src_alpha) + (gl-polygon-mode gl_front_and_back gl_fill) + (cells::trc nil "wand-pixelling" (ogl-raster-pos-get)) + + (gl-draw-pixels (car sz) (cdr sz) + gl_rgb gl_unsigned_byte (pixels self)) + (ogl::glec :draw-pixels)))) \ No newline at end of file
Index: cell-cultures/cl-magick/wand-texture.lisp diff -u cell-cultures/cl-magick/wand-texture.lisp:1.2 cell-cultures/cl-magick/wand-texture.lisp:1.3 --- cell-cultures/cl-magick/wand-texture.lisp:1.2 Sun Jul 4 20:59:44 2004 +++ cell-cultures/cl-magick/wand-texture.lisp Fri Oct 1 06:01:19 2004 @@ -38,22 +38,25 @@ (cons (bfit (car c1)(car c2)(car c3)) (bfit (cdr c1)(cdr c2)(cdr c3)))))
- (defmethod initialize-instance :after ((self wand-texture) &key) - (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))) - (unless (equal (image-size self) best-fit-sz) - ;;(print `(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 `(new image size ,(image-size self))) - (setf (texture-name self) - (wand-image-to-texture self)) - )) + (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))) + (unless (equal (image-size self) best-fit-sz) + ;;(print `(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 `(new image size ,(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)))))) +
(defun wand-texture-activate (wand) ;(print `(wand-texture-activate ,(texture-name wand))) @@ -61,12 +64,14 @@
(defparameter *textures-1* (fgn-alloc 'gluint 1 :ignore)) (defun wand-image-to-texture (self) - (let ((tx (progn (gl-gen-textures 1 *textures-1*) - (ff-elt *textures-1* gluint 0))) + (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)) + (ukt::trc "!!!!wand-image-to-texture genning new tx:" tx) (gl-bind-texture gl_texture_2d tx)
(progn ;; useless?? @@ -90,12 +95,12 @@
(defmethod wand-render ((self wand-texture) left top right bottom &aux (sz (image-size self))) - #+not (format t "~&wand-render tex ~a ~a ~a" (texture-name self) self - :size sz :bbox (list left top right bottom)) - ;;(assert *ogl-listing-p*) - (with-attrib (gl_texture_bit);; gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) + (ukt::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) - #+tilingworksbutslower + #+slower (ogl-tex-gen-setup gl_object_linear gl_modulate (if (tile-p self) gl_repeat gl_clamp) (/ 1 (max (car sz)(cdr sz))) @@ -108,7 +113,7 @@
do (loop for x from left below right by (car sz) for x-rem = (- right x) - do ;(print `(tex tiling ,x ,y)) + do ;; (print `(tex tiling ,x ,y))
(flet ((vxy (tx ty) (let ((x-fraction (min tx (/ x-rem (car sz)))) @@ -120,13 +125,10 @@ (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 + ))))R \ No newline at end of file