[cells-cvs] CVS cells-gtk3/cells-gtk/test-gtk
phildebrandt
phildebrandt at common-lisp.net
Mon Apr 14 16:43:55 UTC 2008
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)
More information about the Cells-cvs
mailing list