Update of /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv13587/cells-gtk/test-gtk
Modified Files: test-buttons.lisp test-display.lisp test-drawing.lisp test-gtk.asd test-gtk.lisp test-tree-view.lisp Log Message: Added OpenGL drawing area
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-buttons.lisp 2008/04/13 10:59:20 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-buttons.lisp 2008/04/14 16:43:48 1.2 @@ -5,13 +5,13 @@ (:default-initargs :kids (c? (the-kids (mk-label :text (c? (format nil "Toggled button active = ~a" - (value (fm-other :toggled-button))))) + (widget-value :toggled-button)))) (mk-hseparator) (mk-label :text (c? (format nil "Check button checked = ~a" - (value (fm-other :check-button))))) + (widget-value :check-button)))) (mk-hseparator) (mk-label :text (c? (format nil "Radio button selected = ~a" - (value (fm-other :radio-group))))) + (widget-value :radio-group)))) (mk-hseparator) (mk-label :text (c? (format nil "Button clicked ~a times" (nclics (upper self test-buttons)))) @@ -39,10 +39,10 @@ "_Check Button"))))) (mk-hbox :md-name :radio-group - :kids (c? (the-kids - (mk-radio-button :md-name :radio-1 - :label "Radio 1") - (mk-radio-button :md-name :radio-2 - :label "Radio 2" :init t) - (mk-radio-button :md-name :radio-3 - :label "Radio 3")))))))) + :kids (kids-list? + (mk-radio-button :md-name :radio-1 + :label "Radio 1") + (mk-radio-button :md-name :radio-2 + :label "Radio 2" :init t) + (mk-radio-button :md-name :radio-3 + :label "Radio 3"))))))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-display.lisp 2008/04/13 10:59:20 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-display.lisp 2008/04/14 16:43:48 1.2 @@ -4,11 +4,13 @@ (defmodel test-display (vbox) () (:default-initargs ;; g_timeout_add a function that will move the bar until the "Pulse" toggle is false. - :value (c? (when (value (fm-other :pulse)) - (timeout-add (value (fm-other :timeout)) - (lambda () - (pulse (fm-other :pbar2)) - (value (fm-other :pulse)))))) + :value (c? (with-widget-value (val :pulse) + (with-widget-value (timeout :timeout) + (timeout-add timeout + (lambda () + (with-widget (pbar :pbar2) + (pulse pbar)) + (widget-value :pulse)))))) :expand t :fill t :kids (kids-list? (mk-hbox @@ -25,7 +27,7 @@ (mk-hbox :kids (kids-list? (mk-progress-bar :md-name :pbar - :fraction (c? (value (fm^ :fraction-value)))) + :fraction (c? (widget-value :fraction-value 1))) (mk-hscale :md-name :fraction-value :value-type 'single-float :min 0 :max 1 @@ -34,17 +36,17 @@ (mk-button :label "Show in status bar" :on-clicked (callback (widget event data) - (push-message (fm-other :statusbar) - (format nil "~a" (fraction (fm-other :pbar)))))))) + (with-widget (w :statusbar) + (push-message w (format nil "~a" (fraction (fm-other :pbar))))))))) (mk-hbox :kids (kids-list? (mk-progress-bar :md-name :pbar2 - :pulse-step (c? (value (fm^ :step))) + :pulse-step (c? (widget-value :step .1)) :fraction (c-in .1)) (mk-toggle-button :md-name :pulse :label "Pulse") (mk-label :text "Interval") (mk-spin-button :md-name :timeout - :sensitive (c? (not (value (fm^ :pulse)))) + :sensitive (c? (not (widget-value :pulse))) :min 10 :max 1000 :init 100) (mk-label :text "Pulse step") @@ -53,7 +55,7 @@ :min 0.01 :max 1 :step 0.01 :init 0.1) (mk-image :md-name :pulse-image - :stock (c? (if (value (fm^ :pulse)) :yes :no))))) + :stock (c? (if (widget-value :pulse) :yes :no))))) (mk-alignment :expand t :fill t :xalign 0 :yalign 1 --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing.lisp 2008/04/13 10:59:20 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing.lisp 2008/04/14 16:43:48 1.2 @@ -164,7 +164,63 @@ :kids (kids-list? (make-instance 'test-cairo-drawing :fm-parent *parent*))))
+;;; +;;; GL drawing +;;; + (defparameter *da* nil)
+(defmodel teapot (gl-drawing-area) + () + (:default-initargs + :width (c-in 200) :height (c-in 200) :expand t :fill t + :init #'(lambda (self) + (declare (ignorable self)) + (gl:clear-color 0 0 0 0) + (gl:cull-face :back) + (gl:depth-func :less) + (gl:disable :dither) + (gl:shade-model :smooth) + (gl:light-model :light-model-local-viewer 1) + (gl:color-material :front :ambient-and-diffuse) + (gl:enable :light0 :lighting :cull-face :depth-test)) + :resize #'(lambda (self) + (with-matrix-mode (:projection) + (glu:perspective 50 (/ (allocated-width self) (allocated-height self)) 0.5 20))) + :draw #'(lambda (self) + (declare (ignore self)) + (gl:load-identity) + (gl:translate 0 0 -5) + (gl:rotate 30 1 1 0) + (gl:light :light0 :position '(0 1 1 0)) + (gl:light :light0 :diffuse '(0.2 0.4 0.6 0)) + (gl:clear :color-buffer-bit :depth-buffer-bit) + (gl:color 1 1 1) + (gl:front-face :cw) + (trc "drawing teapot with size" (/ (with-widget (w :teapot-size 130) + (trc "found widget teapot-size" w (value w)) + (value w)) 100)) + (glut:solid-teapot (/ (widget-value :teapot-size 130) 100)) + (gl:front-face :ccw) + (gl:flush)))) + +(defmodel test-gl-drawing (gtk-app) + () + (:default-initargs + :kids (kids-list? + (make-kid 'hbox + :kids (kids-list? + (make-kid 'vbox + :kids (kids-list? + (mk-spin-button :md-name :teapot-size + :min 1 :max 200 :step 1 :init 130 + :on-value-changed (callback (w e d) + (with-widget (teapot :teapot) + (trc "redrawing teapot") + (redraw teapot)))))) + (make-kid 'teapot :md-name :teapot)))))) + + (defun test-drawing () - (setf *da* (first (kids (first (kids (start-win 'test-cairo-drawing))))))) + ; (setf *da* (first (kids (first (kids (start-app 'test-gl-drawing)))))) + (start-app 'test-gl-drawing)) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.asd 2008/04/13 10:59:20 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.asd 2008/04/14 16:43:48 1.2 @@ -1,6 +1,21 @@ + + +;;; run gtk in its own thread (requires bordeaux-threads) +(pushnew :cells-gtk-threads *features*) + +;;; drawing-area widget using cairo (requires cl-cairo2) +(pushnew :cells-gtk-cairo *features*) + +;;; drawing-area widget using OpenGL (requires libgtkglext1) +(pushnew :cells-gtk-opengl *features*) + + (asdf:defsystem :test-gtk :name "test-gtk" - :depends-on (:cells-gtk) + :depends-on (:cells-gtk + #+cells-gtk-opengl :cl-opengl + #+cells-gtk-opengl :cl-glu + #+cells-gtk-opengl :cl-glut) :serial t :components ((:file "test-gtk") @@ -12,6 +27,6 @@ (:file "test-menus") (:file "test-dialogs") (:file "test-textview") - (:file "test-drawing") + #+(or cells-gtk-opengl cells-gtk-cairo) (:file "test-drawing") (:file "test-addon") )) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.lisp 2008/04/13 10:59:21 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.lisp 2008/04/14 16:43:48 1.2 @@ -48,7 +48,7 @@ "Addon" "Entry" "Tree-view" - "Drawing"))) + #+(or cells-gtk-cairo cells-gtk-opengl) "Drawing"))) (list (mk-notebook :tab-labels tabs :kids (c? (the-kids --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-tree-view.lisp 2008/04/13 11:34:25 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-tree-view.lisp 2008/04/14 16:43:48 1.3 @@ -63,16 +63,16 @@ (defmodel test-tree-view (notebook) ((data :accessor data :initform (c-in (make-sample-tree "tree" 3))) (items :accessor items :initarg :items - :initform (c? (and (value (fm-other :hscale)) - (loop for i from 1 to (value (fm-other :hscale)) collect - (make-be 'listbox-test-item - :string (format nil "Item ~d" i) - :icon (nth (random 5) (list "home" "open" "save" "ok" "cancel")) - :int i - :float (coerce (* (+ i 1) (/ 1 (1+ (random 100)))) 'single-float) - :double (coerce (* (+ i 2) (/ 1 (1+ (random 1000)))) 'double-float) - :boolean (oddp i) - :date (- (get-universal-time) (random 10000000)))))))) + :initform (c? (with-widget-value (hscale :hscale) + (loop for i from 1 to hscale collect + (make-be 'listbox-test-item + :string (format nil "Item ~d" i) + :icon (nth (random 5) (list "home" "open" "save" "ok" "cancel")) + :int i + :float (coerce (* (+ i 1) (/ 1 (1+ (random 100)))) 'single-float) + :double (coerce (* (+ i 2) (/ 1 (1+ (random 1000)))) 'double-float) + :boolean (oddp i) + :date (- (get-universal-time) (random 10000000)))))))) (:default-initargs :tab-labels (list "Listbox" "Treebox" "Cells-Tree-View") :kids (kids-list? @@ -84,7 +84,7 @@ (mk-listbox :columns (def-columns (:string (:title "Selection"))) - :items (c? (let ((sel (value (fm-other :listbox)))) + :items (c? (with-widget-value (sel :listbox) (if (listp sel) sel (list sel)))) :print-fn (lambda (item) (list (format nil "~a" item)))))) @@ -142,7 +142,7 @@ :kids (kids-list? (mk-listbox :md-name :listbox - :selection-mode (c? (value (fm-other :selection-mode))) + :selection-mode (c? (widget-value :selection-mode)) :columns (def-columns (:string (:title "String") #'(lambda (val) @@ -160,7 +160,7 @@ '(:foreground "navy" :strikethrough t)))) (:boolean (:title "Boolean")) (:date (:title "Date"))) - :select-if (c? (value (fm^ :selection-predicate))) + :select-if (c? (widget-value :selection-predicate)) :items (c? (items (upper self test-tree-view))) :print-fn (lambda (item) (list (string$ item) (icon$ item) (int$ item) (float$ item) @@ -172,7 +172,7 @@ :kids (kids-list? (mk-listbox :columns (def-columns (:string (:title "Selection"))) - :items (c? (let ((sel (value (fm-other :treebox)))) + :items (c? (with-widget-value (sel :treebox) (mapcar #'(lambda (item) (list (format nil "~a" (class-name (class-of item))))) (if (listp sel) sel (list sel)))))))) @@ -209,8 +209,8 @@ :kids (kids-list? (mk-treebox :md-name :treebox - :selection-mode (c? (value (fm^ :tree-selection-mode))) - :select-if (c? (value (fm^ :tree-selection-predicate))) + :selection-mode (c? (widget-value :tree-selection-mode)) + :select-if (c? (widget-value :tree-selection-predicate)) :columns (def-columns (:string (:title "Widget class") #'(lambda (val)