gtk-demo: added demo-treeview-tree function

diff --git a/gtk/gtk.demo.lisp b/gtk/gtk.demo.lisp
index 5d142b9..435e97a 100644 (file)
--- a/gtk/gtk.demo.lisp
+++ b/gtk/gtk.demo.lisp
@@ -22,7 +22,8 @@
            #:test-box-child-property
            #:test-builder
            #:demo-text-editor
-           #:demo-class-browser))
+           #:demo-class-browser
+           #:demo-treeview-tree))
 
 (in-package :gtk-demo)
 
@@ -688,3 +689,62 @@
                            (display-class-slots class)))))
             (g-signal-connect search-button "clicked" #'on-search-clicked))
           (widget-show window)))))
+
+(defun make-tree-from-sexp (l)
+  (setf l (if (listp l) l (list l)))
+  (let ((node (make-tree-node :item (make-tvi :title (format nil "~S" (first l))
+                                              :value (format nil "~S" (class-of (first l)))))))
+    (iter (for child in (rest l))
+          (tree-node-insert-at node (make-tree-from-sexp child) (length (tree-node-children node))))
+    node))
+
+(defun demo-treeview-tree ()
+  (within-main-loop
+    (let* ((window (make-instance 'gtk-window :type :toplevel :title "Treeview (tree)"))
+           (model (make-instance 'tree-lisp-store))
+           (scroll (make-instance 'scrolled-window :hscrollbar-policy :automatic :vscrollbar-policy :automatic))
+           (tree-view (make-instance 'tree-view :headers-visible t :width-request 300 :height-request 400 :rules-hint t))
+           (h-box (make-instance 'h-box))
+           (v-box (make-instance 'v-box))
+           (entry (make-instance 'entry))
+           (button (make-instance 'button :label "Display")))
+      (tree-lisp-store-add-column model "gchararray" #'tvi-title)
+      (tree-lisp-store-add-column model "gchararray" #'tvi-value)
+      (tree-node-insert-at (tree-lisp-store-root model)
+                           (make-tree-from-sexp '(lambda (object &rest initargs &key &allow-other-keys)
+                                                  (* 1 2)
+                                                  (- 3 4)))
+                           0)
+      (setf (tree-view-model tree-view) model
+            (tree-view-tooltip-column tree-view) 0)
+      (connect-signal tree-view "row-activated" (lambda (tv path column)
+                                                  (release* tv path column)
+                                                  (format t "You clicked on row ~A~%" (tree-path-indices path))))
+      (connect-signal button "clicked" (lambda (b)
+                                         (declare (ignore b))
+                                         (let ((object (read-from-string (entry-text entry))))
+                                           (tree-node-remove-at (tree-lisp-store-root model) 0)
+                                           (tree-node-insert-at (tree-lisp-store-root model)
+                                                                (make-tree-from-sexp object)
+                                                                0))))
+      (container-add window v-box)
+      (box-pack-start v-box h-box :expand nil)
+      (box-pack-start h-box entry)
+      (box-pack-start h-box button :expand nil)
+      (box-pack-start v-box scroll)
+      (container-add scroll tree-view)
+      (let ((column (make-instance 'tree-view-column :title "Value" :sort-column-id 0))
+            (renderer (make-instance 'cell-renderer-text :text "A text")))
+        (tree-view-column-pack-start column renderer)
+        (tree-view-column-add-attribute column renderer "text" 0)
+        (tree-view-append-column tree-view column)
+        (print (tree-view-column-tree-view column))
+        (print (tree-view-column-cell-renderers column)))
+      (let ((column (make-instance 'tree-view-column :title "Type"))
+            (renderer (make-instance 'cell-renderer-text :text "A text")))
+        (tree-view-column-pack-start column renderer)
+        (tree-view-column-add-attribute column renderer "text" 1)
+        (tree-view-append-column tree-view column)
+        (print (tree-view-column-tree-view column))
+        (print (tree-view-column-cell-renderers column)))
+      (widget-show window))))