[cells-gtk-cvs] CVS update: root/cells-gtk/menus.lisp

[Peter Denno]

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory common-lisp.net:/tmp/cvs-serv8110/cells-gtk

Modified Files:
	menus.lisp 
Log Message:
New code for TreeModel ComboBoxes. Requires libcellsgtk.so
Date: Sun May 29 23:09:40 2005
Author: pdenno

Index: root/cells-gtk/menus.lisp
diff -u root/cells-gtk/menus.lisp:1.9 root/cells-gtk/menus.lisp:1.10
--- root/cells-gtk/menus.lisp:1.9	Sat Feb 26 23:28:08 2005
+++ root/cells-gtk/menus.lisp	Sun May 29 23:09:40 2005
@@ -18,20 +18,68 @@
 
 (in-package :cgtk)
 
+(defmacro with-tree-iters (vars &body body)
+  `(let (,@(loop for var in vars collect `(,var (gtk-adds-tree-iter-new))))
+     (unwind-protect 
+       (progn , at body)
+       ,@(loop for var in vars collect `(gtk-tree-iter-free ,var)))))
+
+;;; ============= Combo-box ============================
+;;; User should specify exactly one of :items or :roots 
+;;; If specify :roots, specify :children-fn too.
 (def-widget combo-box ()
   ((items :accessor items :initarg :items :initform nil)
    (print-fn :accessor print-fn :initarg :print-fn
-     :initform #'(lambda (item) (format nil "~a" item)))
-   (init :accessor init :initarg :init :initform nil))
+     :initform #'(lambda (item) (format nil "~a" item))) ; see below if :roots
+   (init :accessor init :initarg :init :initform nil)
+   (roots :accessor roots :initarg :roots :initform nil)
+   (children-fn :accessor children-fn :initarg :children-fn :initform #'(lambda (x) (declare (ignore x)) nil))
+   (tree-model :cell nil :accessor tree-model :initform nil))
   (active)
   (changed)
   :new-tail '-text
-  :on-changed (callback (widget event data)
-                (trc nil "combo-box onchanged cb" widget event data (id self))
-                (let ((pos (gtk-combo-box-get-active (id self))))
-                  (trc nil "combo-box pos" pos)
-                  (setf (md-value self) (and (not (= pos -1))
-                                          (nth pos (items self)))))))
+  :on-changed 
+  (callback (widget event data)
+    (trc nil "combo-box onchanged cb" widget event data (id self))
+    (if (items self) 
+	;; flat model (:items specified)
+	(let ((pos (gtk-combo-box-get-active (id self))))
+	  ;;(trc nil "combo-box pos" pos)
+	  (setf (md-value self) (and (not (= pos -1))
+				     (nth pos (items self)))))
+      ;; non-flat tree-model (:roots specified)
+      (with-tree-iters (iter)
+        (when (gtk-combo-box-get-active-iter (id self) iter)
+	  (setf (md-value self)
+		(item-from-path
+		 (children-fn self)
+		 (roots self)
+		 (read-from-string
+		  (gtk-tree-model-get-cell (id (tree-model self)) iter 1 :string)))))))))
+
+;;; When user specifies :roots, he is using a tree-model.
+;;; POD There is probably no reason he has to use :strings for the "columns"
+(def-c-output roots ((self combo-box))
+  (when old-value
+    (gtk-tree-store-clear (id (tree-model self))))
+  (when new-value
+    (unless (tree-model self)
+      (let ((model (mk-tree-store :item-types '(:string :string))))
+	(setf (tree-model self) model)
+	(setf (of-tree model) self)
+	(gtk-combo-box-set-model (id self) (id (to-be model)))))
+    (let* ((user-print-fn (print-fn self)) ; because he shouldn't need to know this detail.
+	   (pfunc #'(lambda (x) (list (funcall user-print-fn x)))))
+      (loop for root in new-value
+	    for index from 0 do
+	    (gtk-tree-store-set-kids (id (tree-model self)) root c-null index
+				     '(:string :string) pfunc (children-fn self)))
+      ;; Spec says iter must correspond to a path of depth one. Hence no point in set-active-iter.
+      ;; init should just be the index of the depth one item you want displayed.
+      (bwhen (item-index (init self))
+         (gtk-combo-box-set-active (id self) item-index)
+	 (let ((item (item-from-path (children-fn self) (roots self) (list item-index))))
+	   (setf (md-value self) item))))))
 
 (def-c-output items ((self combo-box))
   (when old-value
@@ -45,7 +93,8 @@
 	(when index
 	  (gtk-combo-box-set-active (id self) index)
 	  (setf (md-value self) (init self)))))))
-	
+
+;;; ============= Toolbar/Toolbutton ============================	
 (def-object tooltips ()
   () () ())
 
@@ -126,6 +175,7 @@
   (when new-value
     (setf (stock-id self) (string-downcase (format nil "gtk-~a" new-value)))))
 
+;;; ============= Menu ============================	
 (def-widget menu-shell ()
   () () ()
   :padding 0)