Larry Clapp | 1 Sep 17:58 2008

bug report w/patch for record-caller in link.lisp, in LWL 5.1

Bug report:

Running Stefano's Sudoku example from his cells-doc in Lispworks for
Linux 5.1, got an error in record-caller:

  Error: The subscript 16 exceeds the limit 15 for the first dimension 
  of the array #*1111111111111111.
    1 (abort) Return to level 0.
    2 Return to top loop level 0.

Lispworks said the offending code was at the indicated line:

  (handler-case
      (setf (sbit (cd-usage *depender*) used-pos) 1)  ; <== ### here ###
    (type-error (error)
      (declare (ignorable error))
      (setf (cd-usage *depender*)
        (adjust-array (cd-usage *depender*) (+ used-pos 16) :initial-element 0))
      (setf (sbit (cd-usage *depender*) used-pos) 1))))

Fix:

The condition reported was of type CONDITIONS:SUBSCRIPT-OUT-OF-BOUNDS.
I added that to the handler-case, and then it worked:

  (handler-case
      (setf (sbit (cd-usage *depender*) used-pos) 1)
    ((or type-error conditions:subscript-out-of-bounds) (error)
    ;^^^            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
      (declare (ignorable error))
(Continue reading)

Kenny Tilton | 1 Sep 18:23 2008
Picon

Re: bug report w/patch for record-caller in link.lisp, in LWL 5.1

Thanks, I'll put it in my working code base, but I have not committed to 
CVS in a while and not sure when I will again.

I have always hated that code. Not sure why I did not just use an 
integer and logical operations.

kt

Larry Clapp wrote:
> Bug report:
> 
> Running Stefano's Sudoku example from his cells-doc in Lispworks for
> Linux 5.1, got an error in record-caller:
> 
>   Error: The subscript 16 exceeds the limit 15 for the first dimension 
>   of the array #*1111111111111111.
>     1 (abort) Return to level 0.
>     2 Return to top loop level 0.
> 
> Lispworks said the offending code was at the indicated line:
> 
>   (handler-case
>       (setf (sbit (cd-usage *depender*) used-pos) 1)  ; <== ### here ###
>     (type-error (error)
>       (declare (ignorable error))
>       (setf (cd-usage *depender*)
>         (adjust-array (cd-usage *depender*) (+ used-pos 16) :initial-element 0))
>       (setf (sbit (cd-usage *depender*) used-pos) 1))))
> 
> Fix:
(Continue reading)

Stefano Dissegna | 4 Sep 14:09 2008
Picon

PLT-Scheme cells?

I didn't actually tried this, but it looks very similar to cells. What do you think?

http://docs.plt-scheme.org/frtime/index.html

<div><div dir="ltr">I didn't actually tried this, but it looks very similar to cells. What do you think?<br><br><a href="http://docs.plt-scheme.org/frtime/index.html">http://docs.plt-scheme.org/frtime/index.html</a><br><br>
</div></div>
Stefano Dissegna | 6 Sep 13:45 2008
Picon

Re: PLT-Scheme cells?



2008/9/4 Kenny Tilton <kennytilton <at> optonline.net>
Stefano Dissegna wrote:
I didn't actually tried this, but it looks very similar to cells. What do you think?

http://docs.plt-scheme.org/frtime/index.html

Yep, same idea. Looks like a pain, tho, all this business about "lifting".

kt


--
http://www.theoryyalgebra.com/

I've read more about FrTime, and the big difference with Cells is that in FrTime *every* value acts as an input cell and every expression is a formula, i.e. everything is built-in, because FrTime redefines all scheme's primitives (this seems quite too intrusive to me). To avoid performance issues, there is an optimizer that "unlifts" constant values and expressions. Another difference is that FrTime is not tied to an OO system.

<div><div dir="ltr">
<br><br><div class="gmail_quote">2008/9/4 Kenny Tilton <span dir="ltr">&lt;<a href="mailto:kennytilton <at> optonline.net">kennytilton <at> optonline.net</a>&gt;</span><br><blockquote class="gmail_quote">
<div class="Ih2E3d">Stefano Dissegna wrote:<br><blockquote class="gmail_quote">
I didn't actually tried this, but it looks very similar to cells. What do you think?<br><br><a href="http://docs.plt-scheme.org/frtime/index.html" target="_blank">http://docs.plt-scheme.org/frtime/index.html</a><br>
</blockquote>
<br>
</div>
Yep, same idea. Looks like a pain, tho, all this business about "lifting".<br><br>
kt<br>
<br><br>
-- <br><a href="http://www.theoryyalgebra.com/" target="_blank">http://www.theoryyalgebra.com/</a>
</blockquote>
<div>
<br>I've read more about FrTime, and the big difference with Cells is that in FrTime *every*  value acts as an input cell and every expression is a formula, i.e. everything is built-in, because FrTime redefines all scheme's primitives (this seems quite too intrusive to me). To avoid performance issues, there is an optimizer that "unlifts" constant values and expressions. Another difference is that FrTime is not tied to an OO system.<br>
</div>
</div>
<br>
</div></div>
Madhu | 27 Sep 10:21 2008
Picon

Celtk contrib: ttk::treeview


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))))
;;; ----------------------------------------------------------------------
;;;
;;; 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))))
Kenny Tilton | 27 Sep 15:56 2008
Picon

Re: Celtk contrib: ttk::treeview

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/
Kenny Tilton | 27 Sep 23:39 2008
Picon

Re: Celtk contrib: ttk::treeview

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/
Madhu | 28 Sep 02:43 2008
Picon

Re: Celtk contrib: ttk::treeview


* Kenny Tilton <48DEA802.1050303 <at> 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

Madhu | 28 Sep 17:06 2008
Picon

Re: Celtk contrib: ttk::treeview


* Kenny Tilton <48DEA802.1050303 <at> 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

Attachment (dirtree-test.lisp): text/x-emacs-lisp, 3302 bytes

* Kenny Tilton <48DEA802.1050303 <at> 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

Kenny Tilton | 28 Sep 17:18 2008
Picon

Re: Re: Celtk contrib: ttk::treeview

Madhu wrote:
> * Kenny Tilton <48DEA802.1050303 <at> 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

Gmane