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))))
A contrib?! You are setting an ugly precedent! :)
Cool, I will check it out ASAP.
cheers, ken
Madhu wrote:
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))))
cells-devel site list cells-devel@common-lisp.net http://common-lisp.net/mailman/listinfo/cells-devel
I cannot get Tile to run, your code or my old Code.
What versions are you at on all the DLLs? And mebbe send me your Celtk tree, you might have fixed something and forgotten about it.
I had one question:
(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))))
Can't you just have:
:on-open (lambda (self) (setf (openp self) t))
And have a kids rule: (c? (when (^openp)...))
From the code it looks like you understand this. Maybe you ran into an issue?
All in all looks like a nice job.
thx, ken
Kenny Tilton wrote:
A contrib?! You are setting an ugly precedent! :)
Cool, I will check it out ASAP.
cheers, ken
Madhu wrote:
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))))
cells-devel site list cells-devel@common-lisp.net http://common-lisp.net/mailman/listinfo/cells-devel
* Kenny Tilton 48DEA802.1050303@optonline.net : Wrote on Sat, 27 Sep 2008 17:39:14 -0400:
| I cannot get Tile to run, your code or my old Code.
I did not do anything special for Tile, it just came with Tk[1]. I'm on linux, openSUSE_11.0 and I believe the tk-8.5.2-15 from the distribution bundles ttk along with tk.
| What versions are you at on all the DLLs? And mebbe send me your Celtk | tree, you might have fixed something and forgotten about it.
[I'll send you a link to a tarball in a day or two before I leaving on a long vacation]
| Can't you just have: | | :on-open (lambda (self) (setf (openp self) t)) | | And have a kids rule: | (c? (when (^openp)...)) | | From the code it looks like you understand this. Maybe you ran into an | issue?
[`openp' itself is tied to Tk -- I couldn't call the cell OPEN because CL had dibs, but I did try a variation. I'll try this again]
Thanks! -- Madhu
1. (ff:list-all-foreign-libraries) (#P"/usr/lib/python2.5/site-packages/OpenGL/Tk/linux2-tk8.5/Togl.so" #P"libtk8.5.so" #P"libtcl8.5.so")
2. With allegro around the dirtree code I'd suggest #+allegro(progn (excl:unadvise dirtree-expand) (excl:defadvice dirtree-expand :around (remove-if #'null (mapcar #'truename :do-it))))
3. I had intended to switch the file header to LLGPL but sent a different copy of the file by mistake
* Kenny Tilton 48DEA802.1050303@optonline.net : Wrote on Sat, 27 Sep 2008 17:39:14 -0400:
| Can't you just have: | | :on-open (lambda (self) (setf (openp self) t)) | | And have a kids rule: | (c? (when (^openp)...)) | | From the code it looks like you understand this. Maybe you ran into an | issue?
The issue was that I could not figure out how to limit expansions down the tree using a kids rule at make-instance time. The general idea was directories should be expanded only when needed. [Further I was using `expandedp' to ensure that directories got expanded only once, even if they were opened multiple times by on-open events]. I couldn't combine these requirements with the desired initial state.
Besides, this was supposed to demo the idea that the tree represented in the family's hierarchical model is directly displayed by the widget. So manipulating the model (adding kids, sorting the kids) should reflect in the displayed tree.
Anyway I figured out how to initalize kids the way I wanted: Don't do it in the defmodel form (you cant get hold of a parent object there), just do it in make-tk-instance. FWIW I'm attaching the current version. There may be an outstanding bug around openp.
BTW, there is a problem with tk-format: if youre passing strings with ~, FORMAT will barf on strange directives. Dirty workaround:
(defmethod tk-send-value :around ((s string)) (sanitize-string-for-format (call-next-method)))
(defun sanitize-string-for-format (string) (let ((n (count #~ string))) (if (zerop n) string (let ((ret (make-string (+ n (length string)) :element-type (type-of (char string 0)))) (i -1)) (loop for c across string do (setf (aref ret (incf i)) c) if (eql c #~) do (setf (aref ret (incf i)) c)) ret))))
-- Regards Madhu
Madhu wrote:
- Kenny Tilton 48DEA802.1050303@optonline.net :
Wrote on Sat, 27 Sep 2008 17:39:14 -0400:
| Can't you just have: | | :on-open (lambda (self) (setf (openp self) t)) | | And have a kids rule: | (c? (when (^openp)...)) | | From the code it looks like you understand this. Maybe you ran into an | issue?
The issue was that I could not figure out how to limit expansions down the tree using a kids rule at make-instance time.
That was what I was trying to suggest with the above excerpt, but I was too terse: just have the kids rule first check another cell, the openp slot. When that goes to t the kids will be generated, when it goes to nil they can go away. If you think you need to avoid recreating the clos instances you are probably wrong, but you can just make the container collapsed when not openp (and play any number of tricks to avoid the rule rerunning when openp goes to nil and tossing all the kids.
ie, This is a very common requirement solved without SETF. But I commend your creativity in finding a solution, and the extensive work you did wiring in treeview. You are a quick study!
The general idea was directories should be expanded only when needed. [Further I was using `expandedp' to ensure that directories got expanded only once, even if they were opened multiple times by on-open events]. I couldn't combine these requirements with the desired initial state.
No, you forgot to ask me how. But I understand, I usually charge ahead on my own too and Just Get It Working.
Besides, this was supposed to demo the idea that the tree represented in the family's hierarchical model is directly displayed by the widget. So manipulating the model (adding kids, sorting the kids) should reflect in the displayed tree.
? How does this mandate abandonment of the declarative paradigm?
Anyway I figured out how to initalize kids the way I wanted: Don't do it in the defmodel form (you cant get hold of a parent object there),
Yes you can, but only if you use rules for the kids slot. The trick is always to /grow/ a Family tree with rules on the kids slot.
just do it in make-tk-instance. FWIW I'm attaching the current version. There may be an outstanding bug around openp.
BTW, there is a problem with tk-format: if youre passing strings with ~, FORMAT will barf on strange directives. Dirty workaround:
(defmethod tk-send-value :around ((s string)) (sanitize-string-for-format (call-next-method)))
(defun sanitize-string-for-format (string) (let ((n (count #~ string))) (if (zerop n) string (let ((ret (make-string (+ n (length string)) :element-type (type-of (char string 0)))) (i -1)) (loop for c across string do (setf (aref ret (incf i)) c) if (eql c #~) do (setf (aref ret (incf i)) c)) ret))))
Thx!
kt
* Kenny Tilton 48DFA037.3030705@optonline.net : Wrote on Sun, 28 Sep 2008 11:18:15 -0400: |> The issue was that I could not figure out how to limit expansions down |> the tree using a kids rule at make-instance time. | | That was what I was trying to suggest with the above excerpt, but I | was too terse: just have the kids rule first check another cell, the | openp slot. When that goes to t the kids will be generated, when it | goes to nil they can go away. If you think you need to avoid | recreating the clos instances you are probably wrong, but you can just | make the container collapsed when not openp (and play any number of | tricks to avoid the rule rerunning when openp goes to nil and tossing | all the kids.
openp is a slot on treeview-item that controls the ".pathname item -open node" tcl command. I'm using `openedp' for a new variable.
| ie, This is a very common requirement solved without SETF. But I | commend your creativity in finding a solution, and the extensive work | you did wiring in treeview. You are a quick study! | | |> The general idea was |> directories should be expanded only when needed. [Further I was using |> `expandedp' to ensure that directories got expanded only once, even if |> they were opened multiple times by on-open events]. I couldn't combine |> these requirements with the desired initial state. | | No, you forgot to ask me how. But I understand, I usually charge ahead | on my own too and Just Get It Working.
You know what? Youre right. I'm appending the code to this message, it is a bit simpler without those :after methods on make-tk-instance.
There is still a question -- of triggering a (setf (^openp) t) in a dirtree-node kids rule.
|> Besides, this was supposed to demo the idea that the tree represented in |> the family's hierarchical model is directly displayed by the widget. So |> manipulating the model (adding kids, sorting the kids) should reflect in |> the displayed tree. | | ? How does this mandate abandonment of the declarative paradigm?
The declarative paradigm is already there, to be chosen and used. All that is being done is support is also added for a traditional container-contains hierarchy, so one can reach for it JUST IN CASE one needs it. -- Madhu
PS: Here is the code, in full declarative glory :)
(defun dirtree-make-kids (self) (loop for p in (dirtree-expand (etypecase self (dirtree-node (my-pathname self)) (dirtree #p"/"))) collect (make-kid 'dirtree-node :my-pathname p)))
(defmd dirtree-node (treeview-item) my-pathname (openp (c-in nil)) (openedp (c-in nil)) (directoryp (c? (bwhen (p (^my-pathname)) (dirtree-directory-p p)))) :text (c? (bwhen (p (^my-pathname)) (if (^directoryp) (concatenate 'string (car (last (cdr (pathname-directory p)))) "/") (file-namestring p)))) :values-lst (c? (bwhen (p (^my-pathname)) (list (namestring p) (or (ignore-errors (with-open-file (stream p) (file-length stream))) "") (or (bwhen (utime (file-write-date p)) (dirtree-format-date utime)) "")))) :on-open (lambda (self) (setf (^openedp) t)) :on-close (lambda (self) (setf (^openedp) nil)) :kids (c? (the-kids (if (^openedp) (dirtree-make-kids self) (when (^directoryp) (make-kid 'dirtree-node :text "dummy"))))))
(defmd dirtree (treeview) :column-ids '("ABSOLUTE-PATHNAME" "SIZE" "DATE") :displaycolumns '("SIZE" "DATE") :kids (c? (the-kids (make-kid 'dirtree-node :my-pathname #p"/" :text "/"))) :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)"))))
Madhu wrote:
- Kenny Tilton 48DFA037.3030705@optonline.net :
Wrote on Sun, 28 Sep 2008 11:18:15 -0400: |> The issue was that I could not figure out how to limit expansions down |> the tree using a kids rule at make-instance time. | | That was what I was trying to suggest with the above excerpt, but I | was too terse: just have the kids rule first check another cell, the | openp slot. When that goes to t the kids will be generated, when it | goes to nil they can go away. If you think you need to avoid | recreating the clos instances you are probably wrong, but you can just | make the container collapsed when not openp (and play any number of | tricks to avoid the rule rerunning when openp goes to nil and tossing | all the kids.
openp is a slot on treeview-item that controls the ".pathname item -open node" tcl command. I'm using `openedp' for a new variable.
| ie, This is a very common requirement solved without SETF. But I | commend your creativity in finding a solution, and the extensive work | you did wiring in treeview. You are a quick study! | | |> The general idea was |> directories should be expanded only when needed. [Further I was using |> `expandedp' to ensure that directories got expanded only once, even if |> they were opened multiple times by on-open events]. I couldn't combine |> these requirements with the desired initial state. | | No, you forgot to ask me how. But I understand, I usually charge ahead | on my own too and Just Get It Working.
You know what? Youre right. I'm appending the code to this message, it is a bit simpler without those :after methods on make-tk-instance.
There is still a question -- of triggering a (setf (^openp) t) in a dirtree-node kids rule.
|> Besides, this was supposed to demo the idea that the tree represented in |> the family's hierarchical model is directly displayed by the widget. So |> manipulating the model (adding kids, sorting the kids) should reflect in |> the displayed tree. | | ? How does this mandate abandonment of the declarative paradigm?
The declarative paradigm is already there, to be chosen and used. All that is being done is support is also added for a traditional container-contains hierarchy, so one can reach for it JUST IN CASE one needs it. -- Madhu
PS: Here is the code, in full declarative glory :)
<snip>
OK, /now/ you can go on your long vacation.
:)
kt
-
Kenny Tilton -
Madhu