From larry at theclapp.org Mon Sep 1 15:58:20 2008 From: larry at theclapp.org (Larry Clapp) Date: Mon, 1 Sep 2008 11:58:20 -0400 Subject: [cells-devel] bug report w/patch for record-caller in link.lisp, in LWL 5.1 Message-ID: <20080901155820.GA9617@cupid.theclapp.org> 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)) (setf (cd-usage *depender*) (adjust-array (cd-usage *depender*) (+ used-pos 16) :initial-element 0)) (setf (sbit (cd-usage *depender*) used-pos) 1)))) However, this seems like a demonstrably error-prone way to handle this particular situation, so I got rid of the handler-case entirely and tried this: (let ((cd-usage (cd-usage *depender*))) (when (>= used-pos (array-dimension cd-usage 0)) (setf cd-usage (setf (cd-usage *depender*) (adjust-array (cd-usage *depender*) (+ used-pos 16) :initial-element 0)))) (setf (sbit cd-usage used-pos) 1)) It works, doesn't depend on implementation-specific conditions, and in my limited testing (I ran the sudoku solver three times using each version), seems at least as fast, if not a tiny bit faster. -- Larry From kennytilton at optonline.net Mon Sep 1 16:23:34 2008 From: kennytilton at optonline.net (Kenny Tilton) Date: Mon, 01 Sep 2008 12:23:34 -0400 Subject: [cells-devel] bug report w/patch for record-caller in link.lisp, in LWL 5.1 In-Reply-To: <20080901155820.GA9617@cupid.theclapp.org> References: <20080901155820.GA9617@cupid.theclapp.org> Message-ID: <48BC1706.4050505@optonline.net> 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: > > 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)) > (setf (cd-usage *depender*) > (adjust-array (cd-usage *depender*) (+ used-pos 16) :initial-element 0)) > (setf (sbit (cd-usage *depender*) used-pos) 1)))) > > However, this seems like a demonstrably error-prone way to handle this > particular situation, so I got rid of the handler-case entirely and > tried this: > > (let ((cd-usage (cd-usage *depender*))) > (when (>= used-pos (array-dimension cd-usage 0)) > (setf cd-usage > (setf (cd-usage *depender*) > (adjust-array (cd-usage *depender*) > (+ used-pos 16) > :initial-element 0)))) > (setf (sbit cd-usage used-pos) 1)) > > It works, doesn't depend on implementation-specific conditions, and in > my limited testing (I ran the sudoku solver three times using each > version), seems at least as fast, if not a tiny bit faster. > > -- Larry > > _______________________________________________ > cells-devel site list > cells-devel at common-lisp.net > http://common-lisp.net/mailman/listinfo/cells-devel > -- http://www.theoryyalgebra.com/ From stefano.dissegna at gmail.com Thu Sep 4 12:09:29 2008 From: stefano.dissegna at gmail.com (Stefano Dissegna) Date: Thu, 4 Sep 2008 14:09:29 +0200 Subject: [cells-devel] PLT-Scheme cells? Message-ID: <933dcb390809040509r58784ea6jbf6861d8c1cac97a@mail.gmail.com> 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 -------------- next part -------------- An HTML attachment was scrubbed... URL: From stefano.dissegna at gmail.com Sat Sep 6 11:45:36 2008 From: stefano.dissegna at gmail.com (Stefano Dissegna) Date: Sat, 6 Sep 2008 13:45:36 +0200 Subject: [cells-devel] PLT-Scheme cells? In-Reply-To: <48C00378.2060207@optonline.net> References: <933dcb390809040509r58784ea6jbf6861d8c1cac97a@mail.gmail.com> <48C00378.2060207@optonline.net> Message-ID: <933dcb390809060445r6c2e2896rafb5c178081ddb6@mail.gmail.com> 2008/9/4 Kenny Tilton > 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. -------------- next part -------------- An HTML attachment was scrubbed... URL: From enometh at meer.net Sat Sep 27 08:21:12 2008 From: enometh at meer.net (Madhu) Date: Sat, 27 Sep 2008 13:51:12 +0530 Subject: [cells-devel] Celtk contrib: ttk::treeview Message-ID: 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.] -------------- next part -------------- An embedded and charset-unspecified text was scrubbed... Name: ttk-treeview.lisp URL: -------------- next part -------------- An embedded and charset-unspecified text was scrubbed... Name: dirtree-test.lisp URL: From kennytilton at optonline.net Sat Sep 27 13:56:24 2008 From: kennytilton at optonline.net (Kenny Tilton) Date: Sat, 27 Sep 2008 09:56:24 -0400 Subject: [cells-devel] Celtk contrib: ttk::treeview In-Reply-To: References: Message-ID: <48DE3B88.8080906@optonline.net> 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 > ;;; 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 <> {do-on-command %W OPEN [%W focus]}" (^path)) > (tk-format `(:bind ,self) "bind ~a <> {do-on-command %W CLOSE [%W focus]}" (^path)) > (tk-format `(:bind ,self) "bind ~a <> {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/ From kennytilton at optonline.net Sat Sep 27 21:39:14 2008 From: kennytilton at optonline.net (Kenny Tilton) Date: Sat, 27 Sep 2008 17:39:14 -0400 Subject: [cells-devel] Celtk contrib: ttk::treeview In-Reply-To: <48DE3B88.8080906@optonline.net> References: <48DE3B88.8080906@optonline.net> Message-ID: <48DEA802.1050303@optonline.net> 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 >> ;;; 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 <> {do-on-command >> %W OPEN [%W focus]}" (^path)) >> (tk-format `(:bind ,self) "bind ~a <> {do-on-command >> %W CLOSE [%W focus]}" (^path)) >> (tk-format `(:bind ,self) "bind ~a <> {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/ From enometh at meer.net Sun Sep 28 00:43:56 2008 From: enometh at meer.net (Madhu) Date: Sun, 28 Sep 2008 06:13:56 +0530 Subject: [cells-devel] Re: Celtk contrib: ttk::treeview References: <48DE3B88.8080906@optonline.net> <48DEA802.1050303@optonline.net> Message-ID: * 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 From enometh at meer.net Sun Sep 28 15:06:02 2008 From: enometh at meer.net (Madhu) Date: Sun, 28 Sep 2008 20:36:02 +0530 Subject: [cells-devel] Re: Celtk contrib: ttk::treeview References: <48DE3B88.8080906@optonline.net> <48DEA802.1050303@optonline.net> Message-ID: * 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 -------------- next part -------------- A non-text attachment was scrubbed... Name: dirtree-test.lisp Type: text/x-emacs-lisp Size: 3302 bytes Desc: not available URL: From kennytilton at optonline.net Sun Sep 28 15:18:15 2008 From: kennytilton at optonline.net (Kenny Tilton) Date: Sun, 28 Sep 2008 11:18:15 -0400 Subject: [cells-devel] Re: Celtk contrib: ttk::treeview In-Reply-To: References: <48DE3B88.8080906@optonline.net> <48DEA802.1050303@optonline.net> Message-ID: <48DFA037.3030705@optonline.net> 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 From enometh at meer.net Sun Sep 28 16:17:47 2008 From: enometh at meer.net (Madhu) Date: Sun, 28 Sep 2008 21:47:47 +0530 Subject: [cells-devel] Re: Celtk contrib: ttk::treeview References: <48DE3B88.8080906@optonline.net> <48DEA802.1050303@optonline.net> <48DFA037.3030705@optonline.net> Message-ID: * Kenny Tilton <48DFA037.3030705 at optonline.net> : Wrote on Sun, 28 Sep 2008 11:18:15 -0400: |> The issue was that I could not figure out how to limit expansions down |> the tree using a kids rule at make-instance time. | | That was what I was trying to suggest with the above excerpt, but I | was too terse: just have the kids rule first check another cell, the | openp slot. When that goes to t the kids will be generated, when it | goes to nil they can go away. If you think you need to avoid | recreating the clos instances you are probably wrong, but you can just | make the container collapsed when not openp (and play any number of | tricks to avoid the rule rerunning when openp goes to nil and tossing | all the kids. openp is a slot on treeview-item that controls the ".pathname item -open node" tcl command. I'm using `openedp' for a new variable. | ie, This is a very common requirement solved without SETF. But I | commend your creativity in finding a solution, and the extensive work | you did wiring in treeview. You are a quick study! | | |> The general idea was |> directories should be expanded only when needed. [Further I was using |> `expandedp' to ensure that directories got expanded only once, even if |> they were opened multiple times by on-open events]. I couldn't combine |> these requirements with the desired initial state. | | No, you forgot to ask me how. But I understand, I usually charge ahead | on my own too and Just Get It Working. You know what? Youre right. I'm appending the code to this message, it is a bit simpler without those :after methods on make-tk-instance. There is still a question -- of triggering a (setf (^openp) t) in a dirtree-node kids rule. |> Besides, this was supposed to demo the idea that the tree represented in |> the family's hierarchical model is directly displayed by the widget. So |> manipulating the model (adding kids, sorting the kids) should reflect in |> the displayed tree. | | ? How does this mandate abandonment of the declarative paradigm? The declarative paradigm is already there, to be chosen and used. All that is being done is support is also added for a traditional container-contains hierarchy, so one can reach for it JUST IN CASE one needs it. -- Madhu PS: Here is the code, in full declarative glory :) (defun dirtree-make-kids (self) (loop for p in (dirtree-expand (etypecase self (dirtree-node (my-pathname self)) (dirtree #p"/"))) collect (make-kid 'dirtree-node :my-pathname p))) (defmd dirtree-node (treeview-item) my-pathname (openp (c-in nil)) (openedp (c-in nil)) (directoryp (c? (bwhen (p (^my-pathname)) (dirtree-directory-p p)))) :text (c? (bwhen (p (^my-pathname)) (if (^directoryp) (concatenate 'string (car (last (cdr (pathname-directory p)))) "/") (file-namestring p)))) :values-lst (c? (bwhen (p (^my-pathname)) (list (namestring p) (or (ignore-errors (with-open-file (stream p) (file-length stream))) "") (or (bwhen (utime (file-write-date p)) (dirtree-format-date utime)) "")))) :on-open (lambda (self) (setf (^openedp) t)) :on-close (lambda (self) (setf (^openedp) nil)) :kids (c? (the-kids (if (^openedp) (dirtree-make-kids self) (when (^directoryp) (make-kid 'dirtree-node :text "dummy")))))) (defmd dirtree (treeview) :column-ids '("ABSOLUTE-PATHNAME" "SIZE" "DATE") :displaycolumns '("SIZE" "DATE") :kids (c? (the-kids (make-kid 'dirtree-node :my-pathname #p"/" :text "/"))) :treeview-headings (c? (the-kids (mk-treeview-heading :treeview-column-id "#0" :text "Directory Structure") (mk-treeview-heading :treeview-column-id "SIZE" :text "File Size") (mk-treeview-heading :treeview-column-id "DATE" :text "Write date (utime)")))) From kennytilton at optonline.net Sun Sep 28 18:04:44 2008 From: kennytilton at optonline.net (Kenny Tilton) Date: Sun, 28 Sep 2008 14:04:44 -0400 Subject: [cells-devel] Re: Celtk contrib: ttk::treeview In-Reply-To: References: <48DE3B88.8080906@optonline.net> <48DEA802.1050303@optonline.net> <48DFA037.3030705@optonline.net> Message-ID: <48DFC73C.3050700@optonline.net> Madhu wrote: > * Kenny Tilton <48DFA037.3030705 at optonline.net> : > Wrote on Sun, 28 Sep 2008 11:18:15 -0400: > |> The issue was that I could not figure out how to limit expansions down > |> the tree using a kids rule at make-instance time. > | > | That was what I was trying to suggest with the above excerpt, but I > | was too terse: just have the kids rule first check another cell, the > | openp slot. When that goes to t the kids will be generated, when it > | goes to nil they can go away. If you think you need to avoid > | recreating the clos instances you are probably wrong, but you can just > | make the container collapsed when not openp (and play any number of > | tricks to avoid the rule rerunning when openp goes to nil and tossing > | all the kids. > > openp is a slot on treeview-item that controls the ".pathname item -open > node" tcl command. I'm using `openedp' for a new variable. > > | ie, This is a very common requirement solved without SETF. But I > | commend your creativity in finding a solution, and the extensive work > | you did wiring in treeview. You are a quick study! > | > | > |> The general idea was > |> directories should be expanded only when needed. [Further I was using > |> `expandedp' to ensure that directories got expanded only once, even if > |> they were opened multiple times by on-open events]. I couldn't combine > |> these requirements with the desired initial state. > | > | No, you forgot to ask me how. But I understand, I usually charge ahead > | on my own too and Just Get It Working. > > You know what? Youre right. I'm appending the code to this message, > it is a bit simpler without those :after methods on make-tk-instance. > > There is still a question -- of triggering a (setf (^openp) t) in a > dirtree-node kids rule. > > |> Besides, this was supposed to demo the idea that the tree represented in > |> the family's hierarchical model is directly displayed by the widget. So > |> manipulating the model (adding kids, sorting the kids) should reflect in > |> the displayed tree. > | > | ? How does this mandate abandonment of the declarative paradigm? > > The declarative paradigm is already there, to be chosen and used. All > that is being done is support is also added for a traditional > container-contains hierarchy, so one can reach for it JUST IN CASE one > needs it. > -- > Madhu > > PS: Here is the code, in full declarative glory :) OK, /now/ you can go on your long vacation. :) kt