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