[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