[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
Kenny Tilton
ktilton at common-lisp.net
Fri Oct 15 03:37:33 UTC 2004
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
More information about the Cells-cvs
mailing list