From ktilton at common-lisp.net Fri Oct 1 04:01:10 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 01 Oct 2004 06:01:10 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cello/cello-ftgl.lisp cell-cultures/cello/cello-magick.lisp cell-cultures/cello/image.lisp cell-cultures/cello/ix-render.lisp cell-cultures/cello/ix-text.lisp cell-cultures/cello/window-callbacks.lisp cell-cultures/cello/window.lisp Message-ID: 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*))) From ktilton at common-lisp.net Fri Oct 1 04:01:13 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 01 Oct 2004 06:01:13 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cellodemo/cellodemo.lisp cell-cultures/cellodemo/demo-window.lisp cell-cultures/cellodemo/tutor-geometry.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cellodemo In directory common-lisp.net:/tmp/cvs-serv2293/cellodemo Modified Files: cellodemo.lisp demo-window.lisp tutor-geometry.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:10 2004 Author: ktilton Index: cell-cultures/cellodemo/cellodemo.lisp diff -u cell-cultures/cellodemo/cellodemo.lisp:1.1 cell-cultures/cellodemo/cellodemo.lisp:1.2 --- cell-cultures/cellodemo/cellodemo.lisp:1.1 Sat Jun 26 20:38:35 2004 +++ cell-cultures/cellodemo/cellodemo.lisp Fri Oct 1 06:01:10 2004 @@ -42,22 +42,19 @@ :kids (c? (the-kids (a-row (:px 96 :py (downs 96)) (mk-part :imk-jpg (ix-image-file) + :pre-layer (c? (with-layers +red+ :fill (:wand (^wander)))) :md-value (c? (demo-image-file "shapers" "grace.jpg"))) (a-stack () - (loop for n below 10 + (loop for face in '(antquabi bookosb + georgiai framd times + gothic impact + lucon micross + palab) collect (mk-part :xxx (ix-text) - :text-font (let ((myn n)) - (c? (font-ftgl-ensure :texture - (or (elt '(antquabi bookosb - georgiai framd times - gothic impact - lucon micross - palab) - myn) - *gui-style-default-face*) - 24))) - :text$ "Hello, world!"))) - ) + :pre-layer (with-layers (:rgba +white+)) + :text-font (let ((myface face)) + (c? (font-ftgl-ensure :texture myface 24))) + :text$ "Hello, world!")))) (mk-part :zee (ix-text) :md-value (c? (if (visible (fm-other :ft-jpg)) (without-c-dependency (frame-ct .w.)) 0)) @@ -65,17 +62,17 @@ :justify-hz :center :py (c? (py-maintain-pt (pb (psib)))) :pre-layer (with-layers (:out 1500) +blue+) - :zoom (c? (if (without-c-dependency (< 200 (- (frame-ct .w.) (^md-value)))) + :zoom (c? (let ((start (^md-value))) + (if (without-c-dependency (< 200 (- (frame-ct .w.) start))) .cache - (progn (trc "zooming") - (make-list 3 :initial-element (min 2.0 (/ (- (frame-ct .w.) (^md-value)) + (make-list 3 :initial-element (min 2.0 (/ (- (frame-ct .w.) start) 100.0)))))) - :rotation (c? (if (without-c-dependency (< 200 (- (frame-ct .w.) (^md-value)))) + :rotation (c? (let ((start (^md-value))) + (if (without-c-dependency (< 200 (- (frame-ct .w.) start))) .cache - (progn - (trc "rotating") - (list (* 360 (/ (min 200 (- (frame-ct .w.) (^md-value))) 100.0)) + (list (* 360 (/ (min 200 (- (frame-ct .w.) start)) 100.0)) 1 1 1)))) + :text-font (c? (font-ftgl-ensure :texture *gui-style-default-face* 24 )) - :text$ "Hello, world!"))))) + :text$ "hello, world!"))))) Index: cell-cultures/cellodemo/demo-window.lisp diff -u cell-cultures/cellodemo/demo-window.lisp:1.2 cell-cultures/cellodemo/demo-window.lisp:1.3 --- cell-cultures/cellodemo/demo-window.lisp:1.2 Wed Sep 29 04:50:11 2004 +++ cell-cultures/cellodemo/demo-window.lisp Fri Oct 1 06:01:10 2004 @@ -30,9 +30,9 @@ :skin (c? (wand-ensure-typed 'wand-texture (car (md-value (fm-other :texture-picker))))) :focus (c-in nil) - :display-continuous (c-in nil) + :display-continuous (c-in t) :clear-rgba (list 0 0 0 1) - :lb (c-in (downs 750))))) + :lb (c-in (downs 650))))) (defun demo-scroller () (mk-part :demo-scroller (ig-zero-tl) @@ -85,22 +85,12 @@ (make-instance 'gui-style-ftgl :id :button :face *gui-style-button-face* - :sizes '(12 12 12 12 12) - :text-color +white+) - (make-instance 'gui-style-ftgl - :id :label - :face *gui-style-button-face* :sizes '(14 14 14 14 14) :text-color +white+) (make-instance 'gui-style-ftgl - :id :unique - :face *gui-style-button-face* - :sizes '(24 24 24 24 24) - :text-color +white+) - (make-instance 'gui-style-ftgl - :id :unique2 + :id :label :face *gui-style-button-face* - :sizes '(18 18 18 18 18) + :sizes '(12 12 12 12 12) :text-color +white+) (make-instance 'gui-style-ftgl :id :default @@ -145,7 +135,7 @@ :name "bingo" :type "mpg") *user-temp-directory*)))) - ;;;:display-continuous t + :display-continuous nil :md-name :demo-w :title$ "Hello, world" :skin nil @@ -160,7 +150,7 @@ :directory `(:relative "graphics" "out") :name (format nil "snap-me-~3,,,'0 at A" (snapshot-release-id self)) - :type "png") + :type "jpg") cl-user::*devel-root*)) :pre-layer (c? (with-layers @@ -245,7 +235,7 @@ (a-stack (:spacing (u16ths 1)) (texture-picker) (demo-picker)) - #+nah (a-stack (:spacing (u96ths 6) + (a-stack (:spacing (u96ths 6) :justify :center :outset (u96ths 6) :visible (c? (not (snapshot-release-id .w.))) Index: cell-cultures/cellodemo/tutor-geometry.lisp diff -u cell-cultures/cellodemo/tutor-geometry.lisp:1.1 cell-cultures/cellodemo/tutor-geometry.lisp:1.2 --- cell-cultures/cellodemo/tutor-geometry.lisp:1.1 Sat Jun 26 20:38:35 2004 +++ cell-cultures/cellodemo/tutor-geometry.lisp Fri Oct 1 06:01:10 2004 @@ -36,11 +36,9 @@ :pre-layer (c? (with-layers (:disable gl_texture_2d) :off - (:line-width 3) + (:line-width 2) (:rgba (^skin)) - :line-frame - (:poly-mode gl_front_and_back gl_fill) - (:rect -2 -2 2 2))) + :line-frame)) deets))) (the-kids (tu-box :ftgrow From ktilton at common-lisp.net Fri Oct 1 04:01:20 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 01 Oct 2004 06:01:20 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cl-ftgl/cl-ftgl.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cl-ftgl In directory common-lisp.net:/tmp/cvs-serv2293/cl-ftgl Modified Files: cl-ftgl.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:13 2004 Author: ktilton Index: cell-cultures/cl-ftgl/cl-ftgl.lisp diff -u cell-cultures/cl-ftgl/cl-ftgl.lisp:1.3 cell-cultures/cl-ftgl/cl-ftgl.lisp:1.4 --- cell-cultures/cl-ftgl/cl-ftgl.lisp:1.3 Wed Sep 29 04:50:43 2004 +++ cell-cultures/cl-ftgl/cl-ftgl.lisp Fri Oct 1 06:01:12 2004 @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Header: /project/cells/cvsroot/cell-cultures/cl-ftgl/cl-ftgl.lisp,v 1.3 2004/09/29 02:50:43 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/cell-cultures/cl-ftgl/cl-ftgl.lisp,v 1.4 2004/10/01 04:01:12 ktilton Exp $ (defpackage #:cl-ftgl (:nicknames #:ftgl) @@ -461,7 +461,7 @@ (setf (ftgl-ifont font) (ftgl-font-make font)))) (defun ftgl-font-make (font) - (print (list "ftgl-font-make entry" font)) + ;;(print (list "ftgl-font-make entry" font)) (let ((path (merge-pathnames (make-pathname :name (string (ftgl-face font)) :type "ttf") *font-directory-path*))) @@ -478,13 +478,6 @@ (defun ftgl-render (font s) (let ((df (ftgl-get-display-font font))) - (when (typep font 'ftgl-texture) - (assert cello::*w*) - (ukt::trc "ftgl-render sees texture,font" - (fgc-char-texture df (char-code #\a)) font - (gl-is-texture (fgc-char-texture df (char-code #\a))) - (gl-is-enabled gl_texture_2d))) - (uffi:with-cstring (cs s) (fgc-render df cs)))) From ktilton at common-lisp.net Fri Oct 1 04:01:29 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 01 Oct 2004 06:01:29 +0200 Subject: [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 Message-ID: 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 From ktilton at common-lisp.net Fri Oct 1 04:01:38 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 01 Oct 2004 06:01:38 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cl-opengl/cl-opengl.lisp cell-cultures/cl-opengl/gl-def.lisp cell-cultures/cl-opengl/gl-functions.lisp cell-cultures/cl-opengl/glut-extras.lisp cell-cultures/cl-opengl/ogl-macros.lisp cell-cultures/cl-opengl/ogl-utils.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cl-opengl In directory common-lisp.net:/tmp/cvs-serv2293/cl-opengl Modified Files: cl-opengl.lisp gl-def.lisp gl-functions.lisp glut-extras.lisp ogl-macros.lisp ogl-utils.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:29 2004 Author: ktilton Index: cell-cultures/cl-opengl/cl-opengl.lisp diff -u cell-cultures/cl-opengl/cl-opengl.lisp:1.2 cell-cultures/cl-opengl/cl-opengl.lisp:1.3 --- cell-cultures/cl-opengl/cl-opengl.lisp:1.2 Sun Jul 4 20:59:45 2004 +++ cell-cultures/cl-opengl/cl-opengl.lisp Fri Oct 1 06:01:29 2004 @@ -58,7 +58,7 @@ #:ups #:ups-most #:ups-more #:downs #:downs-most #:downs-more #:farther #:nearer #:ogl-texture-delete #:ogl-texture-gen #:ogl-tex-gen-setup #:ogl-bounds #:ogl-scissor-box #:ogl-raster-pos-get - #:ogl-pen-move #:ogl-pen-init #:ogl-pen #:ogl-pen-x #:ogl-pen-y + #:ogl-pen-move #:with-bitmap-shifted #:texture-name #:ogl-list-cache #:ogl-lists-delete #:eltgli #:ogl-tex-activate #:gl-name)) Index: cell-cultures/cl-opengl/gl-def.lisp diff -u cell-cultures/cl-opengl/gl-def.lisp:1.1 cell-cultures/cl-opengl/gl-def.lisp:1.2 --- cell-cultures/cl-opengl/gl-def.lisp:1.1 Sat Jun 26 20:38:41 2004 +++ cell-cultures/cl-opengl/gl-def.lisp Fri Oct 1 06:01:29 2004 @@ -26,7 +26,7 @@ `(defun-ffx ,rtn ,module$ ,name$ (, at type-args) (progn ;;(cells::count-it ,(intern (string-upcase name$) :keyword)) - (glec ',rtn)))) + (glec ',(intern name$))))) (defun aforef (o n) (uffi:deref-array o '(:array :int) n)) Index: cell-cultures/cl-opengl/gl-functions.lisp diff -u cell-cultures/cl-opengl/gl-functions.lisp:1.2 cell-cultures/cl-opengl/gl-functions.lisp:1.3 --- cell-cultures/cl-opengl/gl-functions.lisp:1.2 Sun Jul 4 20:59:45 2004 +++ cell-cultures/cl-opengl/gl-functions.lisp Fri Oct 1 06:01:29 2004 @@ -169,6 +169,7 @@ (defun-ffx :void "open-gl" "glGenTextures" (glsizei n gluint *textures)) (defun-ffx :void "open-gl" "glBindTexture" (glenum target gluint texture)) (defun-ffx :void "open-gl" "glDeleteTextures" (glsizei n gluint *textures)) +(defun-ffx :int "open-gl" "glIsTexture" (gluint textureName)) @@ -373,13 +374,11 @@ (defun-ogl :void "open-gl" "glPixelZoom" (glfloat xfactor glfloat yfactor)) #| display lists |# -(defun-ogl glboolean "open-gl" "glIsList" (gluint list)) +(defun-ogl :int "open-gl" "glIsList" (gluint list)) (defun-ogl :void "open-gl" "glDeleteLists" (gluint list glsizei range )) (defun-ogl gluint "open-gl" "glGenLists" (glsizei range )) (defun-ogl :void "open-gl" "glNewList" (gluint list glenum mode )) (defun-ogl :void "open-gl" "glEndList" ()) (defun-ogl :void "open-gl" "glCallList" (gluint list )) (defun-ogl :void "open-gl" "glCallLists" (glsizei n glenum type glvoid *lists)) - - (defun-ogl :void "open-gl" "glListBase" (gluint base)) Index: cell-cultures/cl-opengl/glut-extras.lisp diff -u cell-cultures/cl-opengl/glut-extras.lisp:1.1 cell-cultures/cl-opengl/glut-extras.lisp:1.2 --- cell-cultures/cl-opengl/glut-extras.lisp:1.1 Sat Jun 26 20:38:41 2004 +++ cell-cultures/cl-opengl/glut-extras.lisp Fri Oct 1 06:01:29 2004 @@ -37,6 +37,7 @@ (setf *glut-dll* nil *opengl-dll* nil) (ff:unload-foreign-library dll))))) +(defparameter *mg-glut-display-busy* nil) (defun cl-glut-init () (cl-opengl-init) @@ -60,7 +61,8 @@ (print "glut initialised") ) (fgn-free argc)))) - (print "Glut already initialized")))) + (print "Glut already initialized")) + (setf *mg-glut-display-busy* nil))) (defvar *mdepth*) (defvar *selecting*) Index: cell-cultures/cl-opengl/ogl-macros.lisp diff -u cell-cultures/cl-opengl/ogl-macros.lisp:1.1 cell-cultures/cl-opengl/ogl-macros.lisp:1.2 --- cell-cultures/cl-opengl/ogl-macros.lisp:1.1 Sat Jun 26 20:38:41 2004 +++ cell-cultures/cl-opengl/ogl-macros.lisp Fri Oct 1 06:01:29 2004 @@ -100,8 +100,6 @@ (defun cl-opengl-init () (declare (ignorable load-oglfont-p)) - - (unless *opengl-dll* (print "loading open GL/GLU") (uffi:load-foreign-library @@ -112,7 +110,7 @@ :module "gl-util")))) (defun glec (&optional (id :anon)) - (unless *gl-begun* + (unless (and (boundp '*gl-begun*) *gl-begun*) (let ((e (glgeterror))) (if (zerop e) (unless t ;; (find id '(glutcheckloop glutgetwindow)) Index: cell-cultures/cl-opengl/ogl-utils.lisp diff -u cell-cultures/cl-opengl/ogl-utils.lisp:1.1 cell-cultures/cl-opengl/ogl-utils.lisp:1.2 --- cell-cultures/cl-opengl/ogl-utils.lisp:1.1 Sat Jun 26 20:38:41 2004 +++ cell-cultures/cl-opengl/ogl-utils.lisp Fri Oct 1 06:01:29 2004 @@ -42,11 +42,12 @@ (defun ogl-texture-gen () (gl-gen-textures 1 *textures-1*) + (glec :ogl-texture-gen) (ff-elt *textures-1* gluint 0)) (let (gl-s-plane gl-t-plane gl-r-plane gl-q-plane) (defun ogl-tex-gen-setup (mode tex-env tex-wrap scale &rest planes) - ;(print `(ogl-tex-gen-setup ,mode ,tex-wrap)) + (ukt::trc nil "ogl-tex-gen-setup:" mode tex-env tex-wrap scale planes) (gl-tex-envf gl_texture_env gl_texture_env_mode tex-env) (gl-tex-parameterf gl_texture_2d gl_texture_min_filter gl_linear ) (gl-tex-parameterf gl_texture_2d gl_texture_mag_filter gl_linear ) @@ -192,28 +193,17 @@ (defun ogl-raster-pos-get () (gl-get-ints-4 gl_current_raster_position)) -(defparameter *ogl-pen* nil) - -(defun ogl-pen () - *ogl-pen*) - -(defun ogl-pen-x () - (car *ogl-pen*)) - -(defun ogl-pen-y () - (cadr *ogl-pen*)) - -(defun ogl-pen-init () - (setq *ogl-pen* (ogl-raster-pos-get)) - ;;(print (list "ogl-pen-init" :to *ogl-pen*)) - (values)) +(defmacro with-bitmap-shifted ((x y) &body body) + (let ((xy (gensym))) + `(let ((,xy (cons ,x ,y))) + (ogl-pen-move (car ,xy) (cdr ,xy)) + (prog1 + (progn , at body) + (ogl-pen-move (- (car ,xy)) (- (cdr ,xy))))))) (defun ogl-pen-move (x y) - ;(incf (car *ogl-pen*) x) - ;(incf (cadr *ogl-pen*) y) - ;(print (list "ogl-pen-move" x y)) - ;(print (list "in synch?" *ogl-pen* (ogl-raster-pos-get))) - (gl-bitmap 0 0 0 0 (+ x) (+ y))) + ;;(ukt::trc "ogl-pen-moving" x y) + (gl-bitmap 0 0 0 0 x y)) (defclass ogl-texture () ((texture-name :accessor texture-name :initform nil) From ktilton at common-lisp.net Fri Oct 1 04:01:40 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 01 Oct 2004 06:01:40 +0200 Subject: [cells-cvs] CVS update: cell-cultures/config/cl-ftgl-config.lisp cell-cultures/config/cl-magick-config.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/config In directory common-lisp.net:/tmp/cvs-serv2293/config Modified Files: cl-ftgl-config.lisp cl-magick-config.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:38 2004 Author: ktilton Index: cell-cultures/config/cl-ftgl-config.lisp diff -u cell-cultures/config/cl-ftgl-config.lisp:1.1 cell-cultures/config/cl-ftgl-config.lisp:1.2 --- cell-cultures/config/cl-ftgl-config.lisp:1.1 Sat Jun 26 20:38:41 2004 +++ cell-cultures/config/cl-ftgl-config.lisp Fri Oct 1 06:01:32 2004 @@ -24,7 +24,7 @@ (setq *ftgl-dynamic-lib-path* (merge-pathnames - (make-pathname :name "ftgl_dynamic_MTD" + (make-pathname :name "ftgl_dynamic_MTD_d" :type "dll") cl-user::*cello-dynlib-directory*)) Index: cell-cultures/config/cl-magick-config.lisp diff -u cell-cultures/config/cl-magick-config.lisp:1.1 cell-cultures/config/cl-magick-config.lisp:1.2 --- cell-cultures/config/cl-magick-config.lisp:1.1 Sat Jun 26 20:38:41 2004 +++ cell-cultures/config/cl-magick-config.lisp Fri Oct 1 06:01:32 2004 @@ -34,7 +34,7 @@ (setq *cl-magick-source-directory* (merge-pathnames - (make-pathname :directory '(:relative "cello" "cl-magick")) + (make-pathname :directory '(:relative "cl-magick")) cl-user::*devel-root*)) (setq *magick-wand-templates* From ktilton at common-lisp.net Fri Oct 15 03:37:33 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 15 Oct 2004 05:37:33 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cellodemo/cellodemo.lisp cell-cultures/cellodemo/demo-window.lisp cell-cultures/cellodemo/hedron-decoration.lisp cell-cultures/cellodemo/hedron-render.lisp cell-cultures/cellodemo/light-panel.lisp cell-cultures/cellodemo/tutor-geometry.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cellodemo In directory common-lisp.net:/tmp/cvs-serv28025/cellodemo Modified Files: cellodemo.lisp demo-window.lisp hedron-decoration.lisp hedron-render.lisp light-panel.lisp tutor-geometry.lisp Log Message: Re-write of the core layout widgets under the ix-inline class, plus a new OpenGL example, viz., a simple nurb. Looks sweet, btw. Date: Fri Oct 15 05:37:31 2004 Author: ktilton Index: cell-cultures/cellodemo/cellodemo.lisp diff -u cell-cultures/cellodemo/cellodemo.lisp:1.2 cell-cultures/cellodemo/cellodemo.lisp:1.3 --- cell-cultures/cellodemo/cellodemo.lisp:1.2 Fri Oct 1 06:01:10 2004 +++ cell-cultures/cellodemo/cellodemo.lisp Fri Oct 15 05:37:30 2004 @@ -37,7 +37,7 @@ (demo-image-subdir subdir))) (defun ft-jpg () - (mk-part :ft-jpg (ig-zero-tl) + (mk-part :ft-jpg (ix-zero-tl) :px 0 :py 0 :kids (c? (the-kids (a-row (:px 96 :py (downs 96)) Index: cell-cultures/cellodemo/demo-window.lisp diff -u cell-cultures/cellodemo/demo-window.lisp:1.3 cell-cultures/cellodemo/demo-window.lisp:1.4 --- cell-cultures/cellodemo/demo-window.lisp:1.3 Fri Oct 1 06:01:10 2004 +++ cell-cultures/cellodemo/demo-window.lisp Fri Oct 15 05:37:30 2004 @@ -26,6 +26,7 @@ (defun cello-test () (let ((cells::*c-debug* (get-internal-real-time))) (run-stylish-demos '(light-panel ft-jpg tu-geo ftgl-test demo-scroller) + ;;'tu-geo 'light-panel :skin (c? (wand-ensure-typed 'wand-texture (car (md-value (fm-other :texture-picker))))) @@ -35,9 +36,9 @@ :lb (c-in (downs 650))))) (defun demo-scroller () - (mk-part :demo-scroller (ig-zero-tl) + (mk-part :demo-scroller (ix-zero-tl) :kids (c? (list - (mk-part :dialog (ig-zero-tl) + (mk-part :dialog (ix-zero-tl) :px 48 :py -48 :outset (u8ths 2) :skin (c? (wand-ensure-typed 'wand-texture @@ -58,7 +59,7 @@ (mk-part :scroller (ix-scroller) :px 0 :py 0 :mac-p t - :scroll-bars '(:hz :vt) + :scroll-bars '(:horizontal :vertical) :start-size (mkv2 (u96ths 150)(u96ths (downs 250))) :resizeable t :content (c? (mk-part :gview (ix-image-file) @@ -164,7 +165,7 @@ :kids (c? (the-kids (demo-window-beef) #+nicetry - (mk-part :wintop (ig-zero-tl) + (mk-part :wintop (ix-zero-tl) :px 0 :py 0 :ll 0 :lt 0 :lr (c? (l-width .parent)) :lb (c? (downs (l-height .parent))) @@ -191,7 +192,7 @@ (when (recording node) (ix-snapshot node (recordingp node)))))) -(defmethod not-to-be :after ((self demo-window)) +(defmethod not-to-be :after ((self window)) (unless (kids *sys*) (cl-openal-shutdown)) (wands-clear)) @@ -203,13 +204,14 @@ (wav-play-till-end nil (car (sound-paths s))))) (defun demo-window-beef () - (mk-part :beef (ix-stack) + (mk-part :beef (ix-inline) + :orientation :vertical :px 0 :py (u8ths (downs 1)) :spacing (u8ths 1) :lb (c? (^fill-parent-down)) :kids (c? (the-kids (demo-control-panel) - (mk-part :demos (ig-zero-tl) + (mk-part :demos (ix-zero-tl) ;;:py (u8ths 4) :lb (c? (^fill-parent-down)) :kid-slots (lambda (self) @@ -231,7 +233,7 @@ (defun demo-control-panel () (a-row (:spacing (u8ths 2) :justify :center) - (mk-part :rate (frame-rate-text)) + #+shh (mk-part :rate (frame-rate-text)) (a-stack (:spacing (u16ths 1)) (texture-picker) (demo-picker)) @@ -330,7 +332,8 @@ :glut-id glut_bitmap_8_by_13) :pre-layer (with-layers +red+) :text$ (c? (string (class-name (md-value .parent))))) - (mk-part :subks (ix-stack) + (mk-part :subks (ix-inline) + :orientation :vertical :kids (c? (loop for subk in (class-direct-subclasses (md-value .parent)) collecting (mk-part :sub (proctor-class) :md-value subk)))))))) Index: cell-cultures/cellodemo/hedron-decoration.lisp diff -u cell-cultures/cellodemo/hedron-decoration.lisp:1.2 cell-cultures/cellodemo/hedron-decoration.lisp:1.3 --- cell-cultures/cellodemo/hedron-decoration.lisp:1.2 Wed Sep 29 04:50:11 2004 +++ cell-cultures/cellodemo/hedron-decoration.lisp Fri Oct 15 05:37:30 2004 @@ -23,7 +23,8 @@ (in-package :cello) (defun hedron-options () - (mk-part :options (ix-stack) + (mk-part :options (ix-inline) + :orientation :vertical :spacing (upts 4) :justify :right :kids (c? (the-kids @@ -78,7 +79,8 @@ )))) (defun hedron-tex-options () - (mk-part :tex-options (ix-stack) + (mk-part :tex-options (ix-inline) + :orientation :vertical :justify :left :kids (c? (the-kids (a-row () @@ -92,13 +94,14 @@ (alabel "Shape/Sides") (mk-part :scroller (ix-scroller) :mac-p t - :scroll-bars '(:vt) + :scroll-bars '(:vertical) :start-size (mkv2 (uin 2)(u96ths (downs 96))) :resizeable nil - :content (c? (mk-part :shape (ix-stack) + :content (c? (mk-part :shape (ix-inline) + :orientation :vertical :pre-layer (with-layers +white+ :fill) - :md-value (c-in (list 'cello)) - :kids (c? (loop for shape in '(cube 4 8 12 rhombic-dodecahedron 20 + :md-value (c-in (list 'nurb)) + :kids (c? (loop for shape in '(nurb cube 4 8 12 rhombic-dodecahedron 20 cylinder cone sphere torus sierpinski-sponge teapot cello) collecting (mk-part :rb (ct-text-radio-item) @@ -162,10 +165,11 @@ (alabel label$) (mk-part :scroller (ix-scroller) :mac-p t - :scroll-bars '(:vt) + :scroll-bars '(:vertical) :start-size (mkv2 (uin 2)(u96ths (downs 96))) :resizeable nil - :content (c? (make-part md-name 'ix-stack + :content (c? (make-part md-name 'ix-inline + :orientation :vertical :pre-layer (with-layers +white+ :fill) :md-value (c-in (list (or (when start$ (find-if (lambda (jpeg) Index: cell-cultures/cellodemo/hedron-render.lisp diff -u cell-cultures/cellodemo/hedron-render.lisp:1.2 cell-cultures/cellodemo/hedron-render.lisp:1.3 --- cell-cultures/cellodemo/hedron-render.lisp:1.2 Wed Sep 29 04:50:11 2004 +++ cell-cultures/cellodemo/hedron-render.lisp Fri Oct 15 05:37:30 2004 @@ -49,6 +49,65 @@ (ftgl-render font "Cello")) +(defun glut-solid-nurb (nurb) + (glu-nurbs-property nurb glu_display_mode glu_fill) + (draw-test-nurb nurb)) + +(defun glut-wire-nurb (nurb) + (glu-nurbs-property nurb glu_display_mode glu_outline_polygon) + (draw-test-nurb nurb)) + +(defparameter *hill* (make-ff-array :float 0 0 0 0 1 1 1 1)) +(defparameter *hill-controls* (make-ff-array :float -3.0 -3.0 -9 -3.0 -1.0 -9 -3.0 1.0 + -9 -3.0 3.0 -9 -1.0 -3.0 -9 -1.0 -1.0 9 -1.0 1.0 9 -1.0 + 3.0 -9 1.0 -3.0 -9 1.0 -1.0 9 1.0 1.0 9 1.0 3.0 -9 3.0 + -3.0 -9 3.0 -1.0 -9 3.0 1.0 -9 3.0 3.0 -9) + #+not (loop with fv = (fgn-alloc 'glfloat 48 :testnurb) + for u below 4 do + (loop for v below 4 + for base = (+ (* u 12) (* v 3)) + do (setf (eltf fv (+ base 0)) (* 2 (- u 1.5))) + (setf (eltf fv (+ base 1)) (* 2 (- v 1.5))) + (setf (eltf fv (+ base 2)) + (* 3 (if (and (or (eql u 1)(eql u 2)) + (or (eql v 1)(eql v 2))) + 3 -3)))) + finally (return fv))) + +(defparameter *dump-matrix* (fgn-alloc 'glfloat 16 :dump-matrix)) +(defun dump-matrix (matrix-id msg) + (gl-get-floatv matrix-id *dump-matrix*) + (format t "~&~a > ~a matrix> ~{~a ~}" msg + (cond ((eql matrix-id gl_modelview_matrix) 'modelview) + ((eql matrix-id GL_PROJECTION_MATRIX) 'projection)) + (loop for n below 16 collecting (eltf *dump-matrix* n)))) + +(defun dump-viewport ( msg) + (gl-get-floatv GL_VIEWPORT *dump-matrix*) + (format t "~&~a > viewport> ~{~a ~}" msg + (loop for n below 4 collecting (eltf *dump-matrix* n)))) + +;;;glGetFloatv(GL_MODELVIEW_MATRIX,modelview); +;;; glGetFloatv(GL_PROJECTION_MATRIX,projection); +;;; glGetIntegerv(GL_VIEWPORT,viewport); +;;; gluLoadSamplingMatrices (Nurb, modelview, projection, viewport); + +(defun draw-test-nurb (nurb) + (glu-nurbs-property nurb glu_sampling_tolerance 5) + (glu-nurbs-property nurb glu_auto_load_matrix gl_false) + + (gl-enable gl_lighting) + (gl-enable gl_light0) + (gl-enable gl_depth_test) + (gl-enable gl_auto_normal) + (gl-enable gl_normalize) + + (gl-rotatef 330 1 0 0) + (gl-scalef .25 .25 .25) + (glu-begin-surface nurb) + (glu-nurbs-surface nurb 8 *hill* 8 *hill* 12 3 *hill-controls* 4 4 gl_map2_vertex_3) + (glu-end-surface nurb)) + (defparameter *sponge-offset* (loop with fv = (fgn-alloc 'gldouble 3 :sponge) for n below 3 do (setf (eltd fv n) 0) @@ -60,10 +119,10 @@ (declare (ignorable w)) (gl-matrix-mode gl_projection) (with-matrix (t) - (trc nil "tetra frame" (ll self) (lr self) (lb self) (lt self)) - (gl-ortho (ll w) (lr w) (lb w) (lt w) -10000 10000) ;;*mgw-near* *mgw-far*) + (trc nil "ix-paint > hedron ortho" (ll self) (lr self) (lb self) (lt self)) + (gl-ortho (ll w) (lr w) (lb w) (lt w) 10000 -10000) ;*mgw-near* *mgw-far*) ;; was -+ 10k - (gl-matrix-mode gl_model-view) + (gl-matrix-mode gl_modelview) (with-matrix (nil) (let ((shape (car (md-value (fm^ :shape)))) (wireframe-p (md-value (fm^ :wireframe))) @@ -158,6 +217,7 @@ (otherwise (string shape))))) :cello) (case shape (cello (list (^text-font))) + (nurb (list (^nurb))) (cone (list base-r height (round slices) (round stacks))) (cylinder (list (quadric self) base-r top-r height (round slices) (round stacks))) ((cube teapot) (list size)) @@ -173,5 +233,5 @@ (gl-disable gl_texture_gen_q) (gl-matrix-mode gl_projection)) - (gl-matrix-mode gl_model-view)) + (gl-matrix-mode gl_modelview)) Index: cell-cultures/cellodemo/light-panel.lisp diff -u cell-cultures/cellodemo/light-panel.lisp:1.2 cell-cultures/cellodemo/light-panel.lisp:1.3 --- cell-cultures/cellodemo/light-panel.lisp:1.2 Wed Sep 29 04:50:11 2004 +++ cell-cultures/cellodemo/light-panel.lisp Fri Oct 15 05:37:30 2004 @@ -28,28 +28,44 @@ (defmodel hedron (ix-styled image) ((quadric :initform (c? (glu-new-quadric)) :reader quadric) + (nurb :reader nurb :initform (c? (let ((nurb (glu-new-nurbs-renderer))) + (assert (not (zerop nurb))) + (trc "hedron got new nurbs renderer" self nurb) + (glu-nurbs-property nurb glu_sampling_tolerance 25) + nurb))) (mat-ambi-diffuse :initform nil :initarg :mat-ambi-diffuse :reader mat-ambi-diffuse) (mat-specular :initform nil :initarg :mat-specular :reader mat-specular) (mat-shiny :initform nil :initarg :mat-shiny :reader mat-shiny) - (mat-emission :initform nil :initarg :mat-emission :reader mat-emission)) + (mat-emission :initform nil :initarg :mat-emission :reader mat-emission) + (backdrop :reader backdrop :initarg :backdrop :initform nil)) (:default-initargs :lighting :on :text-font (ftgl-make :extruded *gui-style-default-face* 18 96 9) :rotation (let ((rx 0)(ry 0)(rz 0)) - (c? (let ((spinning (md-value (fm-other :spinning)))) + (c? (bIf (spinning (md-value (fm-other :spinning))) (macrolet ((radj (axis ixid) `(incf ,axis (if spinning (* 10 (v2-h (md-value (fm-other ,ixid)))) 0)))) (when (frame-ct .w.) - (list (radj rx :rotx) - (radj ry :roty) - (radj rz :rotz))))))))) + (list (radj rx :rotx) + (radj ry :roty) + (radj rz :rotz)))) + (list rx ry rz)))))) + +(defmethod ogl-dsp-list-prep progn ((self hedron)) + (trc nil "ogl-dsp-list-prep> doing hedron" self) + (^nurb) + (ogl-dsp-list-prep (backdrop self))) + +(defmethod not-to-be ((self hedron)) + (when (^nurb) + (glu-delete-nurbs-renderer (^nurb)))) (defmethod display-text$ ((self Hedron)) - "quick dirty to satisfy ix-styled ogl-disp-list-prep" - "2Cel2lo") + "quick dirty ugly hack to satisfy ix-styled ogl-disp-list-prep" + "Cello") (defmodel rgba-mixer (ix-stack) ((red :cell nil :initarg :red :initform nil) @@ -106,10 +122,7 @@ :lb (c? (^fill-parent-down))) (hedron-options) (a-stack (:spacing (u8ths 1) - :justify :left - :skin (c? (wand-ensure-typed 'wand-texture - (car (md-value (fm-other :shape-backer))) - :tile-p nil))) + :justify :left) (hedron-tex-options) (mk-part :hedron (hedron) :ll (u96ths -300) :lt (ups (u96ths 300)) @@ -121,11 +134,14 @@ :mat-shiny (c? (md-value (fm-other :hedro-shiny))) :mat-emission (c? (when (md-value (fm-other :lights-on)) (md-value (fm-other :hedro-emission)))) - + :backdrop (c? (assert (not *ogl-listing-p*)) + (wand-ensure-typed 'wand-texture + (car (md-value (fm-other :shape-backer))) + :tile-p nil)) :pre-layer (with-layers (:in 300) +white+ - :off (:wand (skin .parent)) :on + :off (:wand (^backdrop)) :on (:in 20) +gray+ (:out 20) Index: cell-cultures/cellodemo/tutor-geometry.lisp diff -u cell-cultures/cellodemo/tutor-geometry.lisp:1.2 cell-cultures/cellodemo/tutor-geometry.lisp:1.3 --- cell-cultures/cellodemo/tutor-geometry.lisp:1.2 Fri Oct 1 06:01:10 2004 +++ cell-cultures/cellodemo/tutor-geometry.lisp Fri Oct 15 05:37:30 2004 @@ -26,7 +26,7 @@ (/ degrees #.(/ 180 pi))) (defun tu-geo () - (make-instance 'ig-zero-tl + (make-instance 'ix-zero-tl :md-name 'tu-geo :kids (c? (flet ((tu-box (name &rest deets) (apply 'make-instance 'image From ktilton at common-lisp.net Fri Oct 15 03:37:38 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 15 Oct 2004 05:37:38 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cells/cells-test/test-cyclicity.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cells/cells-test In directory common-lisp.net:/tmp/cvs-serv28025/cells/cells-test Modified Files: test-cyclicity.lisp Log Message: Re-write of the core layout widgets under the ix-inline class, plus a new OpenGL example, viz., a simple nurb. Looks sweet, btw. Date: Fri Oct 15 05:37:33 2004 Author: ktilton Index: cell-cultures/cells/cells-test/test-cyclicity.lisp diff -u cell-cultures/cells/cells-test/test-cyclicity.lisp:1.1 cell-cultures/cells/cells-test/test-cyclicity.lisp:1.2 --- cell-cultures/cells/cells-test/test-cyclicity.lisp:1.1 Sat Jun 26 20:38:37 2004 +++ cell-cultures/cells/cells-test/test-cyclicity.lisp Fri Oct 15 05:37:32 2004 @@ -67,7 +67,7 @@ (mapcan (lambda (router-id) (unless (find router-id visited-nodes) (multiple-value-bind (ups new-visiteds) - (contiguous-nodes-up (fm! node router-id) visited-nodes) + (contiguous-nodes-up (fm-other! node router-id) visited-nodes) (setf visited-nodes new-visiteds) ups))) (router-ids node))) @@ -84,9 +84,9 @@ :sys-node 'two :ring '(one two three four five six)))) (dump-net net "initially") - (setf (system-status (fm! net 'three)) 'down) + (setf (system-status (fm-other! net 'three)) 'down) (dump-net net "down goes three!!") - (setf (system-status (fm! net 'six)) 'down) + (setf (system-status (fm-other! net 'six)) 'down) (dump-net net "down goes six!!!")))) #+do-it From ktilton at common-lisp.net Fri Oct 15 03:37:40 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 15 Oct 2004 05:37:40 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cells/fm-utilities.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cells In directory common-lisp.net:/tmp/cvs-serv28025/cells Modified Files: fm-utilities.lisp Log Message: Re-write of the core layout widgets under the ix-inline class, plus a new OpenGL example, viz., a simple nurb. Looks sweet, btw. Date: Fri Oct 15 05:37:38 2004 Author: ktilton Index: cell-cultures/cells/fm-utilities.lisp diff -u cell-cultures/cells/fm-utilities.lisp:1.1 cell-cultures/cells/fm-utilities.lisp:1.2 --- cell-cultures/cells/fm-utilities.lisp:1.1 Sat Jun 26 20:38:36 2004 +++ cell-cultures/cells/fm-utilities.lisp Fri Oct 15 05:37:38 2004 @@ -418,7 +418,7 @@ :must-find nil :global-search ,global-search)) -(defun fm! (starting md-name &optional (global-search t)) +(defun fm-other! (starting md-name &optional (global-search t)) (fm-find-one starting md-name :must-find t :global-search global-search)) @@ -436,12 +436,13 @@ :must-find nil :global-search ,global-search)) -(defmacro fm-other! (md-name &optional (starting 'self)) - `(fm-find-one ,starting ,(if (consp md-name) - `(list ',(car md-name) ,(cadr md-name)) - `',md-name) +(defmacro fm! (md-name &optional (starting 'self)) + `(without-c-dependency + (fm-find-one ,starting ,(if (consp md-name) + `(list ',(car md-name) ,(cadr md-name)) + `',md-name) :must-find t - :global-search nil)) + :global-search nil))) (defmacro fm-other?! (md-name &optional (starting 'self)) `(fm-find-one ,starting ,(if (consp md-name) From ktilton at common-lisp.net Fri Oct 15 03:37:55 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 15 Oct 2004 05:37:55 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cl-magick/cl-magick.lisp cell-cultures/cl-magick/mgk-test.lisp cell-cultures/cl-magick/wand-texture.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cl-magick In directory common-lisp.net:/tmp/cvs-serv28025/cl-magick Modified Files: cl-magick.lisp mgk-test.lisp wand-texture.lisp Log Message: Re-write of the core layout widgets under the ix-inline class, plus a new OpenGL example, viz., a simple nurb. Looks sweet, btw. Date: Fri Oct 15 05:37:46 2004 Author: ktilton Index: cell-cultures/cl-magick/cl-magick.lisp diff -u cell-cultures/cl-magick/cl-magick.lisp:1.1 cell-cultures/cl-magick/cl-magick.lisp:1.2 --- cell-cultures/cl-magick/cl-magick.lisp:1.1 Sat Jun 26 20:38:39 2004 +++ cell-cultures/cl-magick/cl-magick.lisp Fri Oct 15 05:37:40 2004 @@ -93,15 +93,15 @@ (cl-magick-init) (let ((key (list* wand-type (namestring file-path$) iargs))) (or (let ((old (cdr (assoc key (wands-loaded) :test 'equal)))) ;;/// primitive test - #+shh (when old - (print `(wand-ensure-typed re-using prior load ,wand-type ,file-path$))) + #+shhh (when old + (print `(wand-ensure-typed re-using prior load ,wand-type ,file-path$))) old) (let ((wi (apply 'make-instance wand-type :file-path$ file-path$ iargs))) #+shhh (print `(wand-ensure-typed forced to load ,wand-type ,file-path$)) - (push (cons key wi) (wands-loaded)) - wi) + (push (cons key wi) (wands-loaded)) + wi) (error "Unable to load image file ~a" file-path$))))) #+allegro Index: cell-cultures/cl-magick/mgk-test.lisp diff -u cell-cultures/cl-magick/mgk-test.lisp:1.2 cell-cultures/cl-magick/mgk-test.lisp:1.3 --- cell-cultures/cl-magick/mgk-test.lisp:1.2 Fri Oct 1 06:01:19 2004 +++ cell-cultures/cl-magick/mgk-test.lisp Fri Oct 15 05:37:40 2004 @@ -300,7 +300,7 @@ (gl-matrix-mode gl_projection) (gl-load-identity) (glu-perspective 45 (/ width height) 0.1 100) - (gl-matrix-mode gl_model-view) + (gl-matrix-mode gl_modelview) (gl-load-identity))) (defun cl-magick-test () Index: cell-cultures/cl-magick/wand-texture.lisp diff -u cell-cultures/cl-magick/wand-texture.lisp:1.3 cell-cultures/cl-magick/wand-texture.lisp:1.4 --- cell-cultures/cl-magick/wand-texture.lisp:1.3 Fri Oct 1 06:01:19 2004 +++ cell-cultures/cl-magick/wand-texture.lisp Fri Oct 15 05:37:40 2004 @@ -28,8 +28,8 @@ (defclass wand-texture (wand-image ogl-texture)()) (defmethod wand-release :after ((wand wand-texture)) - (when (texture-name wand) - (ogl-texture-delete (texture-name wand)))) + (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) @@ -45,13 +45,14 @@ (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))) + #+shh (print `(texture-name> gennning texture ,self)) (unless (equal (image-size self) best-fit-sz) - ;;(print `(tex-refit ,(image-size self) to ,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) (setf (image-size self) best-fit-sz)) - ;(print `(new image size ,(image-size self))) + #+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) @@ -125,10 +126,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))) - ))))R \ No newline at end of file + )))) \ No newline at end of file From ktilton at common-lisp.net Fri Oct 15 03:38:02 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 15 Oct 2004 05:38:02 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cl-opengl/gl-constants.lisp cell-cultures/cl-opengl/glu-functions.lisp cell-cultures/cl-opengl/glut-extras.lisp cell-cultures/cl-opengl/nehe-14.lisp cell-cultures/cl-opengl/ogl-macros.lisp cell-cultures/cl-opengl/ogl-utils.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cl-opengl In directory common-lisp.net:/tmp/cvs-serv28025/cl-opengl Modified Files: gl-constants.lisp glu-functions.lisp glut-extras.lisp nehe-14.lisp ogl-macros.lisp ogl-utils.lisp Log Message: Re-write of the core layout widgets under the ix-inline class, plus a new OpenGL example, viz., a simple nurb. Looks sweet, btw. Date: Fri Oct 15 05:37:56 2004 Author: ktilton Index: cell-cultures/cl-opengl/gl-constants.lisp diff -u cell-cultures/cl-opengl/gl-constants.lisp:1.1 cell-cultures/cl-opengl/gl-constants.lisp:1.2 --- cell-cultures/cl-opengl/gl-constants.lisp:1.1 Sat Jun 26 20:38:40 2004 +++ cell-cultures/cl-opengl/gl-constants.lisp Fri Oct 15 05:37:55 2004 @@ -172,8 +172,8 @@ (dfc gl_t4f_c4f_n3f_v4f #x2a2d) #| matrix mode |# -(dfc gl_model-view #x1700) -(dfc gl_projection #x1701) +(dfc gl_modelview #x1700) +(dfc gl_projection #x1701) (dfc gl_texture #x1702) #| display lists |# @@ -338,10 +338,10 @@ (dfc gl_matrix_mode #x0ba0) (dfc gl_normalize #x0ba1) (dfc gl_viewport #x0ba2) -(dfc gl_model-view_stack_depth #x0ba3) +(dfc gl_modelview_stack_depth #x0ba3) (dfc gl_projection_stack_depth #x0ba4) (dfc gl_texture_stack_depth #x0ba5) -(dfc gl_model-view_matrix #x0ba6) +(dfc gl_modelview_matrix #x0ba6) (dfc gl_projection_matrix #x0ba7) (dfc gl_texture_matrix #x0ba8) (dfc gl_attrib_stack_depth #x0bb0) Index: cell-cultures/cl-opengl/glu-functions.lisp diff -u cell-cultures/cl-opengl/glu-functions.lisp:1.1 cell-cultures/cl-opengl/glu-functions.lisp:1.2 --- cell-cultures/cl-opengl/glu-functions.lisp:1.1 Sat Jun 26 20:38:41 2004 +++ cell-cultures/cl-opengl/glu-functions.lisp Fri Oct 15 05:37:55 2004 @@ -22,9 +22,139 @@ (in-package :cl-opengl) +;;; *** Generic constants ****/ + +;;; Errors: (return value 0 = no error) */ +(dfc GLU_INVALID_ENUM 100900) +(dfc GLU_INVALID_VALUE 100901) +(dfc GLU_OUT_OF_MEMORY 100902) +(dfc GLU_INCOMPATIBLE_GL_VERSION 100903) + +;;; StringName */ +(dfc GLU_VERSION 100800) +(dfc GLU_EXTENSIONS 100801) + +;;; Boolean */ +(dfc GLU_TRUE 1) +(dfc GLU_FALSE 0) + + +;;; *** Quadric constants ****/ + +;;; QuadricNormal */ +(dfc GLU_SMOOTH 100000) +(dfc GLU_FLAT 100001) +(dfc GLU_NONE 100002) + +;;; QuadricDrawStyle */ +(dfc GLU_POINT 100010) +(dfc GLU_LINE 100011) +(dfc GLU_FILL 100012) +(dfc GLU_SILHOUETTE 100013) + +;;; QuadricOrientation */ +(dfc GLU_OUTSIDE 100020) +(dfc GLU_INSIDE 100021) + +;;; Callback types: */ +;;; GLU_ERROR 100103 */ + + +;;; *** Tesselation constants ****/ + +;;(dfc GLU_TESS_MAX_COORD 1.0e150) + +;;; TessProperty */ +(dfc GLU_TESS_WINDING_RULE 100140) +(dfc GLU_TESS_BOUNDARY_ONLY 100141) +(dfc GLU_TESS_TOLERANCE 100142) + +;;; TessWinding */ +(dfc GLU_TESS_WINDING_ODD 100130) +(dfc GLU_TESS_WINDING_NONZERO 100131) +(dfc GLU_TESS_WINDING_POSITIVE 100132) +(dfc GLU_TESS_WINDING_NEGATIVE 100133) +(dfc GLU_TESS_WINDING_ABS_GEQ_TWO 100134) + +;;; TessCallback */ +(dfc GLU_TESS_BEGIN 100100) ;;; void (CALLBACK*)(GLenum type) */ +(dfc GLU_TESS_VERTEX 100101) ;;; void (CALLBACK*)(void *data) */ +(dfc GLU_TESS_END 100102) ;;; void (CALLBACK*)(void) */ +(dfc GLU_TESS_ERROR 100103) ;;; void (CALLBACK*)(GLenum errno) */ +(dfc GLU_TESS_EDGE_FLAG 100104) ;;; void (CALLBACK*)(GLboolean boundaryEdge) */ +(dfc GLU_TESS_COMBINE 100105) ;;; void (CALLBACK*)(GLdouble coords[3], + ;;; void *data[4], + ;;; GLfloat weight[4], + ;;; void **dataOut) */ +(dfc GLU_TESS_BEGIN_DATA 100106) ;;; void (CALLBACK*)(GLenum type, + ;;; void *polygon_data) */ +(dfc GLU_TESS_VERTEX_DATA 100107) ;;; void (CALLBACK*)(void *data, + ;;; void *polygon_data) */ +(dfc GLU_TESS_END_DATA 100108) ;;; void (CALLBACK*)(void *polygon_data) */ +(dfc GLU_TESS_ERROR_DATA 100109) ;;; void (CALLBACK*)(GLenum errno, + ;;; void *polygon_data) */ +(dfc GLU_TESS_EDGE_FLAG_DATA 100110) ;;; void (CALLBACK*)(GLboolean boundaryEdge, + ;;; void *polygon_data) */ +(dfc GLU_TESS_COMBINE_DATA 100111) ;;; void (CALLBACK*)(GLdouble coords[3], + ;;; void *data[4], + ;;; GLfloat weight[4], + ;;; void **dataOut, + ;;; void *polygon_data) */ + +;;; TessError */ +(dfc GLU_TESS_ERROR1 100151) +(dfc GLU_TESS_ERROR2 100152) +(dfc GLU_TESS_ERROR3 100153) +(dfc GLU_TESS_ERROR4 100154) +(dfc GLU_TESS_ERROR5 100155) +(dfc GLU_TESS_ERROR6 100156) +(dfc GLU_TESS_ERROR7 100157) +(dfc GLU_TESS_ERROR8 100158) + +(dfc GLU_TESS_MISSING_BEGIN_POLYGON GLU_TESS_ERROR1) +(dfc GLU_TESS_MISSING_BEGIN_CONTOUR GLU_TESS_ERROR2) +(dfc GLU_TESS_MISSING_END_POLYGON GLU_TESS_ERROR3) +(dfc GLU_TESS_MISSING_END_CONTOUR GLU_TESS_ERROR4) +(dfc GLU_TESS_COORD_TOO_LARGE GLU_TESS_ERROR5) +(dfc GLU_TESS_NEED_COMBINE_CALLBACK GLU_TESS_ERROR6) + + +;;; **** NURBS constants ****/ + +;;; NurbsProperty */ +(dfc GLU_AUTO_LOAD_MATRIX 100200) +(dfc GLU_CULLING 100201) +(dfc GLU_SAMPLING_TOLERANCE 100203) +(dfc GLU_DISPLAY_MODE 100204) +(dfc GLU_PARAMETRIC_TOLERANCE 100202) +(dfc GLU_SAMPLING_METHOD 100205) +(dfc GLU_U_STEP 100206) +(dfc GLU_V_STEP 100207) + +;;; NurbsSampling */ +(dfc GLU_PATH_LENGTH 100215) +(dfc GLU_PARAMETRIC_ERROR 100216) +(dfc GLU_DOMAIN_DISTANCE 100217) + + +;;; NurbsTrim */ +(dfc GLU_MAP1_TRIM_2 100210) +(dfc GLU_MAP1_TRIM_3 100211) + +;;; NurbsDisplay */ + +(dfc GLU_OUTLINE_POLYGON 100240) +(dfc GLU_OUTLINE_PATCH 100241) + +;;; NurbsCallback */ +;;; GLU_ERROR 100103 */ + +;;; NurbsErrors */ +(dfc GLU_NURBS_ERROR1 100251) +(dfc GLU_NURBS_ERROR37 100287) + (defun-ogl (* glubyte) "gl-util" "gluErrorString" (glenum error)) -;;;(defun-ogl void "gl-util" "gluGetNurbsProperty" (GLUnurbs *nurb GLenum property GLfloat *data)) ;;;(defun-ogl GLubyte *"gl-util" "gluGetString" (GLenum name)) ;;;(defun-ogl void "gl-util" "gluGetTessProperty" (GLUtesselator *tess GLenum which GLdouble *data)) ;;;(defun-ogl void "gl-util" "gluLoadSamplingMatrices" (GLUnurbs *nurb GLfloat *model GLfloat *perspective GLint *view)) @@ -46,14 +176,27 @@ (defun-ogl :void "gl-util" "gluLookAt" (gldouble eye-x gldouble eye-y gldouble eye-z gldouble center-x gldouble center-y gldouble center-z gldouble upx gldouble upy gldouble upz)) -;;;(defun-ogl GLUnurbs *"gl-util" "gluNewNurbsRenderer" ()) + (defun-ogl (* :void) "gl-util" "gluNewQuadric" ()) + (defun-ogl :void "gl-util" "gluDeleteQuadric" (:void *quadric)) + +(defun-ogl (* :void) "gl-util" "gluNewNurbsRenderer" ()) +(defun-ogl :void "gl-util" "gluDeleteNurbsRenderer" (:void *nurb)) +(defun-ogl :void "gl-util" "gluBeginSurface" (:void *nurb)) +(defun-ogl :void "gl-util" "gluEndSurface" (:void *nurb)) +(defun-ogl :void "gl-util" "gluBeginCurve" (:void *nurb)) +(defun-ogl :void "gl-util" "gluEndCurve" (:void *nurb)) +(defun-ogl :void "gl-util" "gluBeginTrim" (:void *nurb)) +(defun-ogl :void "gl-util" "gluEndTrim" (:void *nurb)) + +(defun-ogl :void "gl-util" "gluGetNurbsProperty" (:void *nurb GLenum property GLfloat *data)) +(defun-ogl :void "gl-util" "gluNurbsCurve" (:void *nurb GLint knotCount GLfloat *knots GLint stride GLfloat *control GLint order GLenum type)) +(defun-ogl :void "gl-util" "gluNurbsProperty" (:void *nurb GLenum property GLfloat value)) +(defun-ogl :void "gl-util" "gluNurbsSurface" (:void *nurb GLint sKnotCount GLfloat *sKnots GLint tKnotCount GLfloat *tKnots GLint sStride GLint tStride GLfloat *control GLint sOrder GLint tOrder GLenum type)) + ;;;(defun-ogl GLUtesselator *"gl-util" "gluNewTess" ()) ;;;(defun-ogl void "gl-util" "gluNextContour" (GLUtesselator *tess GLenum type)) -;;;(defun-ogl void "gl-util" "gluNurbsCurve" (GLUnurbs *nurb GLint knotCount GLfloat *knots GLint stride GLfloat *control GLint order GLenum type)) -;;;(defun-ogl void "gl-util" "gluNurbsProperty" (GLUnurbs *nurb GLenum property GLfloat value)) -;;;(defun-ogl void "gl-util" "gluNurbsSurface" (GLUnurbs *nurb GLint sKnotCount GLfloat *sKnots GLint tKnotCount GLfloat *tKnots GLint sStride GLint tStride GLfloat *control GLint sOrder GLint tOrder GLenum type)) ;;;(defun-ogl :void "gl-util" "gluOrtho2D" (GLdouble left GLdouble right ;;; GLdouble bottom GLdouble top)) ;;;(defun-ogl void "gl-util" "gluPartialDisk" (GLUquadric *quad GLdouble inner GLdouble outer GLint slices GLint loops GLdouble start GLdouble sweep)) Index: cell-cultures/cl-opengl/glut-extras.lisp diff -u cell-cultures/cl-opengl/glut-extras.lisp:1.2 cell-cultures/cl-opengl/glut-extras.lisp:1.3 --- cell-cultures/cl-opengl/glut-extras.lisp:1.2 Fri Oct 1 06:01:29 2004 +++ cell-cultures/cl-opengl/glut-extras.lisp Fri Oct 15 05:37:55 2004 @@ -85,7 +85,7 @@ (let ((mmi (uffi:deref-array mm '(:array :int) 0))) (glgetintegerv (cond - ((eql mmi gl_model-view) gl_model-view_stack_depth) + ((eql mmi gl_modelview) gl_modelview_stack_depth) ((eql mmi gl_projection) gl_projection_stack_depth) ((eql mmi gl_texture) gl_texture_stack_depth) (t (break "bad matrix"))) @@ -99,7 +99,7 @@ (let ((mmi (uffi:deref-array mm '(:array :int) 0))) (unwind-protect (cond - ((eql mmi gl_model-view) :model-view) + ((eql mmi gl_modelview) :model-view) ((eql mmi gl_projection) :projection) ((eql mmi gl_texture) :texture) Index: cell-cultures/cl-opengl/nehe-14.lisp diff -u cell-cultures/cl-opengl/nehe-14.lisp:1.1 cell-cultures/cl-opengl/nehe-14.lisp:1.2 --- cell-cultures/cl-opengl/nehe-14.lisp:1.1 Sat Jun 26 20:38:41 2004 +++ cell-cultures/cl-opengl/nehe-14.lisp Fri Oct 15 05:37:55 2004 @@ -128,7 +128,7 @@ (glu-perspective 70 1 1 1000) (glu-look-at 0d0 0d0 5d0 0d0 0d0 0d0 0d0 1d0 0d0) - (gl-matrix-mode gl_model-view) + (gl-matrix-mode gl_modelview) (gl-load-identity) Index: cell-cultures/cl-opengl/ogl-macros.lisp diff -u cell-cultures/cl-opengl/ogl-macros.lisp:1.2 cell-cultures/cl-opengl/ogl-macros.lisp:1.3 --- cell-cultures/cl-opengl/ogl-macros.lisp:1.2 Fri Oct 1 06:01:29 2004 +++ cell-cultures/cl-opengl/ogl-macros.lisp Fri Oct 15 05:37:55 2004 @@ -50,8 +50,8 @@ (glec :with-matrix-push) (unwind-protect (progn - (when (eql gl_model-view_matrix mm-pushed) - (gl-get-integerv gl_model-view_stack_depth *stack-depth*) + (when (eql gl_modelview_matrix mm-pushed) + (gl-get-integerv gl_modelview_stack_depth *stack-depth*) (glec :get-stack-depth) (print `(with-matrix model matrix stack ,(aforef *stack-depth* 0)))) Index: cell-cultures/cl-opengl/ogl-utils.lisp diff -u cell-cultures/cl-opengl/ogl-utils.lisp:1.2 cell-cultures/cl-opengl/ogl-utils.lisp:1.3 --- cell-cultures/cl-opengl/ogl-utils.lisp:1.2 Fri Oct 1 06:01:29 2004 +++ cell-cultures/cl-opengl/ogl-utils.lisp Fri Oct 15 05:37:55 2004 @@ -47,7 +47,7 @@ (let (gl-s-plane gl-t-plane gl-r-plane gl-q-plane) (defun ogl-tex-gen-setup (mode tex-env tex-wrap scale &rest planes) - (ukt::trc nil "ogl-tex-gen-setup:" mode tex-env tex-wrap scale planes) + ;;(ukt::trc nil "ogl-tex-gen-setup:" mode tex-env tex-wrap scale planes) (gl-tex-envf gl_texture_env gl_texture_env_mode tex-env) (gl-tex-parameterf gl_texture_2d gl_texture_min_filter gl_linear ) (gl-tex-parameterf gl_texture_2d gl_texture_mag_filter gl_linear ) From ktilton at common-lisp.net Fri Oct 15 03:38:04 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 15 Oct 2004 05:38:04 +0200 Subject: [cells-cvs] CVS update: cell-cultures/clyde/cloucell/inspector-window.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/clyde/cloucell In directory common-lisp.net:/tmp/cvs-serv28025/clyde/cloucell Modified Files: inspector-window.lisp Log Message: Re-write of the core layout widgets under the ix-inline class, plus a new OpenGL example, viz., a simple nurb. Looks sweet, btw. Date: Fri Oct 15 05:38:03 2004 Author: ktilton Index: cell-cultures/clyde/cloucell/inspector-window.lisp diff -u cell-cultures/clyde/cloucell/inspector-window.lisp:1.1 cell-cultures/clyde/cloucell/inspector-window.lisp:1.2 --- cell-cultures/clyde/cloucell/inspector-window.lisp:1.1 Sun Jul 4 20:59:46 2004 +++ cell-cultures/clyde/cloucell/inspector-window.lisp Fri Oct 15 05:38:02 2004 @@ -56,7 +56,7 @@ (member prior-i h)) ;; toss "forward" chain from prior-i h))))))) -(defmodel target-view-container (ig-zero-tl) +(defmodel target-view-container (ix-zero-tl) () (:default-initargs :kid-slots (def-kid-slots From ktilton at common-lisp.net Fri Oct 15 03:37:30 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 15 Oct 2004 05:37:30 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cello/cello-ftgl.lisp cell-cultures/cello/cello-magick.lisp cell-cultures/cello/cello.lisp cell-cultures/cello/cello.lpr cell-cultures/cello/ct-scroll-bar.lisp cell-cultures/cello/ct-scroll-pane.lisp cell-cultures/cello/ctl-drag.lisp cell-cultures/cello/ctl-markbox.lisp cell-cultures/cello/ctl-selectable.lisp cell-cultures/cello/ctl-toggle.lisp cell-cultures/cello/image.lisp cell-cultures/cello/ix-family.lisp cell-cultures/cello/ix-geometry.lisp cell-cultures/cello/ix-grid.lisp cell-cultures/cello/ix-inline.lisp cell-cultures/cello/ix-render.lisp cell-cultures/cello/ix-styled.lisp cell-cultures/cello/menu.lisp cell-cultures/cello/pick.lisp cell-cultures/cello/to-do.lisp cell-cultures/cello/window-callbacks.lisp cell-cultures/cello/window.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cello In directory common-lisp.net:/tmp/cvs-serv28025/cello Modified Files: cello-ftgl.lisp cello-magick.lisp cello.lisp cello.lpr ct-scroll-bar.lisp ct-scroll-pane.lisp ctl-drag.lisp ctl-markbox.lisp ctl-selectable.lisp ctl-toggle.lisp image.lisp ix-family.lisp ix-geometry.lisp ix-grid.lisp ix-inline.lisp ix-render.lisp ix-styled.lisp menu.lisp pick.lisp to-do.lisp window-callbacks.lisp window.lisp Log Message: Re-write of the core layout widgets under the ix-inline class, plus a new OpenGL example, viz., a simple nurb. Looks sweet, btw. Date: Fri Oct 15 05:37:22 2004 Author: ktilton Index: cell-cultures/cello/cello-ftgl.lisp diff -u cell-cultures/cello/cello-ftgl.lisp:1.3 cell-cultures/cello/cello-ftgl.lisp:1.4 --- cell-cultures/cello/cello-ftgl.lisp:1.3 Fri Oct 1 06:01:05 2004 +++ cell-cultures/cello/cello-ftgl.lisp Fri Oct 15 05:37:21 2004 @@ -188,8 +188,6 @@ :clipped nil :kids (c? (loop for mode in '(:bitmap :pixmap :texture :outline :polygon :extruded) collect (mk-part :rb (ct-radio-labeled) - :text-font (font-ftgl-ensure :texture - *gui-style-default-face* 12) :associated-value mode :title$ (string-capitalize (format nil "~d" mode)))))) @@ -198,7 +196,8 @@ :kids (c? (the-kids (loop repeat cols collecting - (mk-part :fstk (ix-stack) + (mk-part :fstk (ix-inline) + :orientation :vertical :kids (c? (let ((col-no (kid-no self))) (loop for row-no below (ceiling (length fns) cols) when (mk-font-show col-no row-no) Index: cell-cultures/cello/cello-magick.lisp diff -u cell-cultures/cello/cello-magick.lisp:1.2 cell-cultures/cello/cello-magick.lisp:1.3 --- cell-cultures/cello/cello-magick.lisp:1.2 Fri Oct 1 06:01:05 2004 +++ cell-cultures/cello/cello-magick.lisp Fri Oct 15 05:37:21 2004 @@ -26,8 +26,9 @@ (eval-when (compile load eval) (defmethod ix-layer-expand ((key (eql :wand)) &rest args) - `(progn ;; (cells::trc "ix-layer-expand draw wand for" self) - (ix-render-wand ,(car args) l-box)))) + `(let ((wand ,(car args))) + (cells::trc nil "ix-layer-expand draw wand for" self wand) + (ix-render-wand wand l-box)))) (def-c-output recording () (when old-value Index: cell-cultures/cello/cello.lisp diff -u cell-cultures/cello/cello.lisp:1.1 cell-cultures/cello/cello.lisp:1.2 --- cell-cultures/cello/cello.lisp:1.1 Sun Jul 4 20:59:40 2004 +++ cell-cultures/cello/cello.lisp Fri Oct 15 05:37:21 2004 @@ -32,217 +32,7 @@ #:cl-opengl ) ;;; (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc) - - (:export access-allowed resource-key-held accesscontrol focus-shared-by - ct-toggle-choice-controlaction - ct-zoomers zoom-step zoom-limit - make-foldertab ct-toggle-choice - ix-shadow client client-offset ^client-offset - ix-ensure-in-view-image - - ^parent-height ^parent-width - open-browser-with-file clipped turn-edit-active - content ^content caret-rect ^caret-rect edit-requires-activation edit-ip-compute - canvas text-font ^sel-rect ^text-font ix-string-width font-caret-height nres-to-res nr-offset - column-spacing pb cs-waiting-ex - lvalue-in-frame-h lvalue-in-frame-v - cttext-find-ip-fixed cttext-find-ip-variable - s-focuser wdw swdw focuser focus-text-mini focuser focus ^focus ^focused-on - ctl-handle-over focus-editactive-do ct-selector-stack ct-selector-row - mk-twisted-part mk-twisted do-virtual-key-functions selector - ix-bar-chart ix-detail key-evt ^key-evt initialselection-first - ix-canvas ix-canvas-nested ix-canvas-parent-sized ix-canvas-kid-sized s-canvas w-kill edit-requires-activation - ct-edit-caret ^textual-focus ^edit-active ix-edit-selection - ix-blob ix-dd-bitmap ig-splitter ix-icon - folder-tab-grid folder-tab - ct-tab-header ix-details ^details ix-details-column ix-details-column-ex column-specs ^column-specs - ct-fsm-assume-value fully-enabled markbox-frame associated-value - ct-polygon ct-scroll-rocker ct-scroll-pane igscroller ix-scroller-multi a-scroller ^scroll-stepv2 - ix-scroll-bar-hz ix-scroll-bar-vt ix-scroll-fill - ct-key-valued ct-details ct-icon - ^make-ix-detail-columns make-ix-details do-click - with-one-invalidation with-modality - canvas-to-screen-point canvas-to-screen-rect - nr-outset current-folder focus-minded - focus-lose focus-gain a-stack-of-kids - ^lbmax? ^lrmax? - inset-h inset-v openstate - row-padding wrap$ - inset outset with-window-message - ix-stack-of-kids - focus-debug - buttons-shifted gunscaled - kbd-modifiers ^kbd-modifiers - ll lt lr lb ^ll ^lt ^lr ^lb l-rect - l-height - ^prior-sib - l-width ^best-fit-targetres - px ^px *mouse-where* - py ^py - ^dd-bit-map - visible collapsed layers - ^visible ^collapsed ^layers - was-handled - - ^py-maintain-pt ^px-maintain-pl - ^centered-h? ^centered-v? - ^px-maintain-pr ^py-maintain-pb - ^lr-maintain-pr ^lr-width ^insetlr ^inset-width ^fillright ^fill-right-type ^fill-down ^inset-height - ^fill-parent-right ^fill-parent-down - - - ^prior-sib-pb ^cell-pr ^cell-width - - mk-gr g-offset g-offset-h g-offset-v offset-within - - ^inset-lb - ^lb-maintain-pb ^lb-height find-ix-under pr - colpadding all-cell-width ix-orientation-opposite - selection-set1 v2-xlate selection-set - do-gpprint - current-tab - ix-table - radio-on-name - - - frame :black :red - - focused-on focus-thickness focus ^focus focus-change - edit-active - focused-descendant focus-family focus-find-first ;; /// vestigial? - focus-navi-leave focus-navigate - tabstopp tab-mode - - ;;; userActivity ^userActivity - - multi-text cello-reset - - ix-text - ;----- - text$ ^text$ - char-mask ^char-mask - maxcharwidth ^maxcharwidth - justify-hz ^justify-hz justify-vt ^justify-vt - im-label - - ht-phrase - ^px-self-centered spacing-hz - ^py-self-centered - - ix-text-tall - ;--------- - text-height ^text-height - formatted$ ^formatted$ - - ix-family - ;------- - styles ^styles - effective-styles ^effective-styles - showkids ^showkids - kids-ever-shown ^kids-ever-shown - - ig-zero-tl ix-kid-sized im-matrix ix-oriented im-oriented-cell - ix-stack ig-row ix-row ix-row-flow ix-row-fv - - image ix-bits backpict ^backpict texturearrayinfo ^texturearrayinfo - im-pix-file - - target-res ^target-res - - ix-grid - ;----- - col-ct ^col-ct - all-cell-width ^all-cell-width - all-cell-height ^all-cell-height - row-offsets ^row-offsets - col-offsets ^col-offsets - row-justifys ^row-justifys - col-justifys ^col-justifys - html-to-parts - - ix-paint - - control - ;------ - click-evt ^click-evt ^in-drag - title$ ^title$ enabled ^enabled hilited ^hilited - control-do-action - - ct-button ct-check-text - - ct-drag - - ct-sizer ct-tab-stop - - ct-folder ix-folder - - ctfsm ct-mark-box ct-check-box ct-check-text ct-radio-button ct-radio - ct-reorienter ct-twister - ct-tab-stop-bar ^ix-orientation tabdefs ^tabdefs fixed ^fixed - - ct-selectable ^selected - - ct-exclusive ct-multi-choice - ct-label ct-label-multi-choice ct-label-exclusive - ct-text - user-text$ ^user-text$ - insertion-pt ^insertion-pt - ^caret sm-echo-caret - sel-end ^sel-end sel-rect ^sel-rect sel-range ^sel-range sm-echo-selrange - - ct-selector - selection ^selection - selection-focus ^selection-focus - - tree-view tv-node-directory - - ct-file-drawer drawer-values ^drawer-values ^selectedp - cell-col col-head cell-row row-head - - a-row a-stack - - states make-os-event-buttons-where no-echo-text - - mg-window-activate swindow window - - do-menu-right make-menu-right-items menu-right-select menu-shortc - - current-app-universal-time user-preferences - - getcurrentthread getthreadpriority setthreadpriority - getcurrentprocess getpriorityclass setpriorityclass - - alabel ac-make-font make-style - ix-tabbed-row a-tabbed-row archosw mg-system - tn-browser mktabheaders - - ;--- ooops --------- - make-tv-node - ^tick-count - tv-tree-node-type - context-cursor - do-virtual-key - ^folder-tab-title$ - tick-count - ctradio-turn-to - ix-folder-kids - ^focused-descendant - wants-caret - - ^fm-parent - ix-paint-string - pg-no - focus-on focus-get ix-ensure-in-view - user-pref-set user-pref ^user-pref user-pref-toggle - sampleprinter - do-double-click do-right-button - folder-tab-tab-view - mouse-pos ^mouse-pos mouse-image ^mouse-image - - progress-tracker status-text percent-complete *progress-stepper* - - - )) + ) (in-package :cello) Index: cell-cultures/cello/cello.lpr diff -u cell-cultures/cello/cello.lpr:1.2 cell-cultures/cello/cello.lpr:1.3 --- cell-cultures/cello/cello.lpr:1.2 Sun Jul 4 20:59:40 2004 +++ cell-cultures/cello/cello.lpr Fri Oct 15 05:37:21 2004 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "6.2 [Windows] (May 12, 2004 22:13)"; 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) @@ -21,7 +21,6 @@ (make-instance 'module :name "ix-canvas.lisp") (make-instance 'module :name "ix-family.lisp") (make-instance 'module :name "font.lisp") - (make-instance 'module :name "ix-inline.lisp") (make-instance 'module :name "ix-grid.lisp") (make-instance 'module :name "mouse-click.lisp") (make-instance 'module :name "control.lisp") Index: cell-cultures/cello/ct-scroll-bar.lisp diff -u cell-cultures/cello/ct-scroll-bar.lisp:1.1 cell-cultures/cello/ct-scroll-bar.lisp:1.2 --- cell-cultures/cello/ct-scroll-bar.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ct-scroll-bar.lisp Fri Oct 15 05:37:21 2004 @@ -24,59 +24,53 @@ (defmodel ct-scroll-bar (control ix-inline) ((overflow :accessor overflow - :initform (c? (ecase (md-name self) - (:hz (/ (l-width (content .parent)) + :initform (c? (ecase (orientation self) + (:horizontal (/ (l-width (content .parent)) (l-width (kid1 .parent)))) - (:vt (/ (l-height (content .parent)) - (l-height (kid1 .parent))))))) + (:vertical (/ (l-height (content .parent)) + (l-height (kid1 .parent))))))) (pct-scrolled :reader pct-scrolled :initform (c? (md-value (find :sbar-slider (^kids) :key 'md-name)))) (scroll-handler :cell nil :initarg :scroll-handler :reader scroll-handler :initform (lambda (self scroll-pct) (let ((mgr (scroll-manager self))) - (ecase (md-name self) - (:hz (setf (px (content mgr)) + (ecase (orientation self) + (:horizontal (setf (px (content mgr)) (* scroll-pct (v2-h (scroll-max mgr))))) - (:vt (setf (py (content mgr)) + (:vertical (setf (py (content mgr)) (* scroll-pct (v2-v (scroll-max mgr))))))))) ) (:default-initargs ;;:pre-layer (with-layers +white+ :fill) :justify :center - :kids (c? (the-kids - (funcall (if (mac-p (upper self ix-scroller)) - 'identity 'nreverse) - (list (scroll-bar-slider (md-name self)) - (scroll-bar-stepper (md-name self) :home))) - (scroll-bar-stepper (md-name self) :end))) - :kid-slots (lambda (self) - (assert (eql :center (justify .parent))) - (ecase (md-name .parent) - (:hz (kid-slots-rowing)) - (:vt (kid-slots-stacking)))) - + :kids (c? (the-kids + (funcall (if (mac-p (upper self ix-scroller)) + 'identity 'nreverse) + (list (scroll-bar-slider (orientation self)) + (scroll-bar-stepper (md-name self) :home))) + (scroll-bar-stepper (md-name self) :end))) :visible (c? (> (^overflow) 1)) ;;:collapsed (c? (not (^visible))) - :px (c? (ecase (md-name self) - (:hz 0) - (:vt (px-maintain-pr (inset-lr .parent))))) - :py (c? (ecase (md-name self) - (:vt 0) - (:hz (py-maintain-pb (inset-lb .parent))))) + :px (c? (ecase (orientation self) + (:horizontal 0) + (:vertical (px-maintain-pr (inset-lr .parent))))) + :py (c? (ecase (orientation self) + (:vertical 0) + (:horizontal (py-maintain-pb (inset-lb .parent))))) :ll 0 :lt 0 - - :lr (c? (ecase (md-name self) - (:hz (- (inset-lr .parent) - (if (or (resize-range .parent) - (scrolls-p .parent :vt)) - *sbar-thickness* 0))) - (:vt *sbar-thickness*))) - :lb (c? (ecase (md-name self) - (:vt (+ (inset-lb .parent) - (if (or (resize-range .parent) - (scrolls-p .parent :hz) ) - (ups *sbar-thickness*) 0))) - (:hz (downs *sbar-thickness*)))))) + + :lr (c? (ecase (orientation self) + (:horizontal (- (inset-lr .parent) + (if (or (resize-range .parent) + (scrolls-p .parent :vertical)) + *sbar-thickness* 0))) + (:vertical *sbar-thickness*))) + :lb (c? (ecase (orientation self) + (:vertical (+ (inset-lb .parent) + (if (or (resize-range .parent) + (scrolls-p .parent :horizontal) ) + (ups *sbar-thickness*) 0))) + (:horizontal (downs *sbar-thickness*)))))) (def-c-output pct-scrolled () @@ -88,7 +82,8 @@ (defun scroll-bar-slider (hz-vt-value) (macrolet ((hz-vt (hz-form vt-form) `(ecase hz-vt-value - (:hz ,hz-form)(:vt ,vt-form)))) + (:horizontal ,hz-form) + (:vertical ,vt-form)))) (make-instance 'ix-slider :md-name :sbar-slider :md-value-fn (lambda (pct) @@ -165,7 +160,7 @@ (* 4 *scroll-stepper-r*)))))))) (defmethod ix-paint ((self ix-slider)) - #+not (when (eql :vt (md-name .parent)) + #+not (when (eql :vertical (md-name .parent)) (trc "slider px" (^px)) (trc "slider py" (^py)) (trc "slider ll" (^ll)) @@ -194,7 +189,7 @@ (:home ,home-form)(:end ,end-form))) (hz-vt (hz-form vt-form) `(ecase hz-vt-value - (:hz ,hz-form)(:vt ,vt-form)))) + (:horizontal ,hz-form)(:vertical ,vt-form)))) (make-instance 'ct-button :md-name home-end-value :ll (- *scroll-stepper-r*) :lt (ups *scroll-stepper-r*) Index: cell-cultures/cello/ct-scroll-pane.lisp diff -u cell-cultures/cello/ct-scroll-pane.lisp:1.1 cell-cultures/cello/ct-scroll-pane.lisp:1.2 --- cell-cultures/cello/ct-scroll-pane.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ct-scroll-pane.lisp Fri Oct 15 05:37:21 2004 @@ -28,7 +28,7 @@ slider trench prettied up |# -(defmodel ct-scroll-manager (focus control ig-zero-tl) +(defmodel ct-scroll-manager (focus control ix-zero-tl) ((content :initform nil :initarg :content :accessor content) (step-x :initform (u96ths 12) :initarg :step-x :accessor step-x) (step-y :initform (u96ths 12) :initarg :step-y :accessor step-y) @@ -56,7 +56,7 @@ (defconstant *sbar-thickness* 16) -(defmodel ix-scroller (ct-scroll-manager ig-zero-tl) +(defmodel ix-scroller (ct-scroll-manager ix-zero-tl) ((mac-p :initarg :mac-p :initform t :reader mac-p) (scroll-bars :cell nil :initform nil :initarg :scroll-bars :accessor scroll-bars) (resizeable :cell nil :initform nil :initarg :resizeable :accessor resizeable) @@ -84,11 +84,11 @@ :ll 0 :lt 0 :px 0 :py 0 :lr (c? (- (inset-lr .parent) - 2 (if (scrolls-p .parent :vt) + 2 (if (scrolls-p .parent :vertical) *sbar-thickness* 0))) :lb (c? (+ (inset-lb .parent) (ups 2) - (if (scrolls-p .parent :hz) + (if (scrolls-p .parent :horizontal) (ups *sbar-thickness*) 0))) :step-x (c? (step-x .parent)) :step-y (c? (step-y .parent))) @@ -103,7 +103,8 @@ :drag-range (c? (resize-range .parent)))) (mapcar (lambda (bar-id) (make-instance 'ct-scroll-bar - :md-name bar-id)) + :md-name bar-id + :orientation bar-id)) (scroll-bars self)))))) (defmacro uskin () Index: cell-cultures/cello/ctl-drag.lisp diff -u cell-cultures/cello/ctl-drag.lisp:1.1 cell-cultures/cello/ctl-drag.lisp:1.2 --- cell-cultures/cello/ctl-drag.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ctl-drag.lisp Fri Oct 15 05:37:21 2004 @@ -65,9 +65,9 @@ ;;;(defmethod context-cursor ((self CTDrag) kbdModifiers) ;;; (declare (ignore kbdmodifiers)) ;;; (ecase (dragdirection self) -;;; (:hz GLUT_CURSOR_LEFT_RIGHT) -;;; (:vt GLUT_CURSOR_UP_DOWN) -;;; (:hz-vt GLUT_CURSOR_CROSSHAIR))) +;;; (:horizontal GLUT_CURSOR_LEFT_RIGHT) +;;; (:vertical GLUT_CURSOR_UP_DOWN) +;;; (:horizontal-vt GLUT_CURSOR_CROSSHAIR))) (defmodel ct-poly-drag (ct-drag ix-polygon)()) Index: cell-cultures/cello/ctl-markbox.lisp diff -u cell-cultures/cello/ctl-markbox.lisp:1.1 cell-cultures/cello/ctl-markbox.lisp:1.2 --- cell-cultures/cello/ctl-markbox.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ctl-markbox.lisp Fri Oct 15 05:37:21 2004 @@ -101,20 +101,22 @@ (defmodel ct-radio-button (ct-mark-box ct-radio-item) ()) (defmodel ct-text-radio-item ( ct-radio-item ct-text)()) -(defmodel ct-radio (ix-family) +(defmodel ct-radio (ix-inline) () (:default-initargs :md-value (c-in nil))) -(defmodel ct-radio-row (ix-row ct-radio) +(defmodel ct-radio-row (ct-radio) () (:default-initargs + :orientation :horizontal :md-value (c-in nil))) -(defmodel ct-radio-stack (ix-stack ct-radio) +(defmodel ct-radio-stack (ct-radio) () (:default-initargs - :md-value (c-in nil))) + :md-value (c-in nil) + :orientation :vertical)) (defun radio-on-name (radio-values) (some (lambda (rb-value) @@ -186,8 +188,7 @@ (trc "rendering radio-push" :unscissored))) (call-next-method)) -(defmodel ct-push-toggle (ct-radio-push-button) +(defmodel ct-push-toggle (ct-toggle ct-button) () (:default-initargs - :md-value (c-in nil) - :radio (c? self))) \ No newline at end of file + :md-value (c-in nil))) \ No newline at end of file Index: cell-cultures/cello/ctl-selectable.lisp diff -u cell-cultures/cello/ctl-selectable.lisp:1.1 cell-cultures/cello/ctl-selectable.lisp:1.2 --- cell-cultures/cello/ctl-selectable.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ctl-selectable.lisp Fri Oct 15 05:37:21 2004 @@ -26,23 +26,22 @@ (defmodel ct-selector () ;; mixin at any node containing CTSelectable's - ((selection :accessor selection :initarg :selection) + ((selection :initform (c-in nil) :accessor selection :initarg :selection) (selection-focus :initarg :selection-focus :reader selection-focus :initform nil) (initial-selection :initform nil :reader initial-selection :cell nil :initarg :initial-selection) - ) - (:default-initargs - :selection (c-in nil) - )) + (multiple-choice-p :initform nil :initarg :multiple-choice-p :accessor multiple-choice-p) + (togglep :initform nil :initarg :togglep :accessor togglep) + )) (defmethod sm-unchanged-p ((self ct-selector) (slotname (eql 'selection)) new-value old-value) (equal new-value old-value)) -(defun initialselection-first (self) +(defun initial-selection-first (self) (do-like-fm-parts (it (self ct-selectable)) (when (enabled it) - (return-from initialselection-first (list it))))) + (return-from initial-selection-first (list it))))) (defmethod md-awaken :after ((self ct-selector)) (when (initial-selection self) @@ -50,11 +49,7 @@ (setf (selection self) (eko ("setting initial selection" self) (funcall (initial-selection self) self)))))) -(def-c-output selection ()) - -(defmodel ct-selector-stack (ct-selector ix-stack)()) -(defmodel ct-exclusive-stack (ct-exclusive ix-stack)()) -(defmodel ct-selector-row (ct-selector ix-row)()) +(defmodel ct-selector-inline (ct-selector ix-inline)()) ;---------- @@ -75,83 +70,41 @@ (:default-initargs :outset (u8ths 1))) -#+test? -(def-c-output kids ((self ct-details)) - ;(trc "ctdetails kids echo" newvalue oldvalue) - ) - (defmodel ct-details-exclusive (ct-exclusive ct-details)()) ;; go generic with CTSelectorNested? (defmodel ct-selectable (control) ((selectedp :initarg :selectedp - :initform (c? (bwhen (selector (selector self)) - (member self (selection selector)))) - :reader selectedp)) + :initform (c? (bwhen (selector (selector self)) + (member (^md-value) (selection selector)))) + :reader selectedp)) (:default-initargs - :bkg-color (c? (if (^enabled) - (if (^hilited) - +blue+ - (if (^selectedp) - +yellow+ - +white+)) - +lt-gray+)) - :pre-layer (with-layers (:rgba (^bkg-color)) - :fill - +black+))) +;;; nah, no image behavior here. put in mixin if desired +;;; :bkg-color (c? (if (^enabled) +;;; (if (^hilited) +;;; +blue+ +;;; (if (^selectedp) +;;; +yellow+ +;;; +white+)) +;;; +lt-gray+)) +;;; :pre-layer (with-layers (:rgba (^bkg-color)) +;;; :fill +;;; +black+) + :ct-action (lambda (self event + &aux + (buttons (evt-buttons event)) + (selector (selector self)) + (selection (selection selector)) + (value (^md-value)) + (now-selected (member value selection))) + (if (multiple-choice-p selector) + (if now-selected + (when (or (togglep selector) + (shift-key-down buttons)) + (selection-set selector (remove value selection))) + (selection-set selector (cons value selection))) + (unless now-selected + (selection-set selector value)))))) (defun selector (self) (upper self ct-selector)) -;===================================== - -(defmodel ct-exclusive (ct-selectable) - () - (:default-initargs - :ct-action #'ct-exclusive-control-action)) - -(defmethod ct-exclusive-control-action (self event) - (declare (ignorable event)) - - (with-metrics (nil nil (nil :type :time #+not :count-only #+not :space - ;; :count 2000 - :interpret-closures t - ;; :count-list (list #'md::bd-bound-slot-value) - ) "CTExclusive-controlAction") - (selection-set1 (selector self) self))) - -;===================================== - -(defmodel ct-multi-choice (ct-selectable) - () - (:default-initargs - :ct-action (lambda (self event - &aux - (buttons (evt-buttons (os-event event))) - (selector (selector self)) - (selection (selection selector))) - (selection-set selector - (if (shift-key-down buttons) - (if (member self selection) - (delete self selection) - (cons self selection)) - (list self)))))) - -;===================================== - -(defmodel ct-toggle-choice (ct-toggle ct-selectable) - () - (:default-initargs - :ct-action #'ct-toggle-choice-controlaction)) - -(defmethod ct-toggle-choice-controlaction (self event - &aux - (buttons (evt-buttons (os-event event))) - (selector (selector self)) - (selection (selection selector))) - (trc "controlaction toggle" self) - (selection-set selector - (if (member self selection) - (remove self selection) - (if (shift-key-down buttons) - (cons self selection) - (list self))))) Index: cell-cultures/cello/ctl-toggle.lisp diff -u cell-cultures/cello/ctl-toggle.lisp:1.1 cell-cultures/cello/ctl-toggle.lisp:1.2 --- cell-cultures/cello/ctl-toggle.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ctl-toggle.lisp Fri Oct 15 05:37:21 2004 @@ -40,17 +40,18 @@ ((inset :unchanged-if 'v2= :initform (mkv2 (upts 4) (upts 4))) (depressed :initarg :depressed :reader depressed :initform (c? (^hilited)))) (:default-initargs + :title$ (c? (string-capitalize (md-name self))) :text$ (c? (^title$)) :clipped t :justify-hz :center :justify-vt :center :style-id :button :skin (c? (skin .w.)) + :text-color (c? (if (^depressed) + +dk-gray+ +white+)) :pre-layer (c? (let* ((thick (min (u96ths 4) (* 0.08 (l-width self)))) (defl (if (^depressed) (downs (/ thick 3)) 0)) - (push-in (if (^depressed) (xlout (* .5 thick)) 0)) - (tx-color (if (^depressed) - +dk-gray+ +white+))) + (push-in (if (^depressed) (xlout (* .5 thick)) 0))) (declare (ignorable thick defl)) (trc nil "ctbutton" thick defl) @@ -60,7 +61,9 @@ :on (:frame-3d :edge-raised :thickness thick) - (:rgba tx-color)))))) + (:rgba (^text-color))))))) + +(defmodel ct-selectable-button (ct-selectable ct-button)()) ; ---------------- CT FSM --------------------- (defmodel ctfsm (control) @@ -116,7 +119,7 @@ (defmacro mk-twisted (twisted-name (label-class &rest label-args) (twisted-class &rest twisted-args)) - `(mk-part :twisted-group (ig-zero-tl) + `(mk-part :twisted-group (ix-zero-tl) :showkids (c-in nil) :ll (c? (ix-kid-wrap self 'pl)) :lr (c? (ix-kid-wrap self 'pr)) @@ -145,7 +148,7 @@ (defmacro mk-twisted-part (twisted-name (label$ &rest label-args) twisted-part) - `(mk-part :twisted-group (ig-zero-tl) + `(mk-part :twisted-group (ix-zero-tl) :showkids (c-in nil) :ll (c? (ix-kid-wrap self 'pl)) :lr (c? (ix-kid-wrap self 'pr)) Index: cell-cultures/cello/image.lisp diff -u cell-cultures/cello/image.lisp:1.4 cell-cultures/cello/image.lisp:1.5 --- cell-cultures/cello/image.lisp:1.4 Fri Oct 1 06:01:05 2004 +++ cell-cultures/cello/image.lisp Fri Oct 15 05:37:21 2004 @@ -45,8 +45,6 @@ (when (every 'dsp-list (kids self)) (let ((display-list-name (or .cache (gl-gen-lists 1))) (*window-rendering* (nearest self window))) - (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) @@ -97,6 +95,7 @@ ; ; appearance ; + (gui-styles :initarg :gui-styles :initform nil :accessor gui-styles) (sound :initarg :sound :initform nil :accessor sound) ; (lighting :initarg :lighting :initform nil :accessor lighting) @@ -126,10 +125,20 @@ (:default-initargs :renderer 'ix-paint )) -(defmethod ogl-dsp-list-prep progn ((self image)) - (skin self)) +(defmethod md-awaken :after ((self image)) + (assert (px self)) + (assert (py self)) + (assert (ll self)) + (assert (lt self)) + (assert (lr self)) + (assert (lb self))) + +(defmethod ogl-dsp-list-prep progn ((self image)) + (ogl-dsp-list-prep (skin self))) +(defmethod ogl-dsp-list-prep progn ((self wand-texture)) + (texture-name self)) ;------------------------------ (def-c-output mouse-over-p () Index: cell-cultures/cello/ix-family.lisp diff -u cell-cultures/cello/ix-family.lisp:1.1 cell-cultures/cello/ix-family.lisp:1.2 --- cell-cultures/cello/ix-family.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ix-family.lisp Fri Oct 15 05:37:21 2004 @@ -31,7 +31,7 @@ (effective-styles :reader effective-styles :initarg :effective-styles :initform nil #+not (ix-family-effective-styles)) - (outset :cell nil :initarg :outset :initform 0 :accessor outset) + (outset :initarg :outset :initform 0 :accessor outset) (showkids :initarg :showkids :initform nil :accessor showkids) (kids-ever-shown @@ -48,7 +48,7 @@ ;;-------- ZeroTL ---------------------------- ;; -(defmodel ig-zero-tl (ix-family) +(defmodel ix-zero-tl (ix-family) () (:default-initargs :ll (c? (- (outset self))) @@ -69,32 +69,76 @@ :lr (c? (ix-kid-wrap self 'pr)) :lb (c? (ix-kid-wrap self 'pb)))) -;----------- OfKids ----------------------- +;--------------- ix-inline ----------------------------- ; -(defmacro smkidp (outset-optr min-max attribute) - `(c? (,outset-optr - (if (^kids) - (with-dynamic-fn (roomy (kid) (not (collapsed kid))) - (,min-max ,attribute - :test roomy)) - 0) - (outset self)))) + +(defmodel ix-inline (ix-zero-tl) + ((orientation :initarg :orientation :initform nil :accessor orientation + :documentation ":vertical (for a column) or :horizontal (row)") + (justify :initarg :justify :accessor justify + :initform (c? (ecase (orientation self) + (:vertical :left) + (:horizontal :top)))) + (spacing :initarg :spacing :initform 0 :accessor spacing)) + (:default-initargs + :lr (c? (+ (^outset) + (ecase (orientation self) + (:vertical (loop for k in (^kids) + maximizing (l-width k))) + (:horizontal (bif (lk (last1 (^kids))) + (pr lk) 0))))) + :lb (c? (+ (downs (^outset)) + (ecase (orientation self) + (:vertical (bif (lk (last1 (^kids))) + (pb lk) 0)) + (:horizontal (downs (loop for k in (^kids) + maximizing (l-height k))))))) + :kid-slots (lambda (self) + (ecase (orientation .parent) + (:vertical (list + (mk-kid-slot (px :if-missing t) + (c? (^px-self-centered (justify .parent)))) + (mk-kid-slot (py) + (c? (py-maintain-pt + (^prior-sib-pb self (spacing .parent))))))) + (:horizontal (list + (mk-kid-slot (py :if-missing t) + (c? (^py-self-centered (justify .parent)))) + (mk-kid-slot (px) + (c? (px-maintain-pl + (^prior-sib-pr self (spacing .parent))))))))))) + +(defmodel ix-stack (ix-inline) + () + (:default-initargs + :orientation :vertical)) + +(defmodel ix-row (ix-inline) + () + (:default-initargs + :orientation :horizontal)) +(defmacro a-stack ((&rest stack-args) &body dd-kids) + `(mk-part ,(copy-symbol 'a-stack) (ix-inline) + , at stack-args + :orientation :vertical + :kids (c? (packed-flat! , at dd-kids)))) -(defun v2-in-subframe (super h v sub) - (if (eql super sub) ;; bingo - (values h v) - (dolist (kid (kids super)) - (multiple-value-bind (subh sub-v) - (v2-in-subframe kid h v sub) - (when subh - (return-from v2-in-subframe (values (- subh (px kid)) - (- sub-v (py kid))))))))) +(defmacro a-row ((&rest stack-args) &body dd-kids) + `(mk-part ,(copy-symbol 'a-stack) (ix-inline) + , at stack-args + :orientation :horizontal + :kids (c? (packed-flat! , at dd-kids)))) + +#| archive + +(defmodel ix-row-fv (family-values ix-row)()) +(defmodel ix-inline-fv (family-values ix-inline)()) ;-------------------------- IMMatrix ------------------------------------------ -(defmodel im-matrix (ig-zero-tl) +(defmodel im-matrix (ix-zero-tl) ((columns :cell nil :initarg :columns :initform nil :accessor columns) (indent-hz :cell nil :initarg :indent-hz :initform 0 :accessor indent-hz) (spacing-hz :cell nil :initarg :spacing-hz :initform 0 :accessor spacing-hz) @@ -121,3 +165,28 @@ (pt psib)) 0)))))))) +;--------------- IGRowFlow ---------------------------- + +(defmodel ix-row-flow (ix-row) + ((spacing-hz :cell nil :initarg :spacing-hz :initform 0 :reader spacing-hz) + (spacing-vt :cell nil :initarg :spacing-vt :initform 0 :reader spacing-vt) + (aligned :cell nil :initarg :aligned :initform nil :reader aligned)) + (:default-initargs + :lb (c? (ix-kid-wrap self 'pb)) + :kid-slots (lambda (self) + (declare (ignore self)) + (list + (mk-kid-slot (py) + (c? (py-maintain-pt + (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) + (if (> (+ ph (l-width self)) (l-width .parent)) + (^prior-sib-pb self (spacing-vt .parent)) + (^prior-sib-pt self)))))) + (mk-kid-slot (px) + (c? (px-maintain-pl + (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) + (if (> (+ ph (l-width self)) (l-width .parent)) + 0 + ph))))))))) + +|# \ No newline at end of file Index: cell-cultures/cello/ix-geometry.lisp diff -u cell-cultures/cello/ix-geometry.lisp:1.2 cell-cultures/cello/ix-geometry.lisp:1.3 --- cell-cultures/cello/ix-geometry.lisp:1.2 Sun Jul 4 20:59:40 2004 +++ cell-cultures/cello/ix-geometry.lisp Fri Oct 15 05:37:21 2004 @@ -66,6 +66,18 @@ (incf ,offset-h (px ,from)) (incf ,offset-v (py ,from)))))) +;----------- OfKids ----------------------- +; + +(defun v2-in-subframe (super h v sub) + (if (eql super sub) ;; bingo + (values h v) + (dolist (kid (kids super)) + (multiple-value-bind (subh sub-v) + (v2-in-subframe kid h v sub) + (when subh + (return-from v2-in-subframe (values (- subh (px kid)) + (- sub-v (py kid))))))))) (defun mk-gr (ap) (c-assert ap) (count-it :mk-gr) Index: cell-cultures/cello/ix-grid.lisp diff -u cell-cultures/cello/ix-grid.lisp:1.1 cell-cultures/cello/ix-grid.lisp:1.2 --- cell-cultures/cello/ix-grid.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ix-grid.lisp Fri Oct 15 05:37:21 2004 @@ -24,7 +24,7 @@ (defmacro u-grid () `(fm-parent self)) -(defmodel ix-grid (ig-zero-tl) +(defmodel ix-grid (ix-zero-tl) ((col-ct :initarg :col-ct :initform nil :accessor col-ct) (row-ct :initarg :row-ct :initform nil :accessor row-ct) ; Index: cell-cultures/cello/ix-inline.lisp diff -u cell-cultures/cello/ix-inline.lisp:1.1 cell-cultures/cello/ix-inline.lisp:1.2 --- cell-cultures/cello/ix-inline.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/ix-inline.lisp Fri Oct 15 05:37:21 2004 @@ -21,123 +21,3 @@ ;;; IN THE SOFTWARE. (in-package :cello) - -;--------------- ix-inline ----------------------------- -; - -(defmodel ix-inline (ig-zero-tl) - ((justify :cell nil :initarg :justify :initform nil :accessor justify) - (spacing :cell nil :initarg :spacing :initform 0 :accessor spacing))) - -;--------------- Stacks ------------------------------ -; - - -(defmodel ix-stack (ix-inline) - () - (:default-initargs - :lr (c? (^lr-width (+ (or (loop for k in (^kids) - maximizing (l-width k)) - 0) - (outset self)))) - :lb (c? (+ (downs (outset self)) - (bif (lk (last1 (^kids))) - (pb lk) 0))) - :justify :left - :kid-slots (lambda (self) - (declare (ignore self)) - (kid-slots-stacking)))) - -(defun kid-slots-stacking () - (list - (mk-kid-slot (px :if-missing t) - (c? (^px-self-centered (justify .parent)))) - (mk-kid-slot (py) - (c? (py-maintain-pt - (^prior-sib-pb self (spacing .parent))))))) - -(defmodel ix-stack-of-kids (ix-stack) - () - (:default-initargs - :ll (c? (- (or (loop for k in (^kids) - minimizing (pl k)) - 0) - (outset self))) - :lr (c? (+ (or (loop for k in (^kids) - maximizing (pr k)) - 0) - (outset self))) - :lb (c? (+ (downs (outset self)) - (bif (lk (last1 (^kids))) - (pb lk) 0))) - :justify :left)) - -(defmacro a-stack ((&rest stack-args) &body dd-kids) - `(mk-part ,(copy-symbol 'a-stack) (ix-stack) - , at stack-args - :kids (c? (packed-flat! , at dd-kids)))) - -(defmacro a-stack-of-kids ((&rest stack-args) &body dd-kids) - `(mk-part ,(copy-symbol 'a-stack) (ix-stack-of-kids) - , at stack-args - :kids (c? (packed-flat! , at dd-kids)))) - - - -;----------------------- IXRow ------------------------------ -; - - -(defmodel ix-row (ix-inline) - () - (:default-initargs - :ll (c? (- (outset self))) - :lt (c? (ups (outset self))) - :lb (c? (downs (outset self) (^lb-height (fm-max-kid self 'l-height)))) - :lr (c? (+ (outset self) (bif (lk (last1 (^kids))) - (pr lk) 0))) - :justify :top - :kid-slots (lambda (self) - (declare (ignore self)) - (kid-slots-rowing)))) - -(defun kid-slots-rowing () - (list - (mk-kid-slot (py :if-missing t) - (c? (^py-self-centered (justify .parent)))) - (mk-kid-slot (px) - (c? (px-maintain-pl - (^prior-sib-pr self (spacing .parent))))))) - -(defmodel ix-row-fv (family-values ix-row)()) -(defmodel ix-stack-fv (family-values ix-stack)()) -;--------------- IGRowFlow ---------------------------- - -(defmodel ix-row-flow (ix-row) - ((spacing-hz :cell nil :initarg :spacing-hz :initform 0 :reader spacing-hz) - (spacing-vt :cell nil :initarg :spacing-vt :initform 0 :reader spacing-vt) - (aligned :cell nil :initarg :aligned :initform nil :reader aligned)) - (:default-initargs - :lb (c? (ix-kid-wrap self 'pb)) - :kid-slots (lambda (self) - (declare (ignore self)) - (list - (mk-kid-slot (py) - (c? (py-maintain-pt - (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) - (if (> (+ ph (l-width self)) (l-width .parent)) - (^prior-sib-pb self (spacing-vt .parent)) - (^prior-sib-pt self)))))) - (mk-kid-slot (px) - (c? (px-maintain-pl - (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) - (if (> (+ ph (l-width self)) (l-width .parent)) - 0 - ph))))))))) - -(defmacro a-row ((&rest row-args) &body dd-kids) - `(mk-part ,(copy-symbol 'a-row) (ix-row) - , at row-args - :spacing 0 - :kids (c? (packed-flat! , at dd-kids)))) - Index: cell-cultures/cello/ix-render.lisp diff -u cell-cultures/cello/ix-render.lisp:1.3 cell-cultures/cello/ix-render.lisp:1.4 --- cell-cultures/cello/ix-render.lisp:1.3 Fri Oct 1 06:01:05 2004 +++ cell-cultures/cello/ix-render.lisp Fri Oct 15 05:37:21 2004 @@ -81,6 +81,7 @@ (let ((ixr-box (mkr 0 0 0 0))) (defmethod ix-paint :around ((self image) &aux (n (gl-name self))) + (trc nil "painting" self (^px)(^py)(^lr)) (with-bitmap-shifted ((px self)(py self)) (gl-translatef (px self) (py self) 0) Index: cell-cultures/cello/ix-styled.lisp diff -u cell-cultures/cello/ix-styled.lisp:1.2 cell-cultures/cello/ix-styled.lisp:1.3 --- cell-cultures/cello/ix-styled.lisp:1.2 Wed Sep 29 04:50:09 2004 +++ cell-cultures/cello/ix-styled.lisp Fri Oct 15 05:37:21 2004 @@ -69,10 +69,10 @@ (defun styles-default () *styles*) -(defun gui-style (style) +(defun gui-style (self style) (when style ;;(print `(gui-style ,style ,(styles-default))) - (or (find style (styles-default) :key 'id) + (or (ix-find-style self style) (find :default (styles-default) :key 'id) (break "gui-style cannot find requested style ~a" style)))) @@ -81,7 +81,7 @@ :initform nil :reader style-id) - (style :initform (c? (gui-style (^style-id))) + (style :initform (c? (gui-style self (^style-id))) :initarg :style :reader style) @@ -102,6 +102,13 @@ (with-layers (:rgba (^text-color))))))) +(defmethod ix-find-style ((self image) style-id) + (or (find style-id (^gui-styles) :key 'id) + (ix-find-style .parent style-id))) + +(defmethod ix-find-style (self style-id) + (declare (ignore self style-id))) + (defmethod ogl-dsp-list-prep progn ((self ix-styled) &aux (font (text-font self))) (assert (not *ogl-listing-p*)) (trc nil "ogl-dsp-list-prep sub-prepping font" font) @@ -110,18 +117,7 @@ (unless (ftgl::ftgl-disp-ready-p font) (fgc-set-face-size (ftgl::ftgl-get-metrics-font font) (ftgl::ftgl-size font) (ftgl::ftgl-target-res font))) - (ix-string-width self (^display-text$))) - (ftgl-texture - #+not (loop with x for c across (^display-text$) - do (pushnew (fgc-char-texture (ftgl::ftgl-get-metrics-font font)(char-code c)) x) - finally (trc "font,string,textures" font (^display-text$) x)) - #+no? (unless (ftgl::ftgl-disp-ready-p font) - (trc "setting face size" font) - (fgc-set-face-size (ftgl::ftgl-get-metrics-font font) - (ftgl::ftgl-size font) (ftgl::ftgl-target-res font))) - ;;(trc (eql 12 (ftgl::ftgl-size font)) "forcing glyphs" (ftgl::ftgl-face font) (^display-text$)) - #+not (ix-string-width self (^display-text$))) - ) + (ix-string-width self (^display-text$)))) (ftgl::ftgl-get-display-font font)) (defmethod make-style-font ((style gui-style-glut-stroke)) Index: cell-cultures/cello/menu.lisp diff -u cell-cultures/cello/menu.lisp:1.1 cell-cultures/cello/menu.lisp:1.2 --- cell-cultures/cello/menu.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/menu.lisp Fri Oct 15 05:37:21 2004 @@ -34,12 +34,14 @@ :pre-layer (with-layers +lt-gray+ :fill) :kids (c? (mapcar #'make-menu menus)))) -(defmodel ct-menu (control ix-styled ix-stack) +(defmodel ct-menu (control ix-styled ix-inline) ((items :initarg :items :reader items :initform nil)) (:default-initargs + :orientation :vertical :style-id :button :kids (c? (the-kids - (mk-part :title-items (ix-stack) + (mk-part :title-items (ix-inline) + :orientation :vertical :kids (c? (the-kids (mk-part :title (ix-text) :lighting :off @@ -63,9 +65,10 @@ -(defmodel ct-menu-items (ix-stack window) +(defmodel ct-menu-items (ix-inline window) () (:default-initargs + :orientation :vertical :self-sizing t :lighting :off :outset (u96ths 4) Index: cell-cultures/cello/pick.lisp diff -u cell-cultures/cello/pick.lisp:1.2 cell-cultures/cello/pick.lisp:1.3 --- cell-cultures/cello/pick.lisp:1.2 Sun Jul 4 20:59:40 2004 +++ cell-cultures/cello/pick.lisp Fri Oct 15 05:37:21 2004 @@ -58,7 +58,7 @@ ;;(format t "~&perspective sees aspect: ~a" aspect) (glu-perspective 45 aspect 0.1 100.0)) ;;OQ: appropriate for ortho? - (gl-matrix-mode gl_model-view) + (gl-matrix-mode gl_modelview) #+not (let ((*ogl-listing-p* target) *selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*) (with-metrics (nil nil "(funcall renderer)" self) @@ -69,7 +69,7 @@ (gl-matrix-mode gl_projection) (gl-pop-matrix) - (gl-matrix-mode gl_model-view) + (gl-matrix-mode gl_modelview) (let ((hits (gl-render-mode gl_render))) (print `(:hits ,hits)) Index: cell-cultures/cello/to-do.lisp diff -u cell-cultures/cello/to-do.lisp:1.1 cell-cultures/cello/to-do.lisp:1.2 --- cell-cultures/cello/to-do.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/to-do.lisp Fri Oct 15 05:37:21 2004 @@ -6,17 +6,11 @@ in not-to-be of Window, free os font stuff -do up a display lists slot, maybe now rather than later. read up on efficiency, -and see how deep one can go allocating display lists - when that is done, worry about not leaking foreign-allocated data look at more helpers like with-matrix, and auto-normal, and auto-detecting functions not meant to be called within begin/end -look at a lighting preview control, xyz with sliders for positioning, -sliders for ambient and diffuse - double-clicks mousedown in w, mouseup out, mmosemove back in, click still alive [glut says they fix this] @@ -31,8 +25,6 @@ get ctdrag working on :vt and both and an arbitrary (for things like z) do a polar coordinate dragger for rotation - -lights (and lighting) should be slots in MGWindow, and lights pulled in as kids of the window toggling nested off in starter-w does not redraw unchecked, tho simple cover/uncover works Index: cell-cultures/cello/window-callbacks.lisp diff -u cell-cultures/cello/window-callbacks.lisp:1.3 cell-cultures/cello/window-callbacks.lisp:1.4 --- cell-cultures/cello/window-callbacks.lisp:1.3 Fri Oct 1 06:01:05 2004 +++ cell-cultures/cello/window-callbacks.lisp Fri Oct 15 05:37:21 2004 @@ -84,33 +84,25 @@ (bwhen (w (mg-window-current)) (ix-idle w)))) -#+bzzzt -(defun dnr (n) - (locally (declare (special %displaying%)) - (print `(dnr ,n)) - (unless (and (boundp '%displaying%) %displaying%) - (let ((%displaying% t)) - (when (< n 2) - (dnr (1+ n))))))) - - (def-window-callback mg-glut-display () - (unless (or *ogl-listing-p* ;; re-entrance happens if a DLL puts up a MessageBox + (unless (or *ogl-listing-p* ;; re-entrance happens if a DLL puts up a MessageBox (c-stopped) (null *w*)) (with-metrics (nil nil "mg-glut-display") - (trc nil "mg-glut-display > about to render w " *w* (glutgetwindow)) + (trc nil "mg-glut-display > about to render w " *w* (glutgetwindow)) (window-display *w*)))) (defmethod window-display ((self window)) (bif (dl (dsp-list self)) - (gl-call-list (dsp-list self)) + (progn + (trc nil "window using disp list") + (gl-call-list (dsp-list self))) (ix-paint self)) (glut-swap-buffers) - (incf (frame-ct self)) (trc nil "window-display > rendered w " self (glutgetwindow)) + (incf (frame-ct self)) (when (display-continuous self) (trc nil "window-display > continuous specified so posting redisplay" self) (glut-post-redisplay))) Index: cell-cultures/cello/window.lisp diff -u cell-cultures/cello/window.lisp:1.3 cell-cultures/cello/window.lisp:1.4 --- cell-cultures/cello/window.lisp:1.3 Fri Oct 1 06:01:05 2004 +++ cell-cultures/cello/window.lisp Fri Oct 15 05:37:21 2004 @@ -81,6 +81,7 @@ :initform 0 :accessor gl-name-highest)) (:default-initargs + :px 0 :py 0 :kids (c? (the-kids (^content)) #+not (the-kids (mk-part :wstuff (ix-kid-sized) :px 0 :py (c? (bif (n (nsib)) @@ -386,19 +387,18 @@ (defmethod mg-window-reshape (self width height) (trc nil "mg-window-reshape" self width height) (gl-viewport 0 0 width height) + (gl-matrix-mode gl_projection) (gl-load-identity) - (trc nil "mg-window-reshape ortho" 0 width (- height) 0 *mgw-near* *mgw-far*) + (trc "mg-window-reshape ortho" 0 width (- height) 0 *mgw-near* *mgw-far*) (gl-ortho 0 width (- height) 0 *mgw-near* *mgw-far*) - (gl-load-identity) - (trc nil "mg-window-reshape > new window wid,hei:" self width height) + (trc nil "mg-window-reshape > new window wid,hei:" self width height) +;;; (gl-load-identity) (setf (lr self) (+ (ll self) (scr2log width))) (setf (lb self) (- (lt self) (scr2log height)))) - - (defun run-window (new-window &optional run-init-func) (when run-init-func (funcall run-init-func)) @@ -416,34 +416,27 @@ (bwhen (s (ix-sound-find new-window :open)) (ix-sound-install new-window s)) - #+nah (do () - ((or (c-stopped) - (zerop (glut-get-window)))) - ;;(format t "before main loop ~a | ~&" (glut-get-window)) - (progn ;; with-render-lock ((glut-get-window)) - (glutmainloopevent)) - (sleep 0.1) - ) (handler-bind ((error #'(lambda (c) (print `(bingo glut leave ,c)) (c-stop :top-handler) (glut-leave-main-loop)))) + #+fasterbutcannotbreak (glutmainloop) - #+nah ;; before re-enabling wotk out how to get idel func called if present + ;; before re-enabling wotk out how to get idle func called if present + ;;#+breakable (do () ((or (c-stopped) (zerop (glut-get-window)))) ;;(format t "before main loop ~a | ~&" (glut-get-window)) - (progn ;; with-render-lock ((glut-get-window)) - (glutmainloopevent) - ) - (sleep 0.1))))) + (glutmainloopevent) + (setf (tick-count new-window) (os-tickcount)) + (sleep 0.05))))) (defmethod ix-paint :around ((self window)) (flet ((projection () (gl-matrix-mode gl_projection) (gl-load-identity) - (trc nil "paint> win ortho! l r b t n f:" + (trc "paint> win ortho! l r b t n f:" (ll self)(lr self) (lb self)(lt self) *mgw-near* *mgw-far*) @@ -454,7 +447,7 @@ *mgw-far* ))) (projection) - (gl-matrix-mode gl_model-view) + (gl-matrix-mode gl_modelview) (gl-load-identity) (gl-light-modeli gl_light_model_two_side 0) From ktilton at common-lisp.net Mon Oct 18 22:17:03 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Tue, 19 Oct 2004 00:17:03 +0200 Subject: [cells-cvs] CVS update: cell-cultures/ftgl-int/fgc.def cell-cultures/ftgl-int/FTGLFromC.cpp cell-cultures/ftgl-int/main.cpp Message-ID: Update of /project/cells/cvsroot/cell-cultures/ftgl-int In directory common-lisp.net:/tmp/cvs-serv23354/ftgl-int Modified Files: FTGLFromC.cpp Added Files: fgc.def Removed Files: main.cpp Log Message: Bring FTGL glue up-to-date Date: Tue Oct 19 00:16:56 2004 Author: ktilton Index: cell-cultures/ftgl-int/FTGLFromC.cpp diff -u cell-cultures/ftgl-int/FTGLFromC.cpp:1.1 cell-cultures/ftgl-int/FTGLFromC.cpp:1.2 --- cell-cultures/ftgl-int/FTGLFromC.cpp:1.1 Sat Jun 26 20:38:42 2004 +++ cell-cultures/ftgl-int/FTGLFromC.cpp Tue Oct 19 00:16:55 2004 @@ -1,7 +1,26 @@ -/* CHANGED: frgo, 2004-02-22 */ -/* $Header: /project/cells/cvsroot/cell-cultures/ftgl-int/FTGLFromC.cpp,v 1.1 2004/06/26 18:38:42 ktilton Exp $ */ - #include +/* +;;; +;;; Copyright ? 2004 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. +*/ #include "FTGLBitmapFont.h" #include "FTBitmapGlyph.h" @@ -17,128 +36,116 @@ #include "FTGLPolygonFont.h" #include "FTPolyGlyph.h" -#include "FTGLOutlineFont.h" -#include "FTOutlineGlyph.h" - -#include "FTGLExtrdFont.h" -#include "FTExtrdGlyph.h" +#include "FTGLOutlineFont.h" +#include "FTOutlineGlyph.h" -#ifdef _WIN32 -#define __stdcall __stdcall -#else -#define __stdcall -#endif +#include "FTGLExtrdFont.h" +#include "FTExtrdGlyph.h" -// make a new extrd ctor that takes a depth parm -bool FTGLExtrdFont::FaceDepth( float new_depth ) -{ - Depth( new_depth ); - - return FaceSize( this->FaceSize(), 96 ); // force new glyphs -} -#if defined(__cplusplus) extern "C" { -#endif -bool __stdcall fgcSetFaceSize( FTFont *f, - unsigned int faceSize, - unsigned int res ) -{ - return f->FaceSize( faceSize, res ); -} -float __stdcall fgcAscender( FTFont *f ) -{ - return f->Ascender(); + void __stdcall fgcBuildGlyphs( FTFont* f ) + { + f->BuildGlyphs(); + } + + bool __stdcall fgcSetFaceSize( FTFont* f + , unsigned int faceSize + , unsigned int res ) + { + return f->FaceSize( faceSize, res ); + } + + +float __stdcall fgcAscender( FTFont* f ) { + return f->Ascender( ); } -float __stdcall fgcDescender( FTFont *f ) -{ - return f->Descender( ); +float __stdcall fgcDescender( FTFont* f ) { + return f->Descender( ); } -float __stdcall fgcStringAdvance( FTFont *f, - const char *string ) -{ - return f->Advance( string ); +float __stdcall fgcStringAdvance( FTFont* f, const char* string ) { + return f->Advance( string ); } -float __stdcall fgcStringX( FTFont *f, - const char *string ) +int __stdcall fgcCharTexture( FTFont* f, int chr ) { + return ((FTGlyph *) f->FontGlyph( chr ))->glRendering(); + //return f->GlyphRendering( chr ); +} +/* +void FTFont::DoRender( const unsigned int chr, const unsigned int nextChr) { - float llx = 0.0f; /* frgo: clean inits for all vars ! */ - float lly = 0.0f; - float llz = 0.0f; - float urx = 0.0f; - float ury = 0.0f; - float urz = 0.0f; - - f->BBox( string, llx, lly, llz, urx, ury, urz ); - - return llx; /* frgo: Hm? This always returns 0.0 ... Why ? */ + CheckGlyph( chr); + + FTPoint kernAdvance = glyphList->Render( chr, nextChr, pen); + + pen.x += kernAdvance.x; + pen.y += kernAdvance.y; +}*/ + + + +float __stdcall fgcStringX( FTFont* f, const char* string ) { + float llx,lly,llz,urx,ury,urz; + + f->BBox( string, llx, lly, llz, urx, ury, urz ); + return llx; } -void __stdcall fgcRender( FTFont *f, - const char *string ) -{ - f->Render( string ); +void __stdcall fgcRender( FTFont* f, const char *string ) { + f->Render( string ); } -void __stdcall fgcFree( FTFont *f ) -{ - delete f; +void __stdcall fgcFree( FTFont* f ) { + delete f; } //--------- Bitmap ---------------------------------------------- -FTGLBitmapFont * __stdcall fgcBitmapMake( const char* fontname ) -{ - return new FTGLBitmapFont( fontname ); +FTGLBitmapFont* __stdcall fgcBitmapMake( const char* fontname ) { + return new FTGLBitmapFont( fontname ); } //--------- Pixmap ---------------------------------------------- -FTGLPixmapFont * __stdcall fgcPixmapMake( const char* fontname ) -{ - return new FTGLPixmapFont( fontname ); +FTGLPixmapFont* __stdcall fgcPixmapMake( const char* fontname ) { + return new FTGLPixmapFont( fontname ); } //--------- Texture ---------------------------------------------- -FTGLTextureFont * __stdcall fgcTextureMake( const char* fontname ) -{ - return new FTGLTextureFont( fontname ); +FTGLTextureFont* __stdcall fgcTextureMake( const char* fontname ) { + return new FTGLTextureFont( fontname ); } //--------- Polygon ---------------------------------------------- -FTGLPolygonFont * __stdcall fgcPolygonMake( const char* fontname ) -{ - return new FTGLPolygonFont( fontname ); +FTGLPolygonFont* __stdcall fgcPolygonMake( const char* fontname ) { + return new FTGLPolygonFont( fontname ); } //--------- Outline ---------------------------------------------- -FTGLOutlineFont * __stdcall fgcOutlineMake( const char* fontname ) -{ - return new FTGLOutlineFont( fontname ); +FTGLOutlineFont* __stdcall fgcOutlineMake( const char* fontname ) { + return new FTGLOutlineFont( fontname ); } //--------- Extruded Polygon ------------------------------------- -FTGLExtrdFont * __stdcall fgcExtrudedMake( const char* fontname ) -{ - return new FTGLExtrdFont( fontname ); +FTGLExtrdFont* __stdcall fgcExtrudedMake( const char* fontname ) { + return new FTGLExtrdFont( fontname ); } -bool __stdcall fgcSetFaceDepth( FTGLExtrdFont *f, - float depth ) -{ - return f->FaceDepth( depth ); + +bool __stdcall fgcSetFaceDepth( FTGLExtrdFont* f + , float depth ) { + f->Depth( depth ); + return true; } -#if defined(__cplusplus) -} // extern "C" -#endif + +} From ktilton at common-lisp.net Tue Oct 19 03:47:37 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Tue, 19 Oct 2004 05:47:37 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cellodemo/cellodemo.lpr cell-cultures/cellodemo/demo-window.lisp cell-cultures/cellodemo/hedron-decoration.lisp cell-cultures/cellodemo/hedron-render.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cellodemo In directory common-lisp.net:/tmp/cvs-serv12927/cellodemo Modified Files: cellodemo.lpr demo-window.lisp hedron-decoration.lisp hedron-render.lisp Log Message: Delete copy of celtic mainly Date: Tue Oct 19 05:47:33 2004 Author: ktilton Index: cell-cultures/cellodemo/cellodemo.lpr diff -u cell-cultures/cellodemo/cellodemo.lpr:1.3 cell-cultures/cellodemo/cellodemo.lpr:1.4 --- cell-cultures/cellodemo/cellodemo.lpr:1.3 Wed Sep 29 04:50:11 2004 +++ cell-cultures/cellodemo/cellodemo.lpr Tue Oct 19 05:47:33 2004 @@ -11,8 +11,8 @@ (make-instance 'module :name "tutor-geometry.lisp") (make-instance 'module :name "light-panel.lisp") (make-instance 'module :name "hedron-render.lisp") - (make-instance 'module :name - "hedron-decoration.lisp")) + (make-instance 'module :name "hedron-decoration.lisp") + (make-instance 'module :name "virtual-human.lisp")) :projects (list (make-instance 'project-module :name "..\\cello\\cello")) :libraries nil Index: cell-cultures/cellodemo/demo-window.lisp diff -u cell-cultures/cellodemo/demo-window.lisp:1.4 cell-cultures/cellodemo/demo-window.lisp:1.5 --- cell-cultures/cellodemo/demo-window.lisp:1.4 Fri Oct 15 05:37:30 2004 +++ cell-cultures/cellodemo/demo-window.lisp Tue Oct 19 05:47:33 2004 @@ -33,7 +33,7 @@ :focus (c-in nil) :display-continuous (c-in t) :clear-rgba (list 0 0 0 1) - :lb (c-in (downs 650))))) + :lb (c-in (downs 1000))))) (defun demo-scroller () (mk-part :demo-scroller (ix-zero-tl) @@ -118,8 +118,8 @@ (:close . "close-window")) :idler nil :ll 0 :lt 0 - :lr (c-in (scr2log 900)) - :lb (c-in (scr2log -900)) + :lr (c-in (scr2log 1000)) + :lb (c-in (scr2log -1500)) :fixed-lighting (list (make-instance 'light :id gl_light6 :enabled t Index: cell-cultures/cellodemo/hedron-decoration.lisp diff -u cell-cultures/cellodemo/hedron-decoration.lisp:1.3 cell-cultures/cellodemo/hedron-decoration.lisp:1.4 --- cell-cultures/cellodemo/hedron-decoration.lisp:1.3 Fri Oct 15 05:37:30 2004 +++ cell-cultures/cellodemo/hedron-decoration.lisp Tue Oct 19 05:47:33 2004 @@ -32,7 +32,7 @@ (mk-part :spinning (ct-check-text) :title$ "spinning") (mk-part :wireframe (ct-check-text) - :md-value (c-in nil) + :md-value (c-in t) :title$ "wireframe" :clipped nil :enabled t)) @@ -86,7 +86,7 @@ (a-row () (hedron-shapes) (test-image-group :shape-backer "Backdrops" "hedron-bkgs") - (test-image-group :shape-skin "Skin" "shapers" #+not "mandelbrot")) + (test-image-group :shape-skin "Skin" "shapers" "cloudy")) (hedron-texxing))))) (defun hedron-shapes () Index: cell-cultures/cellodemo/hedron-render.lisp diff -u cell-cultures/cellodemo/hedron-render.lisp:1.3 cell-cultures/cellodemo/hedron-render.lisp:1.4 --- cell-cultures/cellodemo/hedron-render.lisp:1.3 Fri Oct 15 05:37:30 2004 +++ cell-cultures/cellodemo/hedron-render.lisp Tue Oct 19 05:47:33 2004 @@ -58,43 +58,23 @@ (draw-test-nurb nurb)) (defparameter *hill* (make-ff-array :float 0 0 0 0 1 1 1 1)) -(defparameter *hill-controls* (make-ff-array :float -3.0 -3.0 -9 -3.0 -1.0 -9 -3.0 1.0 - -9 -3.0 3.0 -9 -1.0 -3.0 -9 -1.0 -1.0 9 -1.0 1.0 9 -1.0 - 3.0 -9 1.0 -3.0 -9 1.0 -1.0 9 1.0 1.0 9 1.0 3.0 -9 3.0 - -3.0 -9 3.0 -1.0 -9 3.0 1.0 -9 3.0 3.0 -9) - #+not (loop with fv = (fgn-alloc 'glfloat 48 :testnurb) - for u below 4 do - (loop for v below 4 - for base = (+ (* u 12) (* v 3)) - do (setf (eltf fv (+ base 0)) (* 2 (- u 1.5))) - (setf (eltf fv (+ base 1)) (* 2 (- v 1.5))) - (setf (eltf fv (+ base 2)) - (* 3 (if (and (or (eql u 1)(eql u 2)) - (or (eql v 1)(eql v 2))) - 3 -3)))) - finally (return fv))) - -(defparameter *dump-matrix* (fgn-alloc 'glfloat 16 :dump-matrix)) -(defun dump-matrix (matrix-id msg) - (gl-get-floatv matrix-id *dump-matrix*) - (format t "~&~a > ~a matrix> ~{~a ~}" msg - (cond ((eql matrix-id gl_modelview_matrix) 'modelview) - ((eql matrix-id GL_PROJECTION_MATRIX) 'projection)) - (loop for n below 16 collecting (eltf *dump-matrix* n)))) - -(defun dump-viewport ( msg) - (gl-get-floatv GL_VIEWPORT *dump-matrix*) - (format t "~&~a > viewport> ~{~a ~}" msg - (loop for n below 4 collecting (eltf *dump-matrix* n)))) - -;;;glGetFloatv(GL_MODELVIEW_MATRIX,modelview); -;;; glGetFloatv(GL_PROJECTION_MATRIX,projection); -;;; glGetIntegerv(GL_VIEWPORT,viewport); -;;; gluLoadSamplingMatrices (Nurb, modelview, projection, viewport); - +(defparameter *hill-controls* + (let ((m 3) (d 2)) + (loop with fv = (fgn-alloc 'glfloat 48 :testnurb) + for u below 4 do + (loop for v below 4 + for base = (+ (* u 12) (* v 3)) + do (setf (eltf fv (+ base 0)) (- (* m u) d)) + (setf (eltf fv (+ base 1)) (- (* m v) d)) + (setf (eltf fv (+ base 2)) + (* 3 (if (and (or (eql u 1)(eql u 2)) + (or (eql v 1)(eql v 2))) + d (- d))))) + finally (return fv)))) + (defun draw-test-nurb (nurb) - (glu-nurbs-property nurb glu_sampling_tolerance 5) - (glu-nurbs-property nurb glu_auto_load_matrix gl_false) + (glu-nurbs-property nurb glu_sampling_tolerance 1) + ;(glu-nurbs-property nurb glu_auto_load_matrix gl_false) (gl-enable gl_lighting) (gl-enable gl_light0) @@ -102,11 +82,23 @@ (gl-enable gl_auto_normal) (gl-enable gl_normalize) - (gl-rotatef 330 1 0 0) + ;(gl-rotatef 330 1 0 0) (gl-scalef .25 .25 .25) (glu-begin-surface nurb) (glu-nurbs-surface nurb 8 *hill* 8 *hill* 12 3 *hill-controls* 4 4 gl_map2_vertex_3) - (glu-end-surface nurb)) + (glu-end-surface nurb) + + (gl-point-size 5) + (gl-disable gl_lighting) + (gl-color3f 1 1 0) + (gl-begin gl_points) + (loop for u below 4 do + (loop for v below 4 + for base = (+ (* u 12) (* v 3)) + do (gl-vertex3f (eltf *hill-controls* (+ base 0)) + (eltf *hill-controls* (+ base 1)) + (eltf *hill-controls* (+ base 2))))) + (gl-end)) (defparameter *sponge-offset* (loop with fv = (fgn-alloc 'gldouble 3 :sponge) for n below 3 @@ -232,6 +224,6 @@ (gl-disable gl_texture_gen_r) (gl-disable gl_texture_gen_q) - (gl-matrix-mode gl_projection)) + #+hunh (gl-matrix-mode gl_projection)) (gl-matrix-mode gl_modelview)) From ktilton at common-lisp.net Tue Oct 19 03:47:38 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Tue, 19 Oct 2004 05:47:38 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cl-opengl/ogl-utils.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cl-opengl In directory common-lisp.net:/tmp/cvs-serv12927/cl-opengl Modified Files: ogl-utils.lisp Log Message: Delete copy of celtic mainly Date: Tue Oct 19 05:47:37 2004 Author: ktilton Index: cell-cultures/cl-opengl/ogl-utils.lisp diff -u cell-cultures/cl-opengl/ogl-utils.lisp:1.3 cell-cultures/cl-opengl/ogl-utils.lisp:1.4 --- cell-cultures/cl-opengl/ogl-utils.lisp:1.3 Fri Oct 15 05:37:55 2004 +++ cell-cultures/cl-opengl/ogl-utils.lisp Tue Oct 19 05:47:37 2004 @@ -244,3 +244,15 @@ (if (consp arg) (mapcan 'flatten arg) (list arg))) args)) + + +(defparameter *dump-matrix* (fgn-alloc 'glfloat 16 :dump-matrix)) +(defun dump-matrix (matrix-id msg) + (gl-get-floatv matrix-id *dump-matrix*) + (format t "~&~a > ~a matrix> ~{~a ~}" msg + (cond ((eql matrix-id gl_modelview_matrix) 'modelview) + ((eql matrix-id GL_PROJECTION_MATRIX) 'projection)) + (loop for n below 16 collecting (eltf *dump-matrix* n)))) + + + From ktilton at common-lisp.net Tue Oct 19 03:47:38 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Tue, 19 Oct 2004 05:47:38 +0200 Subject: [cells-cvs] CVS update: cell-cultures/ffi-extender/arrays.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/ffi-extender In directory common-lisp.net:/tmp/cvs-serv12927/ffi-extender Modified Files: arrays.lisp Log Message: Delete copy of celtic mainly Date: Tue Oct 19 05:47:38 2004 Author: ktilton Index: cell-cultures/ffi-extender/arrays.lisp diff -u cell-cultures/ffi-extender/arrays.lisp:1.1 cell-cultures/ffi-extender/arrays.lisp:1.2 --- cell-cultures/ffi-extender/arrays.lisp:1.1 Sat Jun 26 20:38:42 2004 +++ cell-cultures/ffi-extender/arrays.lisp Tue Oct 19 05:47:37 2004 @@ -79,8 +79,6 @@ (,ptr (uffi:allocate-foreign-object ,type ,amt))) (call-fgn-alloc ,type ,amt ,ptr (list , at keys))))) - - (defun call-fgn-alloc (type amt ptr keys) ;;(print `(fgnalloc ,type ,amt ,keys)) (fgn-ptr (car (push (make-fgn :id keys From ktilton at common-lisp.net Thu Oct 21 17:50:20 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 21 Oct 2004 19:50:20 +0200 Subject: [cells-cvs] CVS update: cell-cultures/config/cellocore-config.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/config In directory common-lisp.net:/tmp/cvs-serv30733/config Removed Files: cellocore-config.lisp Log Message: cleaning up config process Date: Thu Oct 21 19:50:20 2004 Author: ktilton From ktilton at common-lisp.net Thu Oct 28 00:08:56 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:08:56 +0200 Subject: [cells-cvs] CVS update: cell-cultures/build-sys-kt.lisp cell-cultures/build.lisp cell-cultures/cello-config.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures In directory common-lisp.net:/tmp/cvs-serv27567 Modified Files: build-sys-kt.lisp build.lisp cello-config.lisp Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:08:54 2004 Author: ktilton Index: cell-cultures/build-sys-kt.lisp diff -u cell-cultures/build-sys-kt.lisp:1.1 cell-cultures/build-sys-kt.lisp:1.2 --- cell-cultures/build-sys-kt.lisp:1.1 Sat Jun 26 20:38:32 2004 +++ cell-cultures/build-sys-kt.lisp Thu Oct 28 02:08:54 2004 @@ -9,7 +9,7 @@ (source-directory (merge-pathnames (make-pathname :directory `(:relative , at path)) - *devel-root*))) + cl-user::*cell-cultures-directory*))) (let ( #+cmu18 (ext:*derive-function-types* nil) Index: cell-cultures/build.lisp diff -u cell-cultures/build.lisp:1.2 cell-cultures/build.lisp:1.3 --- cell-cultures/build.lisp:1.2 Sun Jul 4 20:59:39 2004 +++ cell-cultures/build.lisp Thu Oct 28 02:08:54 2004 @@ -8,62 +8,55 @@ ;; and in configure.lisp ;; ---------------------------------------------- -;;; ---- Iff you do not have ASDF loaded.... -;;; -#-(or asdf allegro-ide) -(load (merge-pathnames - (make-pathname - :name "asdf" - :type "lisp") - *devel-root*)) - ;;; ---- -#-allegro-ide + +#+forconvenience +(load (make-pathname + :directory '(:absolute "cell-cultures" "cell-cultures-user" "config") + :name "cell-cultures-config" + :type "lisp")) + (load (merge-pathnames (make-pathname :name "build-sys-kt" :type "lisp") - *devel-root*)) + cl-user::*cell-cultures-directory*)) -;;; --- teach ASDF about LPR files -(let ((d-force t)) - (build-sys d-force "asdf-aclproj")) - -#-allegro-ide -(let ((d-force t)) - (pushnew :cells-testing *features*) - (build-sys d-force "cells") - (build-sys d-force "cells" "cells-test")) +(let ((force nil)) + (build-sys force "utils-kt")) -#-allegro-ide -(let ((d-force nil)) - (build-sys d-force "uffi") ;;; <---- lose this if you already have UFFI - (build-sys d-force "cello" "ffi-extender") - (build-sys d-force "cello" "cl-opengl")) +(progn ;;; let ((force nil)) + ;; (pushnew :cells-testing *features*) + (build-sys t "cells") + ;; (build-sys t "cells" "cells-test") + ) + +(let ((force nil)) + (build-sys force "ffi-extender") + (build-sys force "cl-opengl") + ) #+test (ogl::lesson-14) -#-allegro-ide (let ((ftgl (merge-pathnames (make-pathname :directory '(:relative "cl-ftgl") :name "cl-ftgl") - *cello-directory*))) + *cell-cultures-directory* ))) (compile-file ftgl) (load ftgl)) #+test (cl-ftgl::cl-ftgl-test) -#-allegro-ide (let ((d-force nil)) - (build-sys d-force "cello" "cells") - (build-sys d-force "cello" "cellocore") - (build-sys d-force "cello" "cl-openal") - (build-sys d-force "cello" "cl-magick") + (build-sys d-force "cl-openal") + (build-sys d-force "cl-magick") (build-sys d-force "cello") - (build-sys d-force "cello" "cellodemo")) + (build-sys d-force "cellodemo")) #+tests (cello::cello-test) + + Index: cell-cultures/cello-config.lisp diff -u cell-cultures/cello-config.lisp:1.2 cell-cultures/cello-config.lisp:1.3 --- cell-cultures/cello-config.lisp:1.2 Sun Jul 4 20:59:39 2004 +++ cell-cultures/cello-config.lisp Thu Oct 28 02:08:54 2004 @@ -1,20 +1 @@ -(in-package :cl-user) - -(defparameter *cello-directory* - (merge-pathnames - (make-pathname :directory `(:relative "cello")) - *devel-root*) - "The top of the Cello source tree") - -(defparameter *cello-config-directory* ;; contains sundry *-config.lisp files - (merge-pathnames - (make-pathname - :directory `(:relative "config")) - *devel-root*)) - -(defparameter *cello-dynlib-directory* - (merge-pathnames - (make-pathname - :directory `(:relative "dynlib")) - *devel-root*)) - +;; delete me \ No newline at end of file From ktilton at common-lisp.net Thu Oct 28 00:09:03 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:09:03 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cello/cello-ftgl.lisp cell-cultures/cello/cello.asd cell-cultures/cello/cello.lisp cell-cultures/cello/image.lisp cell-cultures/cello/ix-styled.lisp cell-cultures/cello/ix-text.lisp cell-cultures/cello/mg-geometry.lisp cell-cultures/cello/window.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cello In directory common-lisp.net:/tmp/cvs-serv27567/cello Modified Files: cello-ftgl.lisp cello.asd cello.lisp image.lisp ix-styled.lisp ix-text.lisp mg-geometry.lisp window.lisp Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:08:56 2004 Author: ktilton Index: cell-cultures/cello/cello-ftgl.lisp diff -u cell-cultures/cello/cello-ftgl.lisp:1.4 cell-cultures/cello/cello-ftgl.lisp:1.5 --- cell-cultures/cello/cello-ftgl.lisp:1.4 Fri Oct 15 05:37:21 2004 +++ cell-cultures/cello/cello-ftgl.lisp Thu Oct 28 02:08:56 2004 @@ -20,9 +20,6 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. - -(defpackage #:cello (:use #:cl-ftgl)) - (in-package :cello) (defmethod font-height ((font ftgl)) Index: cell-cultures/cello/cello.asd diff -u cell-cultures/cello/cello.asd:1.1 cell-cultures/cello/cello.asd:1.2 --- cell-cultures/cello/cello.asd:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/cello.asd Thu Oct 28 02:08:56 2004 @@ -15,8 +15,62 @@ :maintainer "Kenny Tilton " :licence "MIT" :description "A Portable Common Lisp GUI" - :long-description "The final pieces of a portable Common Lisp GUI (assumes cellocore)" - :components ((:file "cello-ftgl") + :long-description "The final pieces of a portable Common Lisp GUI" + + :depends-on (:cells :cl-opengl :cl-magick) + :components ((:file "cello") + (:file "datetime") + (:file "window-macros" :depends-on ("cello")) + (:file "clipping" :depends-on ("cello")) + (:file "mg-geometry" :depends-on ("cello")) + (:file "coordinate-xform" :depends-on ("mg-geometry")) + (:file "ix-geometry" :depends-on ("coordinate-xform")) + (:file "colors" :depends-on ("ix-geometry")) + (:file "rgb" :depends-on ("colors")) + (:file "frame" :depends-on ("rgb")) + (:file "application" :depends-on ("frame")) + (:file "image" + :depends-on ("application" + "window-macros" "clipping" + "mg-geometry" + "ix-geometry")) + + (:file "ix-layer-expand" :depends-on ("cello" "image" "frame")) + (:file "ix-canvas" :depends-on ("ix-layer-expand")) + (:file "ix-family" :depends-on ("cello" "ix-canvas")) + (:file "font" :depends-on ("image")) + (:file "ix-inline" :depends-on ("ix-geometry" "ix-family")) + (:file "ix-grid" :depends-on ("ix-inline")) + (:file "mouse-click" :depends-on ("ix-grid")) + (:file "control" :depends-on ("mouse-click")) + (:file "focus" :depends-on ("ix-canvas")) + (:file "focus-navigation" :depends-on ("focus")) + (:file "focus-utilities" :depends-on ("focus-navigation")) + (:file "ix-styled" :depends-on ("ix-canvas" "font")) + (:file "ix-text" :depends-on ("ix-styled")) + (:file "lighting" :depends-on ("ix-inline")) + (:file "window" :depends-on ("image" "lighting")) + (:file "ctl-toggle" :depends-on ("control" "ix-text")) + (:file "ctl-markbox" :depends-on ("ctl-toggle")) + (:file "ctl-drag" :depends-on ("ctl-markbox")) + (:file "ctl-selectable" :depends-on ("ctl-drag")) + (:file "slider" :depends-on ("ctl-selectable")) + (:file "window-utilities" :depends-on ("window")) + (:file "window-render" :depends-on ("window-utilities")) + (:file "window-callbacks" :depends-on ("window-utilities")) + (:file "wm-mouse" :depends-on ("window-callbacks")) + + (:file "pick" :depends-on ("wm-mouse")) + (:file "menu" :depends-on ("pick")) + (:file "ix-render" :depends-on ("window-render")) + (:file "ix-polygon" :depends-on ("ix-render")) + (:file "ct-scroll-pane" :depends-on ("ix-polygon")) + (:file "ct-scroll-bar" :depends-on ("ct-scroll-pane")) + (:file "cello-ftgl") (:file "cello-openal") (:file "cello-magick" :depends-on ("cello-ftgl")) )) + + + + Index: cell-cultures/cello/cello.lisp diff -u cell-cultures/cello/cello.lisp:1.2 cell-cultures/cello/cello.lisp:1.3 --- cell-cultures/cello/cello.lisp:1.2 Fri Oct 15 05:37:21 2004 +++ cell-cultures/cello/cello.lisp Thu Oct 28 02:08:56 2004 @@ -25,27 +25,11 @@ (:nicknames :clo) (:use #:common-lisp - #-cormanlisp #:clos + #-(or cormanlisp mcl) #:clos #:utils-kt #:cells #:ffx #:cl-opengl - ) - ;;; (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc) - ) + #:cl-ftgl + #:cl-magick)) - -(in-package :cello) - -(defparameter *cello-runtime-directory* :unconfigured) -(defparameter *user-temp-directory* :unconfigured) - -(load (merge-pathnames "cellocore-config.lisp" - cl-user::*cello-config-directory*)) - -(defun cellocore-test () - "to be announced") - -(defun cello-runtime-file (file) - (merge-pathnames file - *cello-runtime-directory*)) \ No newline at end of file Index: cell-cultures/cello/image.lisp diff -u cell-cultures/cello/image.lisp:1.5 cell-cultures/cello/image.lisp:1.6 --- cell-cultures/cello/image.lisp:1.5 Fri Oct 15 05:37:21 2004 +++ cell-cultures/cello/image.lisp Thu Oct 28 02:08:56 2004 @@ -34,30 +34,60 @@ (declare (ignore self)) (assert (not *ogl-listing-p*))) -(defvar *window-rendering*) +(defvar *ogl-shared-resource-tender*) + +(defclass ogl-shared-resource-tender () + ((display-lists :initform nil :accessor display-lists) + (quadrics :initform nil :accessor quadrics) + (textures :initform nil :accessor textures))) + +(defmethod not-to-be :before ((self ogl-shared-resource-tender)) + (loop for (nil . dl) in (display-lists self) + do (gl-delete-lists dl 1) + finally (setf (display-lists self) nil)) + (loop for (nil . q) in (quadrics self) + do (glu-delete-quadric q))) + +(defmethod ogl-shared-resource-tender ((self ogl-shared-resource-tender)) + self) + +(defmethod ogl-shared-resource-tender (other) + (c-break "ogl-shared-resource-tender undefined for ~a" other)) + +(defmethod ogl-node-window (other) + (c-break "ogl-node-window undefined for ~a" other)) (defmodel ogl-node () ((dsp-list :initarg :dsp-list :accessor dsp-list :initform (c-formula (:lazy :until-asked) - (assert *w*) - (assert (not *ogl-listing-p*)) - (ogl-dsp-list-prep self) - (when (every 'dsp-list (kids self)) - (let ((display-list-name (or .cache (gl-gen-lists 1))) - (*window-rendering* (nearest self window))) - (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)))) + (assert *w*) + (assert (not *ogl-listing-p*)) + (ogl-dsp-list-prep self) + (when (every 'dsp-list (kids self)) + (let ((display-list-name (or .cache (gl-gen-lists 1))) + (*ogl-shared-resource-tender* + (ogl-shared-resource-tender 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 (ogl-node-window self)) t) + display-list-name)))) (gl-name :initarg :gl-name :initform nil :accessor gl-name) (renderer :initarg :renderer :initform nil :accessor renderer))) +(defmethod not-to-be :after ((self ogl-node)) + (bwhen (dl (^dsp-list)) + (gl-delete-lists dl 1))) + + + + ;;;(defmethod ix-render-prep (self) ;;; (declare (ignore self))) ;;; @@ -133,12 +163,19 @@ (assert (lr self)) (assert (lb self))) +(defmethod ogl-shared-resource-tender ((self image)) + .w.) + +(defmethod ogl-node-window ((self image)) + .w.) (defmethod ogl-dsp-list-prep progn ((self image)) (ogl-dsp-list-prep (skin self))) (defmethod ogl-dsp-list-prep progn ((self wand-texture)) - (texture-name self)) + (texture-name self)) + + ;------------------------------ (def-c-output mouse-over-p () Index: cell-cultures/cello/ix-styled.lisp diff -u cell-cultures/cello/ix-styled.lisp:1.3 cell-cultures/cello/ix-styled.lisp:1.4 --- cell-cultures/cello/ix-styled.lisp:1.3 Fri Oct 15 05:37:21 2004 +++ cell-cultures/cello/ix-styled.lisp Thu Oct 28 02:08:56 2004 @@ -109,16 +109,16 @@ (defmethod ix-find-style (self style-id) (declare (ignore self style-id))) + (defmethod ogl-dsp-list-prep progn ((self ix-styled) &aux (font (text-font self))) (assert (not *ogl-listing-p*)) (trc nil "ogl-dsp-list-prep sub-prepping font" font) (typecase font (ftgl-extruded (unless (ftgl::ftgl-disp-ready-p font) - (fgc-set-face-size (ftgl::ftgl-get-metrics-font font) - (ftgl::ftgl-size font) (ftgl::ftgl-target-res font))) - (ix-string-width self (^display-text$)))) - (ftgl::ftgl-get-display-font font)) + (setf (ftgl::ftgl-disp-ready-p font) t) + (fgc-set-face-size (ftgl-ensure-ifont font) + (ftgl::ftgl-size font) (ftgl::ftgl-target-res font)))))) (defmethod make-style-font ((style gui-style-glut-stroke)) (make-font-glut-stroke Index: cell-cultures/cello/ix-text.lisp diff -u cell-cultures/cello/ix-text.lisp:1.3 cell-cultures/cello/ix-text.lisp:1.4 --- cell-cultures/cello/ix-text.lisp:1.3 Fri Oct 1 06:01:05 2004 +++ cell-cultures/cello/ix-text.lisp Thu Oct 28 02:08:56 2004 @@ -69,6 +69,18 @@ (:default-initargs :lighting :off)) + +(defmethod ogl-dsp-list-prep progn ((self ix-text) &aux (font (text-font self))) + (assert (not *ogl-listing-p*)) + (trc nil "ogl-dsp-list-prep sub-prepping font" font) + (typecase font + (ftgl-extruded + (unless (ftgl::ftgl-disp-ready-p font) + (setf (ftgl::ftgl-disp-ready-p font) t) + (fgc-set-face-size (ftgl-ensure-ifont font) + (ftgl::ftgl-size font) (ftgl::ftgl-target-res font))) + (ix-string-width self (^display-text$))))) + (defmacro alabel (text &rest key-arg-pairs) `(cells::make-part (gensym "ALABEL") 'ix-text , at key-arg-pairs Index: cell-cultures/cello/mg-geometry.lisp diff -u cell-cultures/cello/mg-geometry.lisp:1.1 cell-cultures/cello/mg-geometry.lisp:1.2 --- cell-cultures/cello/mg-geometry.lisp:1.1 Sat Jun 26 20:38:33 2004 +++ cell-cultures/cello/mg-geometry.lisp Thu Oct 28 02:08:56 2004 @@ -38,7 +38,8 @@ (defun mkv2 (h v) (make-v2 :h h :v v)) (defun v2= (a b) - (and (= (v2-h a)(v2-h b)) + (and a b + (= (v2-h a)(v2-h b)) (= (v2-v a)(v2-v b)))) (defun v2-add (p1 p2) Index: cell-cultures/cello/window.lisp diff -u cell-cultures/cello/window.lisp:1.4 cell-cultures/cello/window.lisp:1.5 --- cell-cultures/cello/window.lisp:1.4 Fri Oct 15 05:37:21 2004 +++ cell-cultures/cello/window.lisp Thu Oct 28 02:08:56 2004 @@ -24,12 +24,10 @@ ;------------- Window --------------- ; -(defmodel window (focuser ix-lit-scene control) +(defmodel window (focuser ix-lit-scene control ogl-shared-resource-tender) ( (glutw :initarg :glutw :accessor glutw :initform (c? (without-c-dependency (glutw-create self)))) - (display-lists :cell nil :initform nil :accessor display-lists) - (quadrics :cell nil :initform nil :accessor quadrics) (redisplayp :cell nil :initarg :redisplayp :initform nil :accessor redisplayp) (glut-xy :initarg :glut-xy :unchanged-if 'v2= :initform (mkv2 96 96) :accessor glut-xy) @@ -114,6 +112,12 @@ (defmethod ogl-dsp-list-prep progn ((self window)) (glutw self)) +(defmethod ogl-node-window ((self window)) + self) + +(defmethod ogl-shared-resource-tender ((self window)) + self) + (defun window-menus-basic () (list (list "File" @@ -363,23 +367,7 @@ (when must-find-p (c-break "no mgw matches glutw ~d" gw))))))) -(defmethod ogl-list-cache ((self image)) - (display-lists .w.)) - -(defmethod (setf ogl-list-cache) (new-value (self image)) - (setf (ogl-list-cache .w.) new-value)) - -(defmethod ogl-list-cache ((self window)) - (display-lists self)) - -(defmethod (setf ogl-list-cache) (new-value (self window)) - (setf (display-lists self) new-value)) - (defmethod not-to-be :before ((self window)) - (loop for (nil . q) in (quadrics self) - do - (glu-delete-quadric q)) - (ogl-lists-delete self) (when (upper self window) ;; better way to detect appropriateness? (when (glutw self) (glut-destroy-window (glutw self))))) @@ -436,7 +424,7 @@ (flet ((projection () (gl-matrix-mode gl_projection) (gl-load-identity) - (trc "paint> 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*) @@ -460,7 +448,7 @@ (with-metrics (nil nil "ix-paint window call next") (call-next-method))))) -(defun w-quadric-ensure (key) - (or (cdr (assoc key (quadrics *window-rendering*))) +(defun w-quadric-ensure (ogl-resource-tender key) + (or (cdr (assoc key (quadrics ogl-resource-tender))) (cdar (push (cons key (glu-new-quadric)) - (quadrics *window-rendering*))))) \ No newline at end of file + (quadrics ogl-resource-tender))))) \ No newline at end of file From ktilton at common-lisp.net Thu Oct 28 00:09:07 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:09:07 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cellodemo/cellodemo.lisp cell-cultures/cellodemo/demo-window.lisp cell-cultures/cellodemo/hedron-decoration.lisp cell-cultures/cellodemo/light-panel.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cellodemo In directory common-lisp.net:/tmp/cvs-serv27567/cellodemo Modified Files: cellodemo.lisp demo-window.lisp hedron-decoration.lisp light-panel.lisp Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:09:03 2004 Author: ktilton Index: cell-cultures/cellodemo/cellodemo.lisp diff -u cell-cultures/cellodemo/cellodemo.lisp:1.3 cell-cultures/cellodemo/cellodemo.lisp:1.4 --- cell-cultures/cellodemo/cellodemo.lisp:1.3 Fri Oct 15 05:37:30 2004 +++ cell-cultures/cellodemo/cellodemo.lisp Thu Oct 28 02:09:03 2004 @@ -22,15 +22,9 @@ (in-package :cello) -(defparameter *cellodemo-images* :unconfigured) - - -(load (merge-pathnames "cellodemo-config.lisp" - cl-user::*cello-config-directory*)) - (defun demo-image-subdir (subdir) (merge-pathnames (make-pathname :directory `(:relative ,(string subdir))) - *cellodemo-images*)) + cl-user::*cell-cultures-graphics-directory*)) (defun demo-image-file (subdir file) (merge-pathnames file Index: cell-cultures/cellodemo/demo-window.lisp diff -u cell-cultures/cellodemo/demo-window.lisp:1.5 cell-cultures/cellodemo/demo-window.lisp:1.6 --- cell-cultures/cellodemo/demo-window.lisp:1.5 Tue Oct 19 05:47:33 2004 +++ cell-cultures/cellodemo/demo-window.lisp Thu Oct 28 02:09:03 2004 @@ -22,7 +22,6 @@ (in-package :cello) - (defun cello-test () (let ((cells::*c-debug* (get-internal-real-time))) (run-stylish-demos '(light-panel ft-jpg tu-geo ftgl-test demo-scroller) @@ -42,7 +41,11 @@ :px 48 :py -48 :outset (u8ths 2) :skin (c? (wand-ensure-typed 'wand-texture - (cello-runtime-file "brushdmtl.jpg"))) + (merge-pathnames + (make-pathname + :name "brushdmtl" + :type "jpg") + cl-user::*cell-cultures-graphics-directory*))) :pre-layer (c? (let ((tx-name (texture-name (^skin))) (tx-size (image-size (^skin)))) (with-layers :on +white+ @@ -132,9 +135,8 @@ :wand (magick-wand-template) :splice-wand (magick-wand-template) :pathname (merge-pathnames - (make-pathname - :name "bingo" :type "mpg") - *user-temp-directory*)))) + (make-pathname :name "bingo" :type "mpg") + cl-user::*cell-cultures-output-directory*)))) :display-continuous nil :md-name :demo-w @@ -148,11 +150,10 @@ :snapshot-pathnamer (lambda (self) (merge-pathnames (make-pathname - :directory `(:relative "graphics" "out") :name (format nil "snap-me-~3,,,'0 at A" (snapshot-release-id self)) :type "jpg") - cl-user::*devel-root*)) + cl-user::*cell-cultures-output-directory*)) :pre-layer (c? (with-layers +white+ @@ -233,7 +234,7 @@ (defun demo-control-panel () (a-row (:spacing (u8ths 2) :justify :center) - #+shh (mk-part :rate (frame-rate-text)) + (mk-part :rate (frame-rate-text)) (a-stack (:spacing (u16ths 1)) (texture-picker) (demo-picker)) @@ -268,7 +269,7 @@ (defun texture-picker (&aux (backdrops (directory - (demo-image-subdir "backdrops")))) + (demo-image-subdir "window-bkgs")))) (a-row (:spacing (u8ths 1)) (alabel "Skins") (mk-part :texture-picker (ct-radio-row) Index: cell-cultures/cellodemo/hedron-decoration.lisp diff -u cell-cultures/cellodemo/hedron-decoration.lisp:1.4 cell-cultures/cellodemo/hedron-decoration.lisp:1.5 --- cell-cultures/cellodemo/hedron-decoration.lisp:1.4 Tue Oct 19 05:47:33 2004 +++ cell-cultures/cellodemo/hedron-decoration.lisp Thu Oct 28 02:09:03 2004 @@ -85,7 +85,7 @@ :kids (c? (the-kids (a-row () (hedron-shapes) - (test-image-group :shape-backer "Backdrops" "hedron-bkgs") + (test-image-group :shape-backer "window-bkgs" "hedron-bkgs") (test-image-group :shape-skin "Skin" "shapers" "cloudy")) (hedron-texxing))))) @@ -153,7 +153,7 @@ (defun hedron-backers () - (test-image-group :shape-backer "Backdrops" "hedron-bkgs")) + (test-image-group :shape-backer "window-bkgs" "hedron-bkgs")) (defun test-image-group (md-name label$ dir-name$ &optional start$) (let ((jpegs (mapcan (lambda (type) Index: cell-cultures/cellodemo/light-panel.lisp diff -u cell-cultures/cellodemo/light-panel.lisp:1.3 cell-cultures/cellodemo/light-panel.lisp:1.4 --- cell-cultures/cellodemo/light-panel.lisp:1.3 Fri Oct 15 05:37:30 2004 +++ cell-cultures/cellodemo/light-panel.lisp Thu Oct 28 02:09:03 2004 @@ -59,9 +59,11 @@ (^nurb) (ogl-dsp-list-prep (backdrop self))) -(defmethod not-to-be ((self hedron)) - (when (^nurb) - (glu-delete-nurbs-renderer (^nurb)))) +(defmethod not-to-be :after ((self hedron)) + (bwhen (q (^quadric)) + (glu-delete-quadric q)) + (bwhen (n (^nurb)) + (glu-delete-nurbs-renderer n))) (defmethod display-text$ ((self Hedron)) "quick dirty ugly hack to satisfy ix-styled ogl-disp-list-prep" From ktilton at common-lisp.net Thu Oct 28 00:09:13 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:09:13 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cells/cells-test/cells-test.asd cell-cultures/cells/cells-test/test.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cells/cells-test In directory common-lisp.net:/tmp/cvs-serv27567/cells/cells-test Modified Files: cells-test.asd test.lisp Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:09:11 2004 Author: ktilton Index: cell-cultures/cells/cells-test/cells-test.asd diff -u cell-cultures/cells/cells-test/cells-test.asd:1.3 cell-cultures/cells/cells-test/cells-test.asd:1.4 --- cell-cultures/cells/cells-test/cells-test.asd:1.3 Sun Jul 4 20:59:42 2004 +++ cell-cultures/cells/cells-test/cells-test.asd Thu Oct 28 02:09:10 2004 @@ -1,8 +1,5 @@ ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -(operate 'load-op :asdf-aclproj) -(use-package :asdf-aclproj) - #+(or allegro lispworks cmu mcl clisp cormanlispx sbcl scl) (asdf:defsystem :cells-test @@ -14,7 +11,19 @@ :description "Cells Regression Test/Documentation" :long-description "Informatively-commented regression tests for Cells" :serial t - :components ((lpr-project-file "cells-test"))) + :depends-on (:utils-kt :cells) + :components ((:file "test") + (:file "hello-world") + (:file "internal-combustion") + (:file "boiler-examples") + (:file "person") + (:file "df-interference") + (:file "test-family") + (:file "test-kid-slotting") + (:file "lazy-propagation") + (:file "output-setf") + (:file "test-lazy") + (:file "synapse-testing"))) (defmethod perform :after ((op load-op) (system (eql (find-system :cells-test)))) (cells::cv-test)) Index: cell-cultures/cells/cells-test/test.lisp diff -u cell-cultures/cells/cells-test/test.lisp:1.2 cell-cultures/cells/cells-test/test.lisp:1.3 --- cell-cultures/cells/cells-test/test.lisp:1.2 Thu Jul 1 05:48:54 2004 +++ cell-cultures/cells/cells-test/test.lisp Thu Oct 28 02:09:11 2004 @@ -95,7 +95,7 @@ (defun dft () (let ();(*c-debug* t)) (cell-reset) - (df-test t) + (df-test) )) (defun output-clear (slot-name) From ktilton at common-lisp.net Thu Oct 28 00:09:17 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:09:17 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cells/cells.asd cell-cultures/cells/cells.lisp cell-cultures/cells/defpackage.lisp cell-cultures/cells/fm-utilities.lisp cell-cultures/cells/link.lisp cell-cultures/cells/md-utilities.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cells In directory common-lisp.net:/tmp/cvs-serv27567/cells Modified Files: cells.asd cells.lisp defpackage.lisp fm-utilities.lisp link.lisp md-utilities.lisp Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:09:13 2004 Author: ktilton Index: cell-cultures/cells/cells.asd diff -u cell-cultures/cells/cells.asd:1.2 cell-cultures/cells/cells.asd:1.3 --- cell-cultures/cells/cells.asd:1.2 Tue Jun 29 10:58:49 2004 +++ cell-cultures/cells/cells.asd Thu Oct 28 02:09:13 2004 @@ -3,20 +3,39 @@ ;(declaim (optimize (debug 2) (speed 1) (safety 1) (compilation-speed 1))) (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(operate 'load-op :asdf-aclproj) -(use-package :asdf-aclproj) - #+(or allegro lispworks cmu mcl clisp cormanlisp sbcl scl) -(defsystem :cells - :name "cells" +(asdf:defsystem :cells + :name "cells" :author "Kenny Tilton " - :version "05-Nov-2003" + :version "18-Oct-2004" :maintainer "Kenny Tilton " :licence "MIT Style" :description "Cells" :long-description "The Cells dataflow extension to CLOS." - :components ((lpr-project-file "cells"))) + :depends-on (:utils-kt) + :components (;;(lpr-project-file "cells") + (:file "defpackage") + (:file "cells" :depends-on ("defpackage")) + (:file "cell-types" :depends-on ("defpackage")) + (:file "integrity" :depends-on ("defpackage")) + (:file "constructors" :depends-on ("integrity" "cells")) + (:file "initialize" :depends-on ("cells")) + (:file "md-slot-value" :depends-on ("integrity" "cell-types")) + (:file "slot-utilities" :depends-on ("cells")) + (:file "optimization" :depends-on ("cells")) + (:file "link" :depends-on ("cells")) + (:file "propagate" :depends-on ("cells" "integrity")) + (:file "synapse" :depends-on ("cells")) + (:file "synapse-types" :depends-on ("cells")) + (:file "model-object" :depends-on ("defpackage")) + (:file "defmodel" :depends-on ("model-object" "propagate" "constructors")) + (:file "md-utilities" :depends-on ("cells")) + (:file "family" :depends-on ("defmodel")) + (:file "fm-utilities" :depends-on ("cells")) + (:file "family-values" :depends-on ("propagate" "defmodel" )) + (:file "test" :depends-on ("family")) + )) (defmethod perform ((o load-op) (c (eql (find-system :cells)))) ; (pushnew "CELLS" *modules* :test #'string=) Index: cell-cultures/cells/cells.lisp diff -u cell-cultures/cells/cells.lisp:1.4 cell-cultures/cells/cells.lisp:1.5 --- cell-cultures/cells/cells.lisp:1.4 Wed Jul 7 03:25:40 2004 +++ cell-cultures/cells/cells.lisp Thu Oct 28 02:09:13 2004 @@ -148,24 +148,6 @@ (format stream "~& >: often you mis-edit (c? (c? ...)) nesting is error")))) -;----------------------------- link debugging ----------------------- - - -(defun dump-users (c &optional (depth 0)) - (format t "~&~v,4t~s" depth c) - (dolist (user (c-users c)) - (dump-users user (+ 1 depth)))) - -(defun dump-useds (c &optional (depth 0)) - ;(c.trc "dump-useds> entry " c (+ 1 depth)) - (when (zerop depth) - (format t "x~&")) - (format t "~&|usd> ~v,8t~s" depth c) - (when (typep c 'c-ruled) - ;(c.trc "its ruled" c) - (dolist (used (cd-useds c)) - (dump-useds used (+ 1 depth))))) - (defun c-break (&rest args) (unless *stop* (c-stop args) Index: cell-cultures/cells/defpackage.lisp diff -u cell-cultures/cells/defpackage.lisp:1.5 cell-cultures/cells/defpackage.lisp:1.6 --- cell-cultures/cells/defpackage.lisp:1.5 Wed Jul 21 13:49:37 2004 +++ cell-cultures/cells/defpackage.lisp Thu Oct 28 02:09:13 2004 @@ -58,3 +58,4 @@ ) #+allegro (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc) ) + Index: cell-cultures/cells/fm-utilities.lisp diff -u cell-cultures/cells/fm-utilities.lisp:1.2 cell-cultures/cells/fm-utilities.lisp:1.3 --- cell-cultures/cells/fm-utilities.lisp:1.2 Fri Oct 15 05:37:38 2004 +++ cell-cultures/cells/fm-utilities.lisp Thu Oct 28 02:09:13 2004 @@ -50,7 +50,6 @@ (defmethod container (self) (fm-parent self)) (defmethod container-typed ((self model-object) type) - (c-assert self) (let ((parent (container self))) ;; fm- or ps-parent (cond ((null parent) nil) Index: cell-cultures/cells/link.lisp diff -u cell-cultures/cells/link.lisp:1.1 cell-cultures/cells/link.lisp:1.2 --- cell-cultures/cells/link.lisp:1.1 Sat Jun 26 20:38:36 2004 +++ cell-cultures/cells/link.lisp Thu Oct 28 02:09:13 2004 @@ -133,3 +133,21 @@ (defun c-unlink-used (user used) (setf (cd-useds user) (delete used (cd-useds user)))) + +;----------------- link debugging --------------------- + +(defun dump-users (c &optional (depth 0)) + (format t "~&~v,4t~s" depth c) + (dolist (user (c-users c)) + (dump-users user (+ 1 depth)))) + +(defun dump-useds (c &optional (depth 0)) + ;(c.trc "dump-useds> entry " c (+ 1 depth)) + (when (zerop depth) + (format t "x~&")) + (format t "~&|usd> ~v,8t~s" depth c) + (when (typep c 'c-ruled) + ;(c.trc "its ruled" c) + (dolist (used (cd-useds c)) + (dump-useds used (+ 1 depth))))) + Index: cell-cultures/cells/md-utilities.lisp diff -u cell-cultures/cells/md-utilities.lisp:1.2 cell-cultures/cells/md-utilities.lisp:1.3 --- cell-cultures/cells/md-utilities.lisp:1.2 Wed Jul 7 03:25:40 2004 +++ cell-cultures/cells/md-utilities.lisp Thu Oct 28 02:09:13 2004 @@ -63,7 +63,7 @@ (trc nil "not-to-be cleared 2 fm-parent, eternal-rest" self)) (defmethod not-to-be ((self model-object)) - (trc self "not to be!!!" self) + (trc nil "not to be!!!" self) (if (md-untouchable self) (trc "not-to-be not quiescing untouchable" self) (md-quiesce self))) From ktilton at common-lisp.net Thu Oct 28 00:09:22 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:09:22 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cl-ftgl/cl-ftgl.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cl-ftgl In directory common-lisp.net:/tmp/cvs-serv27567/cl-ftgl Modified Files: cl-ftgl.lisp Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:09:20 2004 Author: ktilton Index: cell-cultures/cl-ftgl/cl-ftgl.lisp diff -u cell-cultures/cl-ftgl/cl-ftgl.lisp:1.4 cell-cultures/cl-ftgl/cl-ftgl.lisp:1.5 --- cell-cultures/cl-ftgl/cl-ftgl.lisp:1.4 Fri Oct 1 06:01:12 2004 +++ cell-cultures/cl-ftgl/cl-ftgl.lisp Thu Oct 28 02:09:16 2004 @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Header: /project/cells/cvsroot/cell-cultures/cl-ftgl/cl-ftgl.lisp,v 1.4 2004/10/01 04:01:12 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/cell-cultures/cl-ftgl/cl-ftgl.lisp,v 1.5 2004/10/28 00:09:16 ktilton Exp $ (defpackage #:cl-ftgl (:nicknames #:ftgl) @@ -41,6 +41,7 @@ #:xftgl #:ftgl-render #:ftgl-font-ensure + #:ftgl-ensure-ifont #:cl-ftgl-set-home-dir #:cl-ftgl-get-home-dir #:cl-ftgl-set-dll-filename @@ -62,8 +63,8 @@ (defparameter *gui-style-button-face* :unconfigured) (eval-when (compile load eval) - (load (merge-pathnames "cl-ftgl-config.lisp" - cl-user::*cello-config-directory*))) + (load (merge-pathnames "cl-ftgl-config" + cl-user::*cell-cultures-config*))) ;; ---------------------------------------------------------------------------- ;; EXTERNAL DEPENDENCIES @@ -427,36 +428,14 @@ (defun ftgl-get-ascender (font) (or (ftgl-ascender font) (setf (ftgl-ascender font) - (fgc-ascender (ftgl-get-metrics-font font))))) + (fgc-ascender (ftgl-ensure-ifont font))))) (defun ftgl-get-descender (font) (or (ftgl-descender font) (setf (ftgl-descender font) - (fgc-descender (ftgl-get-metrics-font font))))) + (fgc-descender (ftgl-ensure-ifont font))))) -(defun ftgl-get-display-font (font) - (let ((cf (ftgl-get-metrics-font font))) - (assert cf) - (ukt::trc nil "FTGL-GET-DISPLAY-FONT sees" (ftgl-disp-ready-p font)) - (unless (ftgl-disp-ready-p font) - (when *ogl-listing-p* - (cells::c-break "bad time #1 for sizing? ~a ~a" *ogl-listing-p* font)) - (setf (ftgl-disp-ready-p font) t) - (typecase font - (ftgl-extruded - #+nyet (let ((*ogl-listing-p* t)) - (ukt::trc nil "ftgl-get-display-font> building glyphs for" font) - - (fgc-build-glyphs cf) - (ukt::trc nil "ftgl-get-display-font> glyphs built OK for" font))) - (ftgl-texture - #+no (fgc-set-face-size cf (ftgl-size font) (ftgl-target-res font))) - (ftgl-pixmap - #+no (fgc-set-face-size cf (ftgl-size font) (ftgl-target-res font)))) - ) - cf)) - -(defun ftgl-get-metrics-font (font) +(defun ftgl-ensure-ifont (font) (or (ftgl-ifont font) (setf (ftgl-ifont font) (ftgl-font-make font)))) @@ -477,9 +456,8 @@ (error "Font not found: ~a" path)))) (defun ftgl-render (font s) - (let ((df (ftgl-get-display-font font))) - (uffi:with-cstring (cs s) - (fgc-render df cs)))) + (uffi:with-cstring (cs s) + (fgc-render (ftgl-ensure-ifont font) cs))) (defmethod fgc-font-make :before (font fpath) (declare (ignore font fpath)) @@ -506,11 +484,11 @@ (fgc-polygon-make fpath)) (defun ftgl-string-length (font cs) - (fgc-string-advance (ftgl-get-metrics-font font) cs)) + (fgc-string-advance (ftgl-ensure-ifont font) cs)) (defmethod font-bearing-x ((font ftgl) &optional (text "m")) (uffi:with-cstring (cs text) - (fgc-string-x (ftgl-get-metrics-font font) cs))) + (fgc-string-x (ftgl-ensure-ifont font) cs))) (defmethod font-bearing-x (font &optional text) (declare (ignorable font text)) From ktilton at common-lisp.net Thu Oct 28 00:09:25 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:09:25 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cl-magick/cl-magick.lisp cell-cultures/cl-magick/mgk-test.lisp cell-cultures/cl-magick/wand-pixels.lisp cell-cultures/cl-magick/wand-texture.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cl-magick In directory common-lisp.net:/tmp/cvs-serv27567/cl-magick Modified Files: cl-magick.lisp mgk-test.lisp wand-pixels.lisp wand-texture.lisp Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:09:22 2004 Author: ktilton Index: cell-cultures/cl-magick/cl-magick.lisp diff -u cell-cultures/cl-magick/cl-magick.lisp:1.2 cell-cultures/cl-magick/cl-magick.lisp:1.3 --- cell-cultures/cl-magick/cl-magick.lisp:1.2 Fri Oct 15 05:37:40 2004 +++ cell-cultures/cl-magick/cl-magick.lisp Thu Oct 28 02:09:21 2004 @@ -44,18 +44,18 @@ (in-package :cl-magick) (defparameter *magick-dynamic-lib* :unconfigured) -(defparameter *magick-wand-templates* :unconfigured) -(defparameter *cl-magick-source-directory* :unconfigured) (eval-when (:compile-toplevel :load-toplevel) - (load (merge-pathnames "cl-magick-config.lisp" - cl-user::*cello-config-directory*))) + (load (merge-pathnames "cl-magick-config" + cl-user::*cell-cultures-config*))) (defun magick-wand-template () (path-to-wand (merge-pathnames - (make-pathname :name "metal" :type "gif") - *magick-wand-templates*))) + (make-pathname + :directory '(:relative "templates") + :name "metal" :type "gif") + cl-user::*cell-cultures-graphics-directory*))) (defparameter *imagick-dll-loaded* nil) (defparameter *wands-loaded* nil) Index: cell-cultures/cl-magick/mgk-test.lisp diff -u cell-cultures/cl-magick/mgk-test.lisp:1.3 cell-cultures/cl-magick/mgk-test.lisp:1.4 --- cell-cultures/cl-magick/mgk-test.lisp:1.3 Fri Oct 15 05:37:40 2004 +++ cell-cultures/cl-magick/mgk-test.lisp Thu Oct 28 02:09:21 2004 @@ -23,18 +23,13 @@ (in-package :cl-magick) -;;;(defun test-images (images-subdir) -;;; (mapcan (lambda (ftype) -;;; (directory (merge-pathnames (make-pathname :type ftype) -;;; images-subdir (string ftype)))) -;;; '(jpg bmp gif tif png))) - #+cello (defun mgk-wand-dump (w &rest info) - (clo::trc "mgk-wand-dump" w info) - (clo::trc "> width" (magick-get-image-width w)) - (clo::trc "> height" (magick-get-image-height w)) - (clo::trc "> description" (magick-describe-image w))) + (ukt::trc "mgk-wand-dump" w info) + ;; (ukt::trc "> width" (magick-get-image-width w)) + ;; (ukt::trc "> height" (magick-get-image-height w)) + ;; (ukt::trc "> description" (magick-describe-image w)) + ) (defconstant wcx 640) ;; Window Width (defconstant wcy 480) ;; Window Height @@ -268,11 +263,10 @@ (defun test-image (filename filetype) (merge-pathnames (make-pathname - :directory '(:relative "test") + :directory '(:relative "shapers") :name (string filename) :type (string filetype)) - *cl-magick-source-directory*)) - + cl-user::*cell-cultures-graphics-directory*)) (defun r6init() (gl-enable gl_texture_2d) @@ -283,9 +277,9 @@ (gl-depth-func gl_lequal) (gl-hint gl_perspective_correction_hint gl_nicest) (setf *skin6* (mgk:wand-ensure-typed 'wand-texture - (clo::demo-image-file 'shapers "jmcbw512.jpg"))) + (test-image "jmcbw512" "jpg"))) (setf *grace* (mgk:wand-ensure-typed 'wand-pixels - (clo::demo-image-file 'shapers "grace.jpg")))) + (test-image "grace" "jpg")))) #+test Index: cell-cultures/cl-magick/wand-pixels.lisp diff -u cell-cultures/cl-magick/wand-pixels.lisp:1.2 cell-cultures/cl-magick/wand-pixels.lisp:1.3 --- cell-cultures/cl-magick/wand-pixels.lisp:1.2 Fri Oct 1 06:01:19 2004 +++ cell-cultures/cl-magick/wand-pixels.lisp Thu Oct 28 02:09:21 2004 @@ -44,7 +44,7 @@ :image-sz sz) (let ((y-move (downs (+ 0 (abs (- top bottom)))))) (with-bitmap-shifted (0 y-move) - (clo::trc nil "wand-render pixels move" 0 y-move :top top :bottom bottom) + ;;(ukt::trc nil "wand-render pixels move" 0 y-move :top top :bottom bottom) #+hush (if (ogl-get-boolean gl_current_raster_position_valid) (progn Index: cell-cultures/cl-magick/wand-texture.lisp diff -u cell-cultures/cl-magick/wand-texture.lisp:1.4 cell-cultures/cl-magick/wand-texture.lisp:1.5 --- cell-cultures/cl-magick/wand-texture.lisp:1.4 Fri Oct 15 05:37:40 2004 +++ cell-cultures/cl-magick/wand-texture.lisp Thu Oct 28 02:09:21 2004 @@ -26,7 +26,7 @@ (progn (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)))) From ktilton at common-lisp.net Thu Oct 28 00:09:33 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:09:33 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cl-openal/altypes.lisp cell-cultures/cl-openal/cl-openal.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cl-openal In directory common-lisp.net:/tmp/cvs-serv27567/cl-openal Modified Files: altypes.lisp cl-openal.lisp Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:09:31 2004 Author: ktilton Index: cell-cultures/cl-openal/altypes.lisp diff -u cell-cultures/cl-openal/altypes.lisp:1.1 cell-cultures/cl-openal/altypes.lisp:1.2 --- cell-cultures/cl-openal/altypes.lisp:1.1 Sat Jun 26 20:38:40 2004 +++ cell-cultures/cl-openal/altypes.lisp Thu Oct 28 02:09:25 2004 @@ -24,7 +24,6 @@ (dft al-bitfield #-allegro-v5.0.1 :unsigned-int #+allegro-v5.0.1 :int integer) (dft al-int :int integer) -(dft al-sizei :int integer) (dft al-uint #-allegro-v5.0.1 :unsigned-int #+allegro-v5.0.1 :int integer) (dft al-ushort #-allegro-v5.0.1 :unsigned-int #+allegro-v5.0.1 :int integer) Index: cell-cultures/cl-openal/cl-openal.lisp diff -u cell-cultures/cl-openal/cl-openal.lisp:1.1 cell-cultures/cl-openal/cl-openal.lisp:1.2 --- cell-cultures/cl-openal/cl-openal.lisp:1.1 Sat Jun 26 20:38:40 2004 +++ cell-cultures/cl-openal/cl-openal.lisp Thu Oct 28 02:09:25 2004 @@ -46,8 +46,8 @@ (defparameter *audio-files* :unconfigured) (eval-when (compile load) - (load (merge-pathnames "cl-openal-config.lisp" - cl-user::*cello-config-directory*))) + (load (merge-pathnames "cl-openal-config" + cl-user::*cell-cultures-config*))) #+doit (xoa) From ktilton at common-lisp.net Thu Oct 28 00:09:40 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:09:40 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cl-opengl/cl-opengl.asd cell-cultures/cl-opengl/cl-opengl.lisp cell-cultures/cl-opengl/gl-functions.lisp cell-cultures/cl-opengl/ogl-utils.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cl-opengl In directory common-lisp.net:/tmp/cvs-serv27567/cl-opengl Modified Files: cl-opengl.asd cl-opengl.lisp gl-functions.lisp ogl-utils.lisp Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:09:33 2004 Author: ktilton Index: cell-cultures/cl-opengl/cl-opengl.asd diff -u cell-cultures/cl-opengl/cl-opengl.asd:1.1 cell-cultures/cl-opengl/cl-opengl.asd:1.2 --- cell-cultures/cl-opengl/cl-opengl.asd:1.1 Sat Jun 26 20:38:40 2004 +++ cell-cultures/cl-opengl/cl-opengl.asd Thu Oct 28 02:09:33 2004 @@ -15,17 +15,20 @@ :maintainer "Kenny Tilton " :licence "MIT" :description "Partial OpenGL Bindings" - :long-description "Poorly implemented bindings to half of OpenGL" + :long-description "Bindings to most of OpenGL, more on demand" :perform (load-op :after (op cl-opengl) (pushnew :cl-opengl cl:*features*)) + :depends-on (:utils-kt :ffi-extender) + :serial t :components ((:file "cl-opengl") (:file "gl-def" :depends-on ("cl-opengl")) (:file "gl-constants" :depends-on ("gl-def")) - (:file "gl-functions" :depends-on ("gl-constants")) - (:file "glu-functions" :depends-on ("gl-functions")) - (:file "glut-functions" :depends-on ("glu-functions")) - (:file "glut-def" :depends-on ("glut-functions")) - (:file "glut-extras" :depends-on ("glut-def")) - (:file "ogl-macros" :depends-on ("glut-extras")) - (:file "ogl-utils" :depends-on ("ogl-macros")) - (:file "nehe-14" :depends-on ("ogl-utils")))) + (:file "gl-functions" :depends-on ("gl-def")) + (:file "glu-functions" :depends-on ("gl-def")) + (:file "glut-functions" :depends-on ("gl-def")) + (:file "glut-def" :depends-on ("gl-def")) + (:file "glut-extras" :depends-on ("gl-def")) + (:file "ogl-macros" :depends-on ("gl-def")) + (:file "ogl-utils" :depends-on ("gl-def")) + (:file "nehe-14" :depends-on ("gl-def")) + )) Index: cell-cultures/cl-opengl/cl-opengl.lisp diff -u cell-cultures/cl-opengl/cl-opengl.lisp:1.3 cell-cultures/cl-opengl/cl-opengl.lisp:1.4 --- cell-cultures/cl-opengl/cl-opengl.lisp:1.3 Fri Oct 1 06:01:29 2004 +++ cell-cultures/cl-opengl/cl-opengl.lisp Thu Oct 28 02:09:33 2004 @@ -59,7 +59,7 @@ #:ogl-texture-delete #:ogl-texture-gen #:ogl-tex-gen-setup #:ogl-bounds #:ogl-scissor-box #:ogl-raster-pos-get #:ogl-pen-move #:with-bitmap-shifted - #:texture-name #:ogl-list-cache #:ogl-lists-delete + #:texture-name #:eltgli #:ogl-tex-activate #:gl-name)) (in-package :cl-opengl) @@ -69,8 +69,8 @@ (defparameter *glut-dynamic-lib* :unconfigured) (eval-when (compile load) - (load (merge-pathnames "cl-opengl-config.lisp" - cl-user::*cello-config-directory*))) + (load (merge-pathnames "cl-opengl-config" + cl-user::*cell-cultures-config*))) (defparameter *opengl-dll* nil) Index: cell-cultures/cl-opengl/gl-functions.lisp diff -u cell-cultures/cl-opengl/gl-functions.lisp:1.3 cell-cultures/cl-opengl/gl-functions.lisp:1.4 --- cell-cultures/cl-opengl/gl-functions.lisp:1.3 Fri Oct 1 06:01:29 2004 +++ cell-cultures/cl-opengl/gl-functions.lisp Thu Oct 28 02:09:33 2004 @@ -357,7 +357,8 @@ (glsizei width glsizei height glenum format glenum type glvoid *pixels)) (defun-ogl :void "open-gl" "glCopyPixels" ( glint x glint y glsizei width glsizei height glenum type )) -/* stenciling */ +#| stenciling |# + (defun-ogl :void "open-gl" "glStencilFunc" ( glenum func glint ref gluint mask )) (defun-ogl :void "open-gl" "glStencilMask" ( gluint mask )) (defun-ogl :void "open-gl" "glStencilOp" ( glenum fail glenum zfail glenum zpass )) Index: cell-cultures/cl-opengl/ogl-utils.lisp diff -u cell-cultures/cl-opengl/ogl-utils.lisp:1.4 cell-cultures/cl-opengl/ogl-utils.lisp:1.5 --- cell-cultures/cl-opengl/ogl-utils.lisp:1.4 Tue Oct 19 05:47:37 2004 +++ cell-cultures/cl-opengl/ogl-utils.lisp Thu Oct 28 02:09:33 2004 @@ -209,36 +209,6 @@ ((texture-name :accessor texture-name :initform nil) (texture-precedence :accessor texture-precedence :initform 0))) -(defparameter *ogl-display-lists* nil) - -(defmethod ogl-lists-delete (node) - (dsp-lists-delete (ogl-list-cache node))) - -(defmethod ogl-list-cache (other) - (declare (ignore other)) - *ogl-display-lists*) - -(defmethod (setf ogl-list-cache) (new-value other) - (declare (ignore other)) - (setf *ogl-display-lists* new-value)) - -(defun dsp-lists-delete (list-cache) - (dolist (k-dl list-cache) - (gl-delete-lists (cdr k-dl) 1))) - -(defun dsp-list-store (list node keys) - (push (cons keys list) (ogl-list-cache node))) - -(defun dsp-list-lookup (keys list) - (cdr (assoc keys list :test 'equal))) - -(defun dsp-list-dump (node) - (format t "display-lists for ~a" node) - (loop for (key . list) in (ogl-list-cache node) - do (format t "~d : ~a" list key))) - -(defparameter *new-listing* nil) - (defun flatten (&rest args) (mapcan (lambda (arg) (if (consp arg) From ktilton at common-lisp.net Thu Oct 28 00:09:42 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:09:42 +0200 Subject: [cells-cvs] CVS update: cell-cultures/config/cl-magick-config.lisp cell-cultures/config/cellodemo-config.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/config In directory common-lisp.net:/tmp/cvs-serv27567/config Modified Files: cl-magick-config.lisp Removed Files: cellodemo-config.lisp Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:09:40 2004 Author: ktilton Index: cell-cultures/config/cl-magick-config.lisp diff -u cell-cultures/config/cl-magick-config.lisp:1.2 cell-cultures/config/cl-magick-config.lisp:1.3 --- cell-cultures/config/cl-magick-config.lisp:1.2 Fri Oct 1 06:01:32 2004 +++ cell-cultures/config/cl-magick-config.lisp Thu Oct 28 02:09:40 2004 @@ -31,13 +31,3 @@ (merge-pathnames (make-pathname :name "CORE_RL_wand_" :type "dll") cl-user::*cello-dynlib-directory*)) - -(setq *cl-magick-source-directory* - (merge-pathnames - (make-pathname :directory '(:relative "cl-magick")) - cl-user::*devel-root*)) - -(setq *magick-wand-templates* - (merge-pathnames - (make-pathname :directory '(:relative "image")) - *cl-magick-source-directory*)) From ktilton at common-lisp.net Thu Oct 28 00:09:49 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:09:49 +0200 Subject: [cells-cvs] CVS update: cell-cultures/utils-kt/defpackage.lisp cell-cultures/utils-kt/detritus.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/utils-kt In directory common-lisp.net:/tmp/cvs-serv27567/utils-kt Modified Files: defpackage.lisp detritus.lisp Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:09:42 2004 Author: ktilton Index: cell-cultures/utils-kt/defpackage.lisp diff -u cell-cultures/utils-kt/defpackage.lisp:1.5 cell-cultures/utils-kt/defpackage.lisp:1.6 --- cell-cultures/utils-kt/defpackage.lisp:1.5 Wed Jul 7 03:25:41 2004 +++ cell-cultures/utils-kt/defpackage.lisp Thu Oct 28 02:09:42 2004 @@ -24,14 +24,16 @@ (defpackage :utils-kt (:nicknames #:ukt) - (:use #:common-lisp - #-(or cormanlisp cmu sbcl) #:clos - #+sbcl #:sb-mop - #+mcl #:ccl) + (:use #:common-lisp + #-(or cormanlisp cmu sbcl) #:clos + #+sbcl #:sb-mop + #+mcl #:ccl) (:export #:utils-kt-reset - #:eko #:count-it #:count-of #:trc #:trcp - #:wdbg #:maptimes #:bwhen #:bif #:xor - "WITH-DYNAMIC-FN" #:last1 #:packed-flat! #:with-metrics - "TRUE" "SHORTC" #:intern$ #:defconstant-once "*COUNT*" "*STOP*" - "*DBG*" "*TRCDEPTH*" - #:make-fifo-queue #:fifo-add #:fifo-empty #:fifo-pop #:mapfifo)) + #:eko #:count-it #:count-of #:trc #:trcp + #:wdbg #:maptimes #:bwhen #:bif #:xor + "WITH-DYNAMIC-FN" #:last1 #:packed-flat! #:with-metrics + #-(or lispworks mcl) "TRUE" "SHORTC" + #:intern$ + #:defconstant-once "*COUNT*" "*STOP*" + "*DBG*" "*TRCDEPTH*" + #:make-fifo-queue #:fifo-add #:fifo-empty #:fifo-pop #:mapfifo)) Index: cell-cultures/utils-kt/detritus.lisp diff -u cell-cultures/utils-kt/detritus.lisp:1.1 cell-cultures/utils-kt/detritus.lisp:1.2 --- cell-cultures/utils-kt/detritus.lisp:1.1 Sat Jun 26 20:38:43 2004 +++ cell-cultures/utils-kt/detritus.lisp Thu Oct 28 02:09:42 2004 @@ -42,7 +42,7 @@ (copy-list (class-instance-slots c)))) -#-lispworks +#-(or lispworks mcl) (defun true (it) (declare (ignore it)) t) (defun false (it) (declare (ignore it))) (defun xor (c1 c2) From ktilton at common-lisp.net Thu Oct 28 00:16:44 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:16:44 +0200 Subject: [cells-cvs] CVS update: Directory change: cell-cultures/cell-cultures-user Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user In directory common-lisp.net:/tmp/cvs-serv28655/cell-cultures-user Log Message: Directory /project/cells/cvsroot/cell-cultures/cell-cultures-user added to the repository Date: Thu Oct 28 02:16:44 2004 Author: ktilton New directory cell-cultures/cell-cultures-user added From ktilton at common-lisp.net Thu Oct 28 00:21:28 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:21:28 +0200 Subject: [cells-cvs] CVS update: Directory change: cell-cultures/cell-cultures-user/config Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user/config In directory common-lisp.net:/tmp/cvs-serv28743/config Log Message: Directory /project/cells/cvsroot/cell-cultures/cell-cultures-user/config added to the repository Date: Thu Oct 28 02:21:28 2004 Author: ktilton New directory cell-cultures/cell-cultures-user/config added From ktilton at common-lisp.net Thu Oct 28 00:21:29 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:21:29 +0200 Subject: [cells-cvs] CVS update: Directory change: cell-cultures/cell-cultures-user/dynlib Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user/dynlib In directory common-lisp.net:/tmp/cvs-serv28743/dynlib Log Message: Directory /project/cells/cvsroot/cell-cultures/cell-cultures-user/dynlib added to the repository Date: Thu Oct 28 02:21:28 2004 Author: ktilton New directory cell-cultures/cell-cultures-user/dynlib added From ktilton at common-lisp.net Thu Oct 28 00:21:30 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:21:30 +0200 Subject: [cells-cvs] CVS update: Directory change: cell-cultures/cell-cultures-user/graphics Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user/graphics In directory common-lisp.net:/tmp/cvs-serv28743/graphics Log Message: Directory /project/cells/cvsroot/cell-cultures/cell-cultures-user/graphics added to the repository Date: Thu Oct 28 02:21:29 2004 Author: ktilton New directory cell-cultures/cell-cultures-user/graphics added From ktilton at common-lisp.net Thu Oct 28 00:21:31 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:21:31 +0200 Subject: [cells-cvs] CVS update: Directory change: cell-cultures/cell-cultures-user/output Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user/output In directory common-lisp.net:/tmp/cvs-serv28743/output Log Message: Directory /project/cells/cvsroot/cell-cultures/cell-cultures-user/output added to the repository Date: Thu Oct 28 02:21:30 2004 Author: ktilton New directory cell-cultures/cell-cultures-user/output added From ktilton at common-lisp.net Thu Oct 28 00:21:32 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:21:32 +0200 Subject: [cells-cvs] CVS update: Directory change: cell-cultures/cell-cultures-user/sounds Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user/sounds In directory common-lisp.net:/tmp/cvs-serv28743/sounds Log Message: Directory /project/cells/cvsroot/cell-cultures/cell-cultures-user/sounds added to the repository Date: Thu Oct 28 02:21:31 2004 Author: ktilton New directory cell-cultures/cell-cultures-user/sounds added From ktilton at common-lisp.net Thu Oct 28 00:22:00 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:22:00 +0200 Subject: [cells-cvs] CVS update: Directory change: cell-cultures/cell-cultures-user/graphics/hedron-bkgs Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user/graphics/hedron-bkgs In directory common-lisp.net:/tmp/cvs-serv28818/hedron-bkgs Log Message: Directory /project/cells/cvsroot/cell-cultures/cell-cultures-user/graphics/hedron-bkgs added to the repository Date: Thu Oct 28 02:22:00 2004 Author: ktilton New directory cell-cultures/cell-cultures-user/graphics/hedron-bkgs added From ktilton at common-lisp.net Thu Oct 28 00:22:01 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:22:01 +0200 Subject: [cells-cvs] CVS update: Directory change: cell-cultures/cell-cultures-user/graphics/shapers Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user/graphics/shapers In directory common-lisp.net:/tmp/cvs-serv28818/shapers Log Message: Directory /project/cells/cvsroot/cell-cultures/cell-cultures-user/graphics/shapers added to the repository Date: Thu Oct 28 02:22:00 2004 Author: ktilton New directory cell-cultures/cell-cultures-user/graphics/shapers added From ktilton at common-lisp.net Thu Oct 28 00:22:04 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:22:04 +0200 Subject: [cells-cvs] CVS update: Directory change: cell-cultures/cell-cultures-user/graphics/templates Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user/graphics/templates In directory common-lisp.net:/tmp/cvs-serv28818/templates Log Message: Directory /project/cells/cvsroot/cell-cultures/cell-cultures-user/graphics/templates added to the repository Date: Thu Oct 28 02:22:03 2004 Author: ktilton New directory cell-cultures/cell-cultures-user/graphics/templates added From ktilton at common-lisp.net Thu Oct 28 00:22:05 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:22:05 +0200 Subject: [cells-cvs] CVS update: Directory change: cell-cultures/cell-cultures-user/graphics/window-bkgs Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user/graphics/window-bkgs In directory common-lisp.net:/tmp/cvs-serv28818/window-bkgs Log Message: Directory /project/cells/cvsroot/cell-cultures/cell-cultures-user/graphics/window-bkgs added to the repository Date: Thu Oct 28 02:22:04 2004 Author: ktilton New directory cell-cultures/cell-cultures-user/graphics/window-bkgs added From ktilton at common-lisp.net Thu Oct 28 00:23:54 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:23:54 +0200 Subject: [cells-cvs] CVS update: Directory change: cell-cultures/cell-cultures-user/graphics/shapers/legalcode_files Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user/graphics/shapers/legalcode_files In directory common-lisp.net:/tmp/cvs-serv28905/legalcode_files Log Message: Directory /project/cells/cvsroot/cell-cultures/cell-cultures-user/graphics/shapers/legalcode_files added to the repository Date: Thu Oct 28 02:23:53 2004 Author: ktilton New directory cell-cultures/cell-cultures-user/graphics/shapers/legalcode_files added From ktilton at common-lisp.net Thu Oct 28 00:26:03 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:26:03 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cell-cultures-user/config/cell-cultures-config.lisp cell-cultures/cell-cultures-user/config/cl-ftgl-config.lisp cell-cultures/cell-cultures-user/config/cl-magick-config.lisp cell-cultures/cell-cultures-user/config/cl-openal-config.lisp cell-cultures/cell-cultures-user/config/cl-opengl-config.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user/config In directory common-lisp.net:/tmp/cvs-serv28969/cell-cultures-user/config Added Files: cell-cultures-config.lisp cl-ftgl-config.lisp cl-magick-config.lisp cl-openal-config.lisp cl-opengl-config.lisp Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:26:00 2004 Author: ktilton From ktilton at common-lisp.net Thu Oct 28 00:26:05 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:26:05 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cell-cultures-user/graphics/brushdmtl.jpg Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user/graphics In directory common-lisp.net:/tmp/cvs-serv28969/cell-cultures-user/graphics Added Files: brushdmtl.jpg Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:26:04 2004 Author: ktilton From ktilton at common-lisp.net Thu Oct 28 00:26:08 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:26:08 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cell-cultures-user/graphics/hedron-bkgs/afire14.jpg cell-cultures/cell-cultures-user/graphics/hedron-bkgs/blksilk.jpg cell-cultures/cell-cultures-user/graphics/hedron-bkgs/ltblusatn.jpg cell-cultures/cell-cultures-user/graphics/hedron-bkgs/metal003.gif cell-cultures/cell-cultures-user/graphics/hedron-bkgs/moon.jpg Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user/graphics/hedron-bkgs In directory common-lisp.net:/tmp/cvs-serv28969/cell-cultures-user/graphics/hedron-bkgs Added Files: afire14.jpg blksilk.jpg ltblusatn.jpg metal003.gif moon.jpg Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:26:05 2004 Author: ktilton From ktilton at common-lisp.net Thu Oct 28 00:26:20 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:26:20 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cell-cultures-user/graphics/shapers/blksatin.jpg cell-cultures/cell-cultures-user/graphics/shapers/cloudy2.jpg cell-cultures/cell-cultures-user/graphics/shapers/creativecommons.html cell-cultures/cell-cultures-user/graphics/shapers/einstein.jpg cell-cultures/cell-cultures-user/graphics/shapers/grace.jpg cell-cultures/cell-cultures-user/graphics/shapers/jmcbw512.jpg cell-cultures/cell-cultures-user/graphics/shapers/ltblusatn.jpg cell-cultures/cell-cultures-user/graphics/shapers/mandelbrot3.gif cell-cultures/cell-cultures-user/graphics/shapers/mandelbrot3.txt cell-cultures/cell-cultures-user/graphics/shapers/metal003.gif cell-cultures/cell-cultures-user/graphics/shapers/skyscraper.jpg cell-cultures/cell-cultures-user/graphics/shapers/turing.gif Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user/graphics/shapers In directory common-lisp.net:/tmp/cvs-serv28969/cell-cultures-user/graphics/shapers Added Files: blksatin.jpg cloudy2.jpg creativecommons.html einstein.jpg grace.jpg jmcbw512.jpg ltblusatn.jpg mandelbrot3.gif mandelbrot3.txt metal003.gif skyscraper.jpg turing.gif Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:26:08 2004 Author: ktilton From ktilton at common-lisp.net Thu Oct 28 00:26:26 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:26:26 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cell-cultures-user/graphics/shapers/legalcode_files/deeds.css cell-cultures/cell-cultures-user/graphics/shapers/legalcode_files/logo_code.gif Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user/graphics/shapers/legalcode_files In directory common-lisp.net:/tmp/cvs-serv28969/cell-cultures-user/graphics/shapers/legalcode_files Added Files: deeds.css logo_code.gif Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:26:23 2004 Author: ktilton From ktilton at common-lisp.net Thu Oct 28 00:26:27 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:26:27 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cell-cultures-user/graphics/templates/metal.gif Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user/graphics/templates In directory common-lisp.net:/tmp/cvs-serv28969/cell-cultures-user/graphics/templates Added Files: metal.gif Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:26:26 2004 Author: ktilton From ktilton at common-lisp.net Thu Oct 28 00:26:36 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:26:36 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cell-cultures-user/graphics/window-bkgs/NeHe.bmp cell-cultures/cell-cultures-user/graphics/window-bkgs/cello.jpg cell-cultures/cell-cultures-user/graphics/window-bkgs/cloudy2.jpg cell-cultures/cell-cultures-user/graphics/window-bkgs/concrete.jpg Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user/graphics/window-bkgs In directory common-lisp.net:/tmp/cvs-serv28969/cell-cultures-user/graphics/window-bkgs Added Files: NeHe.bmp cello.jpg cloudy2.jpg concrete.jpg Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:26:27 2004 Author: ktilton From ktilton at common-lisp.net Thu Oct 28 00:26:49 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 28 Oct 2004 02:26:49 +0200 Subject: [cells-cvs] CVS update: cell-cultures/cell-cultures-user/sounds/backtrace.wav cell-cultures/cell-cultures-user/sounds/blurp_x.wav cell-cultures/cell-cultures-user/sounds/click.wav cell-cultures/cell-cultures-user/sounds/click2.wav cell-cultures/cell-cultures-user/sounds/close-window.wav cell-cultures/cell-cultures-user/sounds/jshootme.wav cell-cultures/cell-cultures-user/sounds/key-down.wav cell-cultures/cell-cultures-user/sounds/lasersound.wav cell-cultures/cell-cultures-user/sounds/ok-button.wav cell-cultures/cell-cultures-user/sounds/open-window.wav cell-cultures/cell-cultures-user/sounds/spin-off.wav Message-ID: Update of /project/cells/cvsroot/cell-cultures/cell-cultures-user/sounds In directory common-lisp.net:/tmp/cvs-serv28969/cell-cultures-user/sounds Added Files: backtrace.wav blurp_x.wav click.wav click2.wav close-window.wav jshootme.wav key-down.wav lasersound.wav ok-button.wav open-window.wav spin-off.wav Log Message: Re-port to Lispworks/win32 Date: Thu Oct 28 02:26:37 2004 Author: ktilton