Attached is a small hack for using ttk::treeview - the hierarchical multicolumn data display widget, within CTK. See man ttk_treeview(n).
There is a small example at the bottom of the file. I'm attaching a second file which tests the widget on the filesystem directory structure (ala the tree.tcl which is bundled with the tk 8.5 demos). This uses `portable' cl pathname functions, so it may be rough depending on your lisp implementation.
I'm hoping to get feedback, especially from Kenny, on the correct or incorrect use of cells here. I'm using the cells family model to structure the tree hierarchy.
scrollbars are not done in this version. I expect there will be changes to Celtk scrollers so it won't be necessary to handle those here.
-- Madhu
[1] In particular I have a question inside dirtree example. The directories displayed have to be opened by double clicking the listed items -- There is no "openable" icon next to them. Now If I could create a dummy kid Tk will display the entry as openable. Cells did not let me create an initial dummy kids list (search for "HOWTO" in dirtree-test.lisp), that I could later swap out with an expanded list inside the on-open callback. [This, even when I wrap calls to with-integrity.]
;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*- ;;; ;;; Time-stamp: <2008-09-27 13:43:34 madhu> ;;; Touched: Wed Sep 24 11:12:58 2008 +0530 enometh@net.meer ;;; Bugs-To: enometh@net.meer ;;; Status: Experimental. Do not redistribute ;;; Copyright (C) 2008 Madhu. All Rights Reserved. ;;; ;;; Celtk support for the ttk::treeview Hierarchical multicolumn data display ;;; widget. See man ttk_treeview(n). This implementation was based on Tk 8.5.2 ;;; on linux. ;;; (in-package "CTK")
;;; ---------------------------------------------------------------------- ;;; ;;; TREEVIEW-ITEM: Interface to the ttk::treeview widget `item' command. This ;;; object is in Celtk only, not present in Tk. Each object represents a ;;; hierarchical item contained in treeview. The Cells family model is used to ;;; specify the hierarchy. The root of the tree is a treeview object. See ;;; TREEVIEW.
(deftk treeview-item (tk-object family) ((idx :cell nil :initarg :idx :accessor idx :initform nil) (on-select :initarg :on-select :initform nil :accessor on-select) (on-close :initarg :on-close :initform nil :accessor on-close) (on-open :initarg :on-open :initform nil :accessor on-open)) (:tk-spec treeview-item -text -image (values-lst -values) (openp -open) -tags) (:default-initargs :id (gentemp "TVI")))
(defmethod tk-configure ((self treeview-item) option value) (assert (idx self) () "cannot configure ~a ~a until instantiated with id." (tk-class self) self) (tk-format `(:configure ,self ,option) "~a item ~a ~a ~a" (path .parent) (idx self) (down$ option) (tk-send-value value)))
(defmethod make-tk-instance :around ((self treeview-item)) (when (upper self treeview) (call-next-method)))
(defmethod make-tk-instance ((self treeview-item)) (with-integrity (:client `(:make-tk ,self)) (setf (idx self) (tk-eval "~a insert ~a end ~{~(~a~) ~a~^ ~}" (path (upper self treeview)) (let ((parent (fm-parent self))) (etypecase parent (treeview-item (idx parent)) (treeview "{}"))) (tk-configurations self)))))
(defmethod not-to-be :after ((self treeview-item)) (unless (find .tkw *windows-destroyed*) (tk-format `(:delete ,self) "~a delete ~a" (path (upper self treeview)) (idx self))))
(defun rearrange-treeview-items (self oldkids newkids) (declare (type (or treeview-item treeview ) self)) (bwhen (root (upper self treeview)) (loop for k in oldkids do (tk-format `(:post-make-tk ,self) "~a detach ~a" (path root) (idx k))) (loop for k in newkids for i from 0 do (tk-format `(:post-make-tk ,self) "~a move ~a ~a ~d" (path root) (idx k) (idx self) i))))
(defobserver .kids ((self treeview-item)) (rearrange-treeview-items self old-value new-value))
(defun find-treeview-item (family idx) (loop for k in (kids family) when (etypecase k (treeview-item (if (string= idx (idx k)) k (find-treeview-item k idx)))) return it))
;;; ---------------------------------------------------------------------- ;;; ;;; TREEVIEW-HEADING: Interface to the ttk::treeview widget `heading' command ;;; for configuring titles of the multicolumn treeview widget. Each object ;;; represents a heading. This object is in CTK only, not in Tk. This is not ;;; a family model but we fake a fm-parent slot to store the parent treeview. ;;;
(defmodel treeview-colspec-mixin () ((treeview :initform nil :initarg :fm-parent :accessor fm-parent) ;evil (column :initform nil :initarg :treeview-column-id :accessor treeview-column-id)))
(deftk treeview-heading (tk-object treeview-colspec-mixin) () (:tk-spec treeview-heading -text -image -anchor -command) (:default-initargs :id (gentemp "TVH")))
(defmethod make-tk-instance ((self treeview-heading)) (assert (^treeview-column-id) () "~a: currently cannot make ~a without specifying column id." (tk-class self) self) (tk-format `(:post-make-tk ,self) "~a heading ~a ~{~(~a~) ~a~^ ~}" (path .parent) (^treeview-column-id) (tk-configurations self)))
(defmethod tk-configure ((self treeview-heading) option value) (assert (path .parent) () "~a: cannot configure heading ~a without parent." self) (assert (^treeview-column-id)) (assert (find (^treeview-column-id) (column-ids .parent) :test #'equal)) (tk-format `(:configure ,self ,option) "~a heading ~a ~a ~a " (path .parent) ;; (^treeview-column-id) (down$ option) (tk-send-value value)))
;;; ---------------------------------------------------------------------- ;;; ;;; TREEVIEW-COLUMN. Interface to the ttk::treeview widget `column' command ;;; for configuring columns of the multicolumn treeview widget. Each object ;;; represnts a column. This object is in CTK only, not in Tk. This is not a ;;; family model but we fake a fm-parent slot to store the treeview. -id is a ;;; readonly option of the command, so we do not specify it in tk-spec. ;;;
(deftk treeview-column (tk-object treeview-colspec-mixin) () (:tk-spec treeview-column -anchor -minwidth -stretch -width) (:default-initargs :id (gentemp "TVC")))
(defmethod make-tk-instance ((self treeview-column)) (assert (^treeview-column-id) () "~a: currently cannot make ~a without specifying column id." (tk-class self) self) (tk-format `(:post-make-tk ,self) "~a column ~a ~{~(~a~) ~a~^ ~}" (path .parent) (^treeview-column-id) (tk-configurations self)))
(defmethod tk-configure ((self treeview-column) option value) (assert (path .parent) () "cannot configure heading ~a without parent." self) (assert (^treeview-column-id)) (assert (find (^treeview-column-id) (column-ids .parent) :test #'equal)) (tk-format `(:configure ,self ,option) "~a heading ~a ~a ~a " (path .parent) (^treeview-column-id) (down$ option) (tk-send-value value)))
;;; ---------------------------------------------------------------------- ;;; ;;; TREEVIEW: ttk::treeview - Hierarchical multicolumn data display widget. ;;; Kids of a treeview object are treeview-item objects. Use column-ids to ;;; specify column identifiers. The values-lst of a treeview-item object is a ;;; list of data values, each in a one to one correspondance with column ;;; identifiers in column-ids. The on-XXX commands of treeview-item are ;;; invoked in response to treeview virtual events. Each on-XXX command is ;;; either nil or a function which takes a single argument, a treeview-item ;;; object. ;;;
(deftk treeview (widget) ((treeview-headings :initform nil :accessor treeview-headings :initarg :treeview-headings) (treeview-columns :initform nil :accessor treeview-columns :initarg :treeview-columns)) (:tk-spec treeview (ttk-class -class) -cursor -takefocus -style -xscrollcommand -yscrollcommand ; TODO (column-ids -columns) -displaycolumns -height -width -padding -selectmode -show) (:default-initargs :id (gentemp "TVIEW") :on-command #'treeview-on-command))
(defmethod make-tk-instance ((self treeview)) (setf (gethash (^path) (dictionary .tkw)) self) (tk-format `(:make-tk ,self) "ttk::treeview ~a ~{~(~a~) ~a~^ ~}" (^path) (tk-configurations self)) (tk-format `(:pack ,self) "pack ~a -expand yes -fill both" (^path)) (tk-format `(:bind ,self) "bind ~a <<TreeviewOpen>> {do-on-command %W OPEN [%W focus]}" (^path)) (tk-format `(:bind ,self) "bind ~a <<TreeviewClose>> {do-on-command %W CLOSE [%W focus]}" (^path)) (tk-format `(:bind ,self) "bind ~a <<TreeviewSelect>> {do-on-command %W SELECT [%W selection]}" (^path)))
(defobserver .kids ((self treeview)) (rearrange-treeview-items self old-value new-value))
(defun treeview-on-command (self event target) (trc nil "treeview-on-command self event target" self event target) (cond ((string= event "OPEN") (bwhen (target-item (find-treeview-item self target)) (bwhen (cmd (on-open target-item)) (funcall cmd target-item)))) ((string= event "CLOSE") (bwhen (target-item (find-treeview-item self target)) (bwhen (cmd (on-close target-item)) (funcall cmd target-item)))) ((string= event "SELECT") (loop for target in (parse-tcl-list-result target) do (bwhen (target-item (find-treeview-item self target)) (bwhen (cmd (on-select target-item)) (funcall cmd target)))))))
#+nil (test-window 'window t :title$ "Test-tree-view" :height (c-in 200) :width (c-in 200) :kids (c? (the-kids (mk-treeview :displaycolumns "#all" :column-ids '("COL1XYZ" "COL2ABC" "COL3") :treeview-headings (c? (the-kids (mk-treeview-heading :treeview-column-id "#0" :text "Name") (mapcar (lambda (c) (unless (stringp c) (setq c (princ-to-string c))) (mk-treeview-heading :treeview-column-id c :text c)) (^column-ids)))) :treeview-columns (c? (the-kids (mk-treeview-column :treeview-column-id "#0" :stretch "0" :width 100) (mapcar (lambda (c) (mk-treeview-column :treeview-column-id c)) (^column-ids)))) :kids (c? (the-kids (mk-treeview-item :text "root1" :openp t :on-select (lambda (s) (warn "select ~S" s)) :values-lst '("foo1" "bar1" "car1") :kids (c? (the-kids (mk-treeview-item :text "level1 A" :values-lst '("foo2" "bar2" "car2") :kids (c? (the-kids (mk-treeview-item :text "level2" :values-lst '("foo3" "bar3" "car3"))))) (mk-treeview-item :text "level1 B" :values-lst '("foo4" "bar4" "car4"))))) (mk-treeview-item :text "root2" :values-lst '("foo5" "bar5" "car5"))))))))
;;; ---------------------------------------------------------------------- ;;; ;;; DIRTREE: TREEVIEW DEMO ;;; (in-package "CTK")
(defun dirtree-directory-p (p) "Return non-nil if directory." (and (not (stringp (pathname-name p))) (not (stringp (pathname-type p)))))
(defun dirtree-expand (p) "Return a list of enrtries in directory p." (when (dirtree-directory-p p) (directory (make-pathname :name :wild :version :wild :type :wild :defaults p))))
(defun dirtree-format-date (utime &optional tz) "Return a Human readable date string" (multiple-value-bind (second minute hour date month year day daylight-p zone) (if tz (decode-universal-time utime tz) (decode-universal-time utime)) (when daylight-p (decf zone)) (format nil "~a ~a ~2,' d ~2,'0d:~2,'0d:~2,'0d ~4d ~?" (ecase day (0 "Mon") (1 "Tue") (2 "Wed") (3 "Thu") (4 "Fri") (5 "Sat") (6 "Sun")) (ecase month (1 "Jan") (2 "Feb") (3 "Mar") (4 "Apr") (5 "May") (6 "Jun") (7 "Jul") (8 "Aug") (9 "Sep") (10 "Oct") (11 "Nov") (12 "Dec")) date hour minute second year "~:[+~;-~]~2,'0d~2,'0d" (multiple-value-bind (hour min) (truncate zone 1) (list (plusp zone) (abs hour) (* 60 (abs min)))))))
(defmd dirtree-node (treeview-item) (my-pathname nil) (expandedp (c-in nil)) (directoryp nil) :kids (c-in nil) :on-open (lambda (self) (warn "XXX open ~S" self) (unless (^expandedp) (warn "XXX populating ~S: ~S" self (^my-pathname)) (setf (kids self) (dirtree-make-kids self) (^expandedp) t))))
(defmd dirtree (treeview) :column-ids '("ABSOLUTE-PATHNAME" "SIZE" "DATE") :displaycolumns '("SIZE" "DATE") :treeview-headings (c? (the-kids (mk-treeview-heading :treeview-column-id "#0" :text "Directory Structure") (mk-treeview-heading :treeview-column-id "SIZE" :text "File Size") (mk-treeview-heading :treeview-column-id "DATE" :text "Write date (utime)"))) :kids (c? (the-kids (make-kid 'dirtree-node :text "/" :my-pathname #p"/" :openp t :kids (c? (the-kids (dirtree-make-kids self)))))))
(defun dirtree-values-lst (p) "Return a list of values to be displayed for entry p" (list p (ignore-errors (with-open-file (stream p) (file-length stream))) (bwhen (utime (file-write-date p)) (dirtree-format-date utime))))
(defun dirtree-make-kids (self) (let ((ret (loop for p in (dirtree-expand (etypecase self (dirtree-node (my-pathname self)) (dirtree #p"/"))) for directory-p = (dirtree-directory-p p) collect (make-instance 'dirtree-node :directoryp directory-p :fm-parent self :my-pathname p :text (if directory-p (concatenate 'string (car (last (cdr (pathname-directory p)))) "/") (file-namestring p)) :openp (c-in nil) :values-lst (dirtree-values-lst p))))) #+HOWTO ;; populate the directories show they show a dummy expansion (map nil (lambda (x) (when (directoryp x) (setf (kids x) (list (make-instance 'dirtree-node :fm-parent x :text "dummy"))))) ret) ret))
#+nil (test-window 'window t :title$ "DIRTREE: TREEVIEW TEST" :height (c-in 200) :width (c-in 200) :kids (c? (the-kids (make-kid 'dirtree))))