[cells-devel] Celtk contrib: ttk::treeview
Kenny Tilton
kennytilton at optonline.net
Sat Sep 27 13:56:24 UTC 2008
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