[cells-devel] Celtk contrib: ttk::treeview
Kenny Tilton
kennytilton at optonline.net
Sat Sep 27 21:39:14 UTC 2008
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 at net.meer>
>> ;;; Bugs-To: enometh at 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 at common-lisp.net
>> http://common-lisp.net/mailman/listinfo/cells-devel
>
>
>
--
http://www.theoryyalgebra.com/
More information about the cells-devel
mailing list