[ltk-user] [patch] Improved ttk treeview support
Daniel Herring
dherring at tentpost.com
Fri Jan 1 21:02:59 UTC 2010
Hi Peter,
Please consider the attached patch against
http://ltk.rplay.net/svn/branches/ltk/repl@215
It implements several essential treeview commands; they are being used to
implement a symbol/package browser for ABLE.
http://common-lisp.net/project/able/
The attached treeview-example.lisp demonstrates their usage.
* (load "treeview-example.lisp")
* (ltk-user::show-symbols :ltk-user)
Thanks,
Daniel
-------------- next part --------------
(require :ltk)
(in-package :ltk-user)
(defun show-symbols (package-designator)
(with-ltk ()
(let* ((package (find-package package-designator))
(symbols nil)
(rows nil)
(top (make-instance 'frame))
(tree (make-instance 'treeview
:master top
:columns "{1 2 3 4}"
))
(sc (make-instance 'scrollbar :master top))
;; font-width should be calculated...
(font-width 10))
(macrolet
((sort-col (accessor up down)
`(let ((up t))
(lambda ()
(dolist (item (setf rows
(stable-sort rows
(if up ,up ,down)
:key ,accessor)))
(treeview-move tree (car item)))
(setf up (not up))))))
(treeview-heading tree :#0
:text "name"
:command (sort-col #'first #'string< #'string>))
(treeview-heading tree 1
:text "attrs"
:command (sort-col #'second #'string< #'string>))
(treeview-column tree 1 :width (* 5 font-width))
(treeview-heading tree 2
:text "#plist"
:command (sort-col #'third #'< #'>))
(treeview-column tree 2 :width (* 5 font-width))
(treeview-heading tree 3
:text "status"
:command (sort-col #'fourth #'string< #'string>))
(treeview-column tree 3 :width (* 9 font-width))
(treeview-heading tree 4
:text "package"
:command (sort-col #'fifth #'string< #'string>)))
(configure tree "yscrollcommand" (format nil "~A set" (widget-path sc)))
(configure sc "command" (format nil "~A yview" (widget-path tree)))
(pack top :side :left :fill :both :expand t)
(pack tree :side :left :fill :both :expand t)
(pack sc :side :left :fill :y :expand nil)
;; guard against do-sybmols processing the same symbol multiple times (allowed behavior)
(do-symbols (symbol package)
(pushnew symbol symbols :test #'eq))
(dolist (symbol (reverse symbols))
(let* ((name (symbol-name symbol))
(pack (symbol-package symbol))
(pname (package-name pack))
(values (list (concatenate
'string
(when (boundp symbol)
(if (constantp symbol)
"c"
"b"))
(when (fboundp symbol)
(let ((mods (concatenate
'string
(when (macro-function symbol) "m")
(when (special-operator-p symbol) "o"))))
(if (string= mods "")
"f"
mods)))
(when (keywordp symbol) "k")
;; this one is problematic
;;(when (compiler-macro-function name) "M")
)
(length (symbol-plist symbol))
;; status
(second (multiple-value-list (find-symbol name package)))
pname)))
(push (cons name values) rows)
(treeview-insert tree
:id name
:text name
:values values))))))
-------------- next part --------------
From 91272cf5aadbf7a3ff5c538868ab1fb9ca684a25 Mon Sep 17 00:00:00 2001
From: D Herring <dherring at at.tentpost.dot.com>
Date: Fri, 1 Jan 2010 15:36:16 -0500
Subject: [PATCH] Improved treeview support
- fix treeview-focus
- add the insert, item, column, heading, and move commands
- add dictionary-plist and tk-princ utils
I decided against using generic functions for the treeview commands since
they do not appear to have much in common with other Tk commands.
If desired, it would not be hard to write generic functions that call these.
---
ltk.lisp | 109 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--
1 files changed, 106 insertions(+), 3 deletions(-)
diff --git a/ltk.lisp b/ltk.lisp
index 96bbff1..205c7be 100644
--- a/ltk.lisp
+++ b/ltk.lisp
@@ -385,6 +385,12 @@ toplevel x
#:children
#:treeview-focus
#:treeview-exists
+ #:dictionary-plist
+ #:treeview-insert
+ #:treeview-item
+ #:treeview-column
+ #:treeview-heading
+ #:treeview-move
#:self))
(defpackage :ltk-user
@@ -2565,10 +2571,107 @@ set y [winfo y ~a]
(format-wish "~a exists ~a" (widget-path tree) item)
(equal (read-data) 1))
-(defgeneric treeview-focus (tree item))
-(defmethod treeview-focus ((tree treeview) item)
- (format-wish "~a exists ~a" (widget-path tree) item))
+(defgeneric treeview-focus (tree))
+(defmethod treeview-focus ((tree treeview))
+ (format-wish "senddatastring [~a focus]" (widget-path tree))
+ (read-data))
+
+(defgeneric (setf treeview-focus) (item tree))
+(defmethod (setf treeview-focus) (item tree)
+ (format-wish "~a focus ~a" (widget-path tree) item))
+
+(defun dictionary-plist (string)
+ "return a plist representing the TCL dictionary"
+ ;; crude but rather effective
+ (do* ((*package* (find-package :keyword))
+ (length (length string))
+ (plist nil)
+ (key (position #\- string)
+ (position #\- string :start (1+ val)))
+ (val (position #\Space string :start (if key (1+ key) length))
+ (position #\Space string :start (if key (1+ key) length))))
+ ((null val)
+ (reverse plist))
+ (push (read-from-string string t t :start (1+ key)) plist)
+ (push (read-from-string string t t :start (1+ val)) plist)))
+
+(defun tk-princ (stream arg colon at)
+ "Like princ (format ~a), but convert a lisp list to a Tk list."
+ (declare (ignore colon at))
+ (cond ((or (null arg)
+ (and (stringp arg)
+ (string= arg "")))
+ (format stream "{}"))
+ ((listp arg)
+ (format stream "{~{~/ltk::tk-princ/~^ ~}}" arg))
+ (t
+ (format stream "~a" arg))))
+
+(defun treeview-insert (tree &rest options
+ &key (parent "{}") (index "end") (id (create-name)) &allow-other-keys)
+ "Creates a new item. Returns its id. See also the treeitem class."
+ ;; Remove the keys that aren't optional in Tcl.
+ (remf options :parent)
+ (remf options :index)
+ (format-wish "~a insert ~a ~a~{ -~(~a~) ~/ltk::tk-princ/~}"
+ (widget-path tree)
+ parent
+ index
+ options)
+ #| Note:
+ It is tempting to use senddata/read-data and let Tk allocate an id.
+ BAD IDEA! Process swapping causes a massive slowdown (observed 100x longer).
+ |#
+ id)
+(defun treeview-item (tree column &rest options)
+ "Query or modify the options for the specified item."
+ (cond
+ ((second options) ;; modify
+ (format-wish "~a item ~a~{ -~(~a~) ~/ltk::tk-princ/~}"
+ (widget-path tree) column options))
+ (t ;; query
+ (format-wish "senddatastring [~a item ~a ~@[ -~(~a~)~]]"
+ (widget-path tree) column (car options))
+ (read-data))))
+
+(defun treeview-column (tree column &rest options)
+ "Query or modify the options for the specified column."
+ (cond
+ ((second options) ;; modify
+ (format-wish "~a column ~a~{ -~(~a~) ~/ltk::tk-princ/~}"
+ (widget-path tree) column options))
+ (t ;; query
+ (format-wish "senddatastring [~a column ~a ~@[ -~(~a~)~]]"
+ (widget-path tree) column (car options))
+ (read-data))))
+
+(defun treeview-heading (tree column &rest options
+ &key command &allow-other-keys
+ &aux (path (widget-path tree)))
+ "Query or modify the heading options for the specified column."
+ (cond
+ ((second options) ;; modify
+ (when command
+ ;; register the callback
+ (let ((cbname (format nil "~a:~a" path column)))
+ (add-callback cbname command)
+ (setf (getf options :command)
+ (concatenate 'string "{callback " cbname "}"))))
+ (format-wish "~a heading ~a~{ -~(~a~) ~/ltk::tk-princ/~}"
+ path column options))
+ (t ;; query
+ (format-wish "senddatastring [~a heading ~a ~@[ -~(~a~)~]]"
+ path column (car options))
+ (read-data))))
+
+(defun treeview-move (tree item &optional parent index)
+ "Moves item to position index in parent's list of children."
+ (format-wish "~a move ~a ~a ~a"
+ (widget-path tree)
+ item
+ (or parent "{}")
+ (or index "end")))
(defclass treeitem (tkobject)
((tree :accessor tree :initform nil :initarg :tree)
--
1.6.0.2
More information about the ltk-user
mailing list