[cells-cvs] CVS update: cell-cultures/cl-magick/cl-magick.lpr cell-cultures/cl-magick/mgk-test.lisp cell-cultures/cl-magick/wand-image.lisp cell-cultures/cl-magick/wand-pixels.lisp cell-cultures/cl-magick/wand-texture.lisp

Kenny Tilton ktilton at common-lisp.net
Fri Oct 1 04:01:29 UTC 2004


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





More information about the Cells-cvs mailing list