[cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-addon.lisp root/cells-gtk/test-gtk/test-buttons.lisp root/cells-gtk/test-gtk/test-display.lisp root/cells-gtk/test-gtk/test-entry.lisp root/cells-gtk/test-gtk/test-gtk.asd root/cells-gtk/test-gtk/test-gtk.lisp root/cells-gtk/test-gtk/test-tree-view.lisp
Kenny Tilton
ktilton at common-lisp.net
Sun Dec 5 06:33:38 UTC 2004
Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk
In directory common-lisp.net:/tmp/cvs-serv13216/cells-gtk/test-gtk
Modified Files:
test-addon.lisp test-buttons.lisp test-display.lisp
test-entry.lisp test-gtk.asd test-gtk.lisp test-tree-view.lisp
Log Message:
Port to AllegroCl and Lispworks on win32 using UFFI
Date: Sun Dec 5 07:33:34 2004
Author: ktilton
Index: root/cells-gtk/test-gtk/test-addon.lisp
diff -u root/cells-gtk/test-gtk/test-addon.lisp:1.1 root/cells-gtk/test-gtk/test-addon.lisp:1.2
--- root/cells-gtk/test-gtk/test-addon.lisp:1.1 Fri Nov 19 00:40:14 2004
+++ root/cells-gtk/test-gtk/test-addon.lisp Sun Dec 5 07:33:31 2004
@@ -3,28 +3,29 @@
(defmodel test-addon (notebook)
()
(:default-initargs
- :tab-labels (list "Calendar" "Arrows")
- :kids (list
- (mk-vbox
- :kids (list
- (mk-calendar :md-name :calendar
- :init (encode-universal-time 0 0 0 6 3 1971))
- (mk-label
- :text (c? (when (md-value (fm^ :calendar))
- (multiple-value-bind (sec min hour day month year)
- (decode-universal-time (md-value (fm^ :calendar)))
- (format nil "Day selected ~a/~a/~a" day month year)))))))
- (mk-vbox
- :kids (list
- (mk-arrow
- :type (c? (md-value (fm^ :type))))
- (mk-frame
- :label "Arrow type"
- :kids (list
- (mk-hbox
- :md-name :type
- :kids (list
- (mk-radio-button :md-name :up :label "Up")
- (mk-radio-button :md-name :down :label "Down")
- (mk-radio-button :md-name :left :label "Left")
- (mk-radio-button :md-name :right :label "Right" :init t))))))))))
\ No newline at end of file
+ :tab-labels (list "Calendar" "Arrows")
+ :kids (list
+ (mk-vbox
+ :kids (list
+ (mk-calendar :md-name :calendar
+ :init (encode-universal-time 0 0 0 6 3 1971))
+ (mk-label
+ :text (c? (when (md-value (fm^ :calendar))
+ (multiple-value-bind (sec min hour day month year)
+ (decode-universal-time (md-value (fm^ :calendar)))
+ (declare (ignorable sec min hour))
+ (format nil "Day selected ~a/~a/~a" day month year)))))))
+ (mk-vbox
+ :kids (list
+ (mk-arrow
+ :type (c? (md-value (fm^ :type))))
+ (mk-frame
+ :label "Arrow type"
+ :kids (list
+ (mk-hbox
+ :md-name :type
+ :kids (list
+ (mk-radio-button :md-name :up :label "Up")
+ (mk-radio-button :md-name :down :label "Down")
+ (mk-radio-button :md-name :left :label "Left")
+ (mk-radio-button :md-name :right :label "Right" :init t))))))))))
\ No newline at end of file
Index: root/cells-gtk/test-gtk/test-buttons.lisp
diff -u root/cells-gtk/test-gtk/test-buttons.lisp:1.1 root/cells-gtk/test-gtk/test-buttons.lisp:1.2
--- root/cells-gtk/test-gtk/test-buttons.lisp:1.1 Fri Nov 19 00:40:14 2004
+++ root/cells-gtk/test-gtk/test-buttons.lisp Sun Dec 5 07:33:31 2004
@@ -1,5 +1,10 @@
(in-package :test-gtk)
+;;;(ff-defun-callable :cdecl :void button-toggled-cb (self event data)
+;;; (declare (ignorable event data))
+;;; (let ((state (gtk-toggle-button-get-active self)))
+;;; (setf (md-value self) state)))
+
(defmodel test-buttons (vbox)
((nclics :accessor nclics :initform (c-in 0)))
(:default-initargs
Index: root/cells-gtk/test-gtk/test-display.lisp
diff -u root/cells-gtk/test-gtk/test-display.lisp:1.1 root/cells-gtk/test-gtk/test-display.lisp:1.2
--- root/cells-gtk/test-gtk/test-display.lisp:1.1 Fri Nov 19 00:40:14 2004
+++ root/cells-gtk/test-gtk/test-display.lisp Sun Dec 5 07:33:31 2004
@@ -4,57 +4,59 @@
()
(:default-initargs
:md-value (c? (when (md-value (fm-other :pulse))
- (timeout-add (md-value (fm-other :timeout))
- (lambda ()
- (pulse (fm-other :pbar2))
- (md-value (fm-other :pulse))))))
- :expand t :fill t
- :kids (list
- (mk-hbox
- :kids (loop for icon-size in '(:menu :small-toolbar :large-toolbar :button :dnd :dialog) collect
- (mk-image :stock :harddisk :icon-size icon-size)))
- (mk-hseparator)
- (mk-aspect-frame
- :ratio 1
- :kids (list
- (mk-image :width 200 :height 250 :filename "test-images/tst.gif")))
- (mk-hseparator)
- (mk-hbox
- :kids (list
- (mk-progress-bar :md-name :pbar
- :fraction (c? (md-value (fm^ :fraction-value))))
- (mk-hscale :md-name :fraction-value
- :value-type 'single-float
- :min 0 :max 1
- :step 0.01
- :init 0.5)
- (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))))))))
- (mk-hbox
- :kids (list
- (mk-progress-bar :md-name :pbar2
- :pulse-step (c? (md-value (fm^ :step)))
- :fraction (c-in 0))
- (mk-toggle-button :md-name :pulse
- :label "Pulse")
- (mk-label :text "Timeout")
- (mk-spin-button :md-name :timeout
- :sensitive (c? (not (md-value (fm^ :pulse))))
- :min 10 :max 1000
- :init 100)
- (mk-label :text "Pulse step")
- (mk-spin-button :md-name :step
- :value-type 'single-float
- :min 0.01 :max 1 :step 0.01
- :init 0.1)
- (mk-image :md-name :pulse-image
- :stock (c? (if (md-value (fm^ :pulse)) :yes :no)))))
- (mk-alignment
- :expand t :fill t
- :xalign 0 :yalign 1
- :xscale 1
- :kids (list
- (mk-statusbar :md-name :statusbar))))))
+ (timeout-add (md-value (fm-other :timeout))
+ (lambda ()
+ (pulse (fm-other :pbar2))
+ (md-value (fm-other :pulse))))))
+ :expand t :fill t
+ :kids (list
+ (mk-hbox
+ :kids (loop for icon-size in '(:menu :small-toolbar :large-toolbar :button :dnd :dialog) collect
+ (mk-image :stock :harddisk :icon-size icon-size)))
+ (mk-hseparator)
+ (mk-aspect-frame
+ :ratio 1
+ :kids (list
+ (mk-image :width 200 :height 250
+ :filename "/000000/root/test-images/tst.gif")))
+ (mk-hseparator)
+ (mk-hbox
+ :kids (list
+ (mk-progress-bar :md-name :pbar
+ :fraction (c? (md-value (fm^ :fraction-value))))
+ (mk-hscale :md-name :fraction-value
+ :value-type 'single-float
+ :min 0 :max 1
+ :step 0.01
+ :init 0.5)
+ (mk-button :label "Show in status bar"
+ :on-clicked
+ (callback (widget event data)
+ (format t "fraction is ~a" (fraction (fm-other :pbar)))
+ (push-message (fm-other :statusbar)
+ (format nil "~a" (fraction (fm-other :pbar))))))))
+ (mk-hbox
+ :kids (list
+ (mk-progress-bar :md-name :pbar2
+ :pulse-step (c? (md-value (fm^ :step)))
+ :fraction (c-in 0))
+ (mk-toggle-button :md-name :pulse
+ :label "Pulse")
+ (mk-label :text "Timeout")
+ (mk-spin-button :md-name :timeout
+ :sensitive (c? (not (md-value (fm^ :pulse))))
+ :min 10 :max 1000
+ :init 100)
+ (mk-label :text "Pulse step")
+ (mk-spin-button :md-name :step
+ :value-type 'single-float
+ :min 0.01 :max 1 :step 0.01
+ :init 0.1)
+ (mk-image :md-name :pulse-image
+ :stock (c? (if (md-value (fm^ :pulse)) :yes :no)))))
+ (mk-alignment
+ :expand t :fill t
+ :xalign 0 :yalign 1
+ :xscale 1
+ :kids (list
+ (mk-statusbar :md-name :statusbar))))))
Index: root/cells-gtk/test-gtk/test-entry.lisp
diff -u root/cells-gtk/test-gtk/test-entry.lisp:1.1 root/cells-gtk/test-gtk/test-entry.lisp:1.2
--- root/cells-gtk/test-gtk/test-entry.lisp:1.1 Fri Nov 19 00:40:14 2004
+++ root/cells-gtk/test-gtk/test-entry.lisp Sun Dec 5 07:33:31 2004
@@ -4,59 +4,65 @@
()
(:default-initargs
:kids (list
- (mk-vbox
- :kids (list
- (mk-label
- :expand t :fill t
- :markup (c? (with-markup (:font-desc "24")
- (with-markup (:foreground :blue
- :font-family "Arial"
- :font-desc (if (md-value (fm-other :spin))
- (truncate (md-value (fm-other :spin)))
- 10))
- (md-value (fm-other :entry)))
- (with-markup (:underline :double
- :weight :bold
- :foreground :red
- :font-desc (if (md-value (fm-other :hscale))
- (truncate (md-value (fm-other :hscale)))
- 10))
- "is")
- (with-markup (:strikethrough (md-value (fm^ :cool)))
- "boring")
- (with-markup (:strikethrough (not (md-value (fm^ :cool))))
- "cool!")))
- :selectable t)
- (mk-entry :md-name :entry :auto-aupdate t :init "Testing")))
+ (mk-vbox
+ :kids (test-entry-1))
+
+ (mk-check-button :md-name :cool
+ :init t
+ :label "Cool")
+ (mk-frame
+ :kids (test-entry-2))
+ (mk-hbox
+ :kids (list
+ (mk-spin-button :md-name :spin
+ :init 10)))
+ (mk-hbox
+ :kids (list
+ (mk-label :text "Entry completion test (press i)")
+ (mk-entry
+ :max-length 20
+ :completion (loop for i from 1 to 10 collect
+ (format nil "Item ~d" i))))))))
- (mk-check-button :md-name :cool
- :init t
- :label "Cool")
- (mk-frame
- :kids (list
- (mk-vbox
- :kids (list
- (mk-hbox
- :kids (list
- (mk-check-button :md-name :sensitive
- :label "Sensitive")
- (mk-check-button :md-name :visible
- :init t
- :label "Visible")))
- (mk-hscale :md-name :hscale
- :visible (c? (md-value (fm^ :visible)))
- :sensitive (c? (md-value (fm^ :sensitive)))
- :expand t :fill t
- :min 0 :max 100
- :init 10)))))
- (mk-hbox
- :kids (list
- (mk-spin-button :md-name :spin
- :init 10)))
- (mk-hbox
- :kids (list
- (mk-label :text "Entry completion test (press i)")
- (mk-entry
- :max-length 20
- :completion (loop for i from 1 to 10 collect
- (format nil "Item ~d" i))))))))
+(defun test-entry-1 ()
+ (c? (list
+ (mk-label
+ :expand t :fill t
+ :markup (c? (with-markup (:font-desc "24")
+ (with-markup (:foreground :blue
+ :font-family "Arial"
+ :font-desc (if (md-value (fm-other :spin))
+ (truncate (md-value (fm-other :spin)))
+ 10))
+ (md-value (fm-other :entry)))
+ (with-markup (:underline :double
+ :weight :bold
+ :foreground :red
+ :font-desc (if (md-value (fm-other :hscale))
+ (truncate (md-value (fm-other :hscale)))
+ 10))
+ "is")
+ (with-markup (:strikethrough (md-value (fm^ :cool)))
+ "boring")
+ (with-markup (:strikethrough (not (md-value (fm^ :cool))))
+ "cool!")))
+ :selectable t)
+ (mk-entry :md-name :entry :auto-aupdate t :init "Testing"))))
+
+(defun test-entry-2 ()
+ (c? (list
+ (mk-vbox
+ :kids (c? (list
+ (mk-hbox
+ :kids (list
+ (mk-check-button :md-name :sensitive
+ :label "Sensitive")
+ (mk-check-button :md-name :visible
+ :init t
+ :label "Visible")))
+ (mk-hscale :md-name :hscale
+ :visible (c? (md-value (fm^ :visible)))
+ :sensitive (c? (md-value (fm^ :sensitive)))
+ :expand t :fill t
+ :min 0 :max 100
+ :init 10)))))))
\ No newline at end of file
Index: root/cells-gtk/test-gtk/test-gtk.asd
diff -u root/cells-gtk/test-gtk/test-gtk.asd:1.1 root/cells-gtk/test-gtk/test-gtk.asd:1.2
--- root/cells-gtk/test-gtk/test-gtk.asd:1.1 Fri Nov 19 00:40:14 2004
+++ root/cells-gtk/test-gtk/test-gtk.asd Sun Dec 5 07:33:31 2004
@@ -1,6 +1,6 @@
(asdf:defsystem :test-gtk
:name "test-gtk"
- :depends-on (:cells :cells-gtk)
+ :depends-on (:cells-gtk)
:serial t
:components
((:file "test-gtk")
Index: root/cells-gtk/test-gtk/test-gtk.lisp
diff -u root/cells-gtk/test-gtk/test-gtk.lisp:1.1 root/cells-gtk/test-gtk/test-gtk.lisp:1.2
--- root/cells-gtk/test-gtk/test-gtk.lisp:1.1 Fri Nov 19 00:40:14 2004
+++ root/cells-gtk/test-gtk/test-gtk.lisp Sun Dec 5 07:33:31 2004
@@ -1,26 +1,38 @@
(defpackage :test-gtk
- (:use :common-lisp :utils-kt :cells :cells-gtk))
+ (:use :common-lisp :utils-kt :cells :gtk-ffi :cells-gtk #-clisp :ffx))
(in-package :test-gtk)
(defmodel test-gtk (gtk-app)
()
(:default-initargs
- :title "GTK Testing"
+ :title "GTK Testing"
+ ;;:tooltips nil ;;dkwt
+ ;;:tooltips-enable nil ;;dkwt
:icon "test-images/small.png"
:position :center
- :splash-screen-image "test-images/splash.png"
+ :splash-screen-image "/000000/root/test-images/splash.png"
:width 550 :height 550
- :kids (list
- (mk-notebook
- :tab-labels '("Buttons" "Entry" "Display" "Layout" "Menus"
- "Tree view" "Text view" "Dialogs" "Addons")
- :kids (loop for test-name in '(test-buttons test-entry test-display test-layout test-menus
- test-tree-view test-textview test-dialogs test-addon)
- collect (make-instance test-name))))))
+ :kids (let ((tabs '("Buttons" "Display" "Layout" "Menus"
+ "Entry"
+ "Textview" "Dialogs" "Addon"
+ "Tree-view"
+ )))
+ (list (mk-notebook
+ :tab-labels nil #+not '("Buttons")
+ :kids (loop for test-name in tabs
+ collect (make-instance
+ (intern (string-upcase
+ (format nil "test-~a" test-name))
+ :test-gtk))))))))
(defun test-gtk-app ()
(start-app 'test-gtk)
#+clisp (ext:exit))
+
+
+(defun gtk-demo ()
+ (cells-gtk-init)
+ (cells-gtk:start-app 'test-gtk::test-gtk :debug nil))
;(ext:saveinitmem "test-gtk.mem" :init-function 'test-gtk::test-gtk-app)
Index: root/cells-gtk/test-gtk/test-tree-view.lisp
diff -u root/cells-gtk/test-gtk/test-tree-view.lisp:1.1 root/cells-gtk/test-gtk/test-tree-view.lisp:1.2
--- root/cells-gtk/test-gtk/test-tree-view.lisp:1.1 Fri Nov 19 00:40:14 2004
+++ root/cells-gtk/test-gtk/test-tree-view.lisp Sun Dec 5 07:33:31 2004
@@ -15,165 +15,176 @@
(defmodel test-tree-view (notebook)
((items :accessor items :initarg :items
- :initform (c? (and (md-value (fm-other :hscale))
- (loop for i from 1 to (md-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? (and (md-value (fm-other :hscale))
+ (loop for i from 1 to (md-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))))))))
(:default-initargs
:tab-labels (list "Listbox" "Treebox")
- :kids (list
- (mk-vbox
- :homogeneous nil
- :kids (list
- (mk-scrolled-window
- :kids (list
- (mk-listbox
- :columns (def-columns
- (:string (:title "Selection")))
- :items (c? (let ((sel (md-value (fm-other :listbox))))
- (if (listp sel) sel (list sel))))
- :items-factory (lambda (item)
- (list (format nil "~a" item))))))
- (mk-frame
- :label "Selection mode"
- :kids (list
- (mk-hbox
- :md-name :selection-mode
- :kids (list
- (mk-radio-button :md-name :none :label "None"
- :md-value (c-in t))
- (mk-radio-button :md-name :single :label "Single")
- (mk-radio-button :md-name :browse :label "Browse")
- (mk-radio-button :md-name :multiple :label "Multiple")))))
-
- (mk-hbox
- :kids (list
- (mk-label :text "Select")
- (mk-combo-box
- :md-name :selection-predicate
- :init (c? (first (items self)))
- :items (list
- #'null
- #'(lambda (itm) t)
- #'(lambda (itm) (not (null (boolean$ itm))))
- #'(lambda (itm)
- (multiple-value-bind (sec min hour day month year)
- (decode-universal-time (get-universal-time))
- (multiple-value-bind (itm-sec itm-min itm-hour itm-day itm-month itm-year)
- (decode-universal-time (date$ itm))
- (= month itm-month))))
- #'(lambda (itm) (oddp (int$ itm)))
- #'(lambda (itm) (evenp (int$ itm))))
- :items-factory (c?
- #'(lambda (item)
- (case (position item (items self))
- (0 "None")
- (1 "All")
- (2 "True")
- (3 "This month")
- (4 "Odd")
- (5 "Even")))))
- (mk-label :text "Items in Listbox")
- (mk-hscale
- :md-name :hscale
- :expand t :fill t
- :min 0 :max 200
- :init 100)))
- (mk-scrolled-window
- :kids (list
- (mk-listbox
- :md-name :listbox
- :selection-mode (c? (md-value (fm-other :selection-mode)))
- :columns (def-columns
- (:string (:title "String") #'(lambda (val) '(:font "courier")))
- (:icon (:title "Icon"))
- (:int (:title "Int") #'(lambda (val)
- (if (oddp val)
- '(:foreground "red" :size 14)
- '(:foreground "blue" :size 6))))
- (:float (:title "Float" :expand nil))
- (:double (:title "Double") #'(lambda (val)
- (if (> val 0.5)
- '(:foreground "cyan" :strikethrough nil)
- '(:foreground "navy" :strikethrough t))))
- (:boolean (:title "Boolean"))
- (:date (:title "Date")))
- :select-if (c? (md-value (fm^ :selection-predicate)))
- :items (c? (items (upper self test-tree-view)))
- :items-factory (lambda (item)
- (list (string$ item) (icon$ item) (int$ item) (float$ item)
- (double$ item) (boolean$ item) (date$ item))))))))
- (mk-vbox
- :homogeneous nil
- :kids (list
- (mk-scrolled-window
- :kids (list
- (mk-listbox
- :columns (def-columns
- (:string (:title "Selection")))
- :items (c? (let ((sel (md-value (fm-other :treebox))))
- (mapcar #'(lambda (item)
- (list (format nil "~a" (class-name (class-of item)))))
- (if (listp sel) sel (list sel))))))))
- (mk-frame
- :label "Selection mode"
- :kids (list
- (mk-hbox
- :md-name :tree-selection-mode
- :kids (list
- (mk-radio-button :md-name :none :label "None"
- :md-value (c-in t))
- (mk-radio-button :md-name :single :label "Single")
- (mk-radio-button :md-name :browse :label "Browse")
- (mk-radio-button :md-name :multiple :label "Multiple")))))
- (mk-hbox
- :kids (list
- (mk-label :text "Select")
- (mk-combo-box
- :md-name :tree-selection-predicate
- :init (c? (first (items self)))
- :items (list
- #'null
- #'(lambda (itm) (subtypep (class-name (class-of itm)) 'vbox))
- #'(lambda (itm) (subtypep (class-name (class-of itm)) 'button))
- #'(lambda (itm) (subtypep (class-name (class-of itm)) 'notebook)))
- :items-factory (c?
- #'(lambda (item)
- (case (position item (items self))
- (0 "None")
- (1 "VBoxes")
- (2 "Buttons")
- (3 "Notebooks")))))))
- (mk-scrolled-window
- :kids (list
- (mk-treebox
- :md-name :treebox
- :selection-mode (c? (md-value (fm^ :tree-selection-mode)))
- :select-if (c? (md-value (fm^ :tree-selection-predicate)))
- :columns (def-columns
- (:string (:title "Widget class") #'(lambda (val) '(:font "courier")))
- (:icon (:title "Icon"))
- (:int (:title "Number of kids")
- #'(lambda (val)
- (list :foreground (if (> val 5) "red" "blue"))))
- (:string (:title "Gtk address")))
- :items (c? (list (upper self gtk-app)))
- :items-factory #'(lambda (item)
- (list
- (format nil "~a" (class-name (class-of item)))
- (case (class-name (class-of item))
- (gtk-app "home")
- (vbox "open")
- (hbox "open")
- (window "index")
- (t "jump-to"))
- (length (kids item))
- (format nil "~a"
- (when (subtypep (class-name (class-of item)) 'cells-gtk::gtk-object)
- (cells-gtk::id item)))))))))))))
\ No newline at end of file
+ :kids (list
+ (mk-vbox
+ :homogeneous nil
+ :kids (list
+ (mk-scrolled-window
+ :kids (list
+ (mk-listbox
+ :columns (def-columns
+ (:string (:title "Selection")))
+ :items (c? (let ((sel (md-value (fm-other :listbox))))
+ (if (listp sel) sel (list sel))))
+ :items-factory (lambda (item)
+ (list (format nil "~a" item))))))
+ (mk-frame
+ :label "Selection mode"
+ :kids (list
+ (mk-hbox
+ :md-name :selection-mode
+ :kids (list
+ (mk-radio-button :md-name :none :label "None"
+ :md-value (c-in t))
+ (mk-radio-button :md-name :single :label "Single")
+ (mk-radio-button :md-name :browse :label "Browse")
+ (mk-radio-button :md-name :multiple :label "Multiple")))))
+
+ (mk-hbox
+ :kids (list
+ (mk-label :text "Select")
+ (mk-combo-box
+ :md-name :selection-predicate
+ :init (c? (first (items self)))
+ :items (list
+ #'null
+ #'(lambda (itm)
+ (declare (ignore itm))
+ t)
+ #'(lambda (itm) (not (null (boolean$ itm))))
+ #'(lambda (itm)
+ (multiple-value-bind (sec min hour day month year)
+ (decode-universal-time (get-universal-time))
+ (declare (ignore sec min hour day year))
+
+ (multiple-value-bind (itm-sec itm-min itm-hour itm-day itm-month itm-year)
+ (decode-universal-time (date$ itm))
+ (declare (ignore itm-sec itm-min itm-hour itm-day itm-year))
+ (= month itm-month))))
+ #'(lambda (itm) (oddp (int$ itm)))
+ #'(lambda (itm) (evenp (int$ itm))))
+ :items-factory (c?
+ #'(lambda (item)
+ (case (position item (items self))
+ (0 "None")
+ (1 "All")
+ (2 "True")
+ (3 "This month")
+ (4 "Odd")
+ (5 "Even")))))
+ (mk-label :text "Items in Listbox")
+ (mk-hscale
+ :md-name :hscale
+ :expand t :fill t
+ :min 0 :max 200
+ :init 100)))
+ (mk-scrolled-window
+ :kids (list
+ (mk-listbox
+ :md-name :listbox
+ :selection-mode (c? (md-value (fm-other :selection-mode)))
+ :columns (def-columns
+ (:string (:title "String")
+ #'(lambda (val)
+ (declare (ignore val))
+ '(:font "courier")))
+ (:icon (:title "Icon"))
+ (:int (:title "Int") #'(lambda (val)
+ (if (oddp val)
+ '(:foreground "red" :size 14)
+ '(:foreground "blue" :size 6))))
+ (:float (:title "Float" :expand nil))
+ (:double (:title "Double") #'(lambda (val)
+ (if (> val 0.5)
+ '(:foreground "cyan" :strikethrough nil)
+ '(:foreground "navy" :strikethrough t))))
+ (:boolean (:title "Boolean"))
+ (:date (:title "Date")))
+ :select-if (c? (md-value (fm^ :selection-predicate)))
+ :items (c? (items (upper self test-tree-view)))
+ :items-factory (lambda (item)
+ (list (string$ item) (icon$ item) (int$ item) (float$ item)
+ (double$ item) (boolean$ item) (date$ item))))))))
+ (mk-vbox
+ :homogeneous nil
+ :kids (list
+ (mk-scrolled-window
+ :kids (list
+ (mk-listbox
+ :columns (def-columns
+ (:string (:title "Selection")))
+ :items (c? (let ((sel (md-value (fm-other :treebox))))
+ (mapcar #'(lambda (item)
+ (list (format nil "~a" (class-name (class-of item)))))
+ (if (listp sel) sel (list sel))))))))
+ (mk-frame
+ :label "Selection mode"
+ :kids (list
+ (mk-hbox
+ :md-name :tree-selection-mode
+ :kids (list
+ (mk-radio-button :md-name :none :label "None"
+ :md-value (c-in t))
+ (mk-radio-button :md-name :single :label "Single")
+ (mk-radio-button :md-name :browse :label "Browse")
+ (mk-radio-button :md-name :multiple :label "Multiple")))))
+ (mk-hbox
+ :kids (list
+ (mk-label :text "Select")
+ (mk-combo-box
+ :md-name :tree-selection-predicate
+ :init (c? (first (items self)))
+ :items (list
+ #'null
+ #'(lambda (itm) (subtypep (class-name (class-of itm)) 'vbox))
+ #'(lambda (itm) (subtypep (class-name (class-of itm)) 'button))
+ #'(lambda (itm) (subtypep (class-name (class-of itm)) 'notebook)))
+ :items-factory (c?
+ #'(lambda (item)
+ (case (position item (items self))
+ (0 "None")
+ (1 "VBoxes")
+ (2 "Buttons")
+ (3 "Notebooks")))))))
+ (mk-scrolled-window
+ :kids (list
+ (mk-treebox
+ :md-name :treebox
+ :selection-mode (c? (md-value (fm^ :tree-selection-mode)))
+ :select-if (c? (md-value (fm^ :tree-selection-predicate)))
+ :columns (def-columns
+ (:string (:title "Widget class")
+ #'(lambda (val)
+ (declare (ignore val))
+ '(:font "courier")))
+ (:icon (:title "Icon"))
+ (:int (:title "Number of kids")
+ #'(lambda (val)
+ (list :foreground (if (> val 5) "red" "blue"))))
+ (:string (:title "Gtk address")))
+ :items (c? (list (upper self gtk-app)))
+ :items-factory #'(lambda (item)
+ (list
+ (format nil "~a" (class-name (class-of item)))
+ (case (class-name (class-of item))
+ (gtk-app "home")
+ (vbox "open")
+ (hbox "open")
+ (window "index")
+ (t "jump-to"))
+ (length (kids item))
+ (format nil "~a"
+ (when (subtypep (class-name (class-of item)) 'cells-gtk::gtk-object)
+ (cells-gtk::id item)))))))))))))
\ No newline at end of file
More information about the Cells-gtk-cvs
mailing list