From 91272cf5aadbf7a3ff5c538868ab1fb9ca684a25 Mon Sep 17 00:00:00 2001
From: D Herring <dherring@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