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