Update of /project/cells/cvsroot/cell-cultures/cello In directory common-lisp.net:/tmp/cvs-serv2293/cello
Modified Files: cello-ftgl.lisp cello-magick.lisp image.lisp ix-render.lisp ix-text.lisp window-callbacks.lisp window.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:06 2004 Author: ktilton
Index: cell-cultures/cello/cello-ftgl.lisp diff -u cell-cultures/cello/cello-ftgl.lisp:1.2 cell-cultures/cello/cello-ftgl.lisp:1.3 --- cell-cultures/cello/cello-ftgl.lisp:1.2 Wed Sep 29 04:50:09 2004 +++ cell-cultures/cello/cello-ftgl.lisp Fri Oct 1 06:01:05 2004 @@ -247,7 +247,7 @@ (trc nil "ix-render-in-font ftgl-texture" :pxy (pxy self) (l-rect self) t$)
(gl-enable gl_texture_2d) - (trc "(gl-is-enabled gl_texture_2d)!!!!!!!" (gl-is-enabled gl_texture_2d) + (trc nil "(gl-is-enabled gl_texture_2d)!!!!!!!" (gl-is-enabled gl_texture_2d) (ogl-get-boolean gl_texture_2d)) ;;(assert (ogl-get-boolean gl_texture_2d)) (gl-disable gl_lighting)
Index: cell-cultures/cello/cello-magick.lisp diff -u cell-cultures/cello/cello-magick.lisp:1.1 cell-cultures/cello/cello-magick.lisp:1.2 --- cell-cultures/cello/cello-magick.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/cello-magick.lisp Fri Oct 1 06:01:05 2004 @@ -81,8 +81,9 @@ (defparameter *mapping-textures* nil)
(defun ix-render-wand (wand l-box) - (when wand - (apply 'wand-render wand (r-bounds l-box)))) + (if wand + (apply 'wand-render wand (r-bounds l-box)) + (trc "ix-render-wand sees no wand" l-box)))
;;;(defun wand-centered-bounds (wand size) ;;; (let* ((raw-w (magick-get-image-width (^mgk-wand)))
Index: cell-cultures/cello/image.lisp diff -u cell-cultures/cello/image.lisp:1.3 cell-cultures/cello/image.lisp:1.4 --- cell-cultures/cello/image.lisp:1.3 Wed Sep 29 04:50:09 2004 +++ cell-cultures/cello/image.lisp Fri Oct 1 06:01:05 2004 @@ -48,11 +48,12 @@ (trc nil "display-list-name" display-list-name self)
(gl-new-list display-list-name gl_compile) - + (trc nil "starting display list" display-list-name self) (let ((*ogl-listing-p* self) *selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*) (with-metrics (nil nil "(funcall renderer)" self) (ix-paint self))) + (trc nil "finished display list" display-list-name self) (gl-end-list) (setf (redisplayp *window-rendering*) t) display-list-name))))
Index: cell-cultures/cello/ix-render.lisp diff -u cell-cultures/cello/ix-render.lisp:1.2 cell-cultures/cello/ix-render.lisp:1.3 --- cell-cultures/cello/ix-render.lisp:1.2 Wed Sep 29 04:50:09 2004 +++ cell-cultures/cello/ix-render.lisp Fri Oct 1 06:01:05 2004 @@ -81,47 +81,46 @@
(let ((ixr-box (mkr 0 0 0 0))) (defmethod ix-paint :around ((self image) &aux (n (gl-name self))) - (gl-translatef (px self) (py self) 0) - (ogl-pen-move (px self) (py self)) ; /// combine former in here? - - (when n - (trc nil "gl-name" self n) - (gl-push-name n)) - - (rpchk 'ix-paint t nil self) - (when (and (not (c-stopped)) - (or (not *selecting*) - (ix-selectable self)) - (visible self) - (not (collapsed self))) - (with-clipping (self) - (progn ;; with-attrib (gl_lighting_bit gl_texture_bit gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) - (count-it :ix-render) - #+not (count-it :ix-render (type-of self)) - #+not (unless (kids self) - (count-it :ix-render-atom)) - (trc nil "ix painting" self) - (trc nil "ix-render around rendering" self) - (with-matrix () - (with-ogl-isolation - (case (lighting self) ;; default is "same as parent" - (:on (gl-enable gl_lighting)) - (:off (gl-disable gl_lighting))) - - (gl-enable gl_color_material) - - (bif (pre-layer (pre-layer self)) - (progn - (assert (functionp pre-layer)) - (count-it :pre-layer) - (nr-make ixr-box (ll self) (lt self) (lr self) (lb self)) - (funcall pre-layer self ixr-box :before) - (call-next-method self) - (funcall pre-layer self ixr-box :after)) - (call-next-method self))))))) - (gl-translatef (- (px self)) (- (py self)) 0) - (ogl-pen-move (- (px self)) (- (py self))) - + (with-bitmap-shifted ((px self)(py self)) + (gl-translatef (px self) (py self) 0) + + + (when n + (trc nil "gl-name" self n) + (gl-push-name n)) + + (rpchk 'ix-paint t nil self) + (when (and (not (c-stopped)) + (or (not *selecting*) + (ix-selectable self)) + (visible self) + (not (collapsed self))) + (with-clipping (self) + (progn ;; with-attrib (gl_lighting_bit gl_texture_bit gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) + (count-it :ix-render) + #+not (count-it :ix-render (type-of self)) + #+not (unless (kids self) + (count-it :ix-render-atom)) + (trc nil "ix painting" self) + (with-matrix () + (with-ogl-isolation + (case (lighting self) ;; default is "same as parent" + (:on (gl-enable gl_lighting)) + (:off (gl-disable gl_lighting))) + + (gl-enable gl_color_material) + + (bif (pre-layer (pre-layer self)) + (progn + (assert (functionp pre-layer)) + (count-it :pre-layer) + (nr-make ixr-box (ll self) (lt self) (lr self) (lb self)) + (funcall pre-layer self ixr-box :before) + (call-next-method self) + (funcall pre-layer self ixr-box :after)) + (call-next-method self))))))) + (gl-translatef (- (px self)) (- (py self)) 0)) + (when n (gl-pop-name))))
Index: cell-cultures/cello/ix-text.lisp diff -u cell-cultures/cello/ix-text.lisp:1.2 cell-cultures/cello/ix-text.lisp:1.3 --- cell-cultures/cello/ix-text.lisp:1.2 Wed Sep 29 04:50:09 2004 +++ cell-cultures/cello/ix-text.lisp Fri Oct 1 06:01:05 2004 @@ -112,15 +112,13 @@ (ty (+ (lb self) (v2-v (inset self)) (round (glut-bitmap-y-orig (font-ffi-glut-id font))))))
- (ogl-pen-move tx ty) + (with-bitmap-shifted (tx ty)
- #+shh (if (ogl-get-boolean gl_current_raster_position_valid) - (trc "rasterpos ok" self :g-offset (g-offset self)) - (trc "rasterpos offscreen" self :g-offset (g-offset self))) - (trc nil "raster pos valid?" (ogl-get-boolean gl_current_raster_position_valid)) - (glut-bitmap-string (font-ffi-glut-id font) t$) - (ogl-pen-move (- tx) (- ty)) - ))) + #+shh (if (ogl-get-boolean gl_current_raster_position_valid) + (trc "rasterpos ok" self :g-offset (g-offset self)) + (trc "rasterpos offscreen" self :g-offset (g-offset self))) + (trc nil "raster pos valid?" (ogl-get-boolean gl_current_raster_position_valid)) + (glut-bitmap-string (font-ffi-glut-id font) t$)))))
(defmethod ix-render-in-font ((font font-glut-stroke) self) (bwhen (t$ (^display-text$))
Index: cell-cultures/cello/window-callbacks.lisp diff -u cell-cultures/cello/window-callbacks.lisp:1.2 cell-cultures/cello/window-callbacks.lisp:1.3 --- cell-cultures/cello/window-callbacks.lisp:1.2 Wed Sep 29 04:50:09 2004 +++ cell-cultures/cello/window-callbacks.lisp Fri Oct 1 06:01:05 2004 @@ -102,7 +102,11 @@ (window-display *w*))))
(defmethod window-display ((self window)) - (ix-paint self) ;; (gl-call-list (dsp-list self)) + + (bif (dl (dsp-list self)) + (gl-call-list (dsp-list self)) + (ix-paint self)) + (glut-swap-buffers)
(incf (frame-ct self))
Index: cell-cultures/cello/window.lisp diff -u cell-cultures/cello/window.lisp:1.2 cell-cultures/cello/window.lisp:1.3 --- cell-cultures/cello/window.lisp:1.2 Wed Sep 29 04:50:09 2004 +++ cell-cultures/cello/window.lisp Fri Oct 1 06:01:05 2004 @@ -294,7 +294,7 @@ (glm gl_max_viewport_dims #x3386 ) )
- (trc nil "glutw-create'd window XY" (glut-get-window) self :from (glut-xy self) :to + (trc "glutw-create'd window XY" (glut-get-window) self :from (glut-xy self) :to (list (glut-get glut_window_x)(glut-get glut_window_y) (glut-get glut_window_width)(glut-get glut_window_height)))
@@ -437,15 +437,13 @@ (progn ;; with-render-lock ((glut-get-window)) (glutmainloopevent) ) - (sleep 0.1) - )))) + (sleep 0.1)))))
- -(defmethod ix-paint ((self window)) +(defmethod ix-paint :around ((self window)) (flet ((projection () (gl-matrix-mode gl_projection) (gl-load-identity) - (trc nil "win ortho! l r b t n f:" + (trc nil "paint> win ortho! l r b t n f:" (ll self)(lr self) (lb self)(lt self) *mgw-near* *mgw-far*) @@ -459,18 +457,15 @@ (gl-matrix-mode gl_model-view) (gl-load-identity) (gl-light-modeli gl_light_model_two_side 0) - (ogl-pen-init) - (ogl-pen-move 0 (ups (l-height self))) - - (when (clear-rgba self) - (apply #'gl-clear-color (clear-rgba self))) - - (gl-clear (+ gl_color_buffer_bit gl_depth_buffer_bit)) - (with-metrics (nil nil "ix-paint window call next") - (call-next-method)) - (ogl-pen-move 0 (downs (l-height self))) - ))
+ (with-bitmap-shifted (0 (ups (l-height self))) + (trc nil "with initial window shift, rasterpos now" (ogl-raster-pos-get)) + (when (clear-rgba self) + (apply #'gl-clear-color (clear-rgba self))) + + (gl-clear (+ gl_color_buffer_bit gl_depth_buffer_bit)) + (with-metrics (nil nil "ix-paint window call next") + (call-next-method)))))
(defun w-quadric-ensure (key) (or (cdr (assoc key (quadrics *window-rendering*)))