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 ,@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)