[ltk-user] treeview improvements

[Daniel Herring]

Please consider the attached patch; it contains a few fixes.

The attached filetree.lisp is another example of using a treeview.

Later,
Daniel
-------------- next part --------------
(defpackage :filetree
  (:use :cl :ltk))

(in-package :filetree)

(defclass file-tree (frame)
  ((tree :accessor ft-tree
         :initform nil)
   (scroll :accessor ft-scroll)
   (root-dir :accessor ft-root-dir
             :initform nil)
   (dir-paths :accessor ft-dir-paths
              :initform (make-hash-table :test 'equal)
              :documentation "store the path for unvisited directory nodes")))

(defun make-id () (symbol-name (gensym "FILETREE-ID-")))
(defun make-stub-id (id) (concatenate 'string id "-STUB"))

;; idea: lazy initialization of sub-trees.
;; Show a stub for directories; populate it when a directory is selected and is nonempty.
;; Needs a mechanism for relisting directories if things change...
(defun update-dir (ft parent)
  (let* ((stub (make-stub-id parent))
         (tree (ft-tree ft))
         (dir-paths (ft-dir-paths ft))
         (dir (gethash parent dir-paths))
         paths)
    (if dir
        (setf paths (cl-fad:list-directory dir))
        (print :no-dir))
    (unless (equal parent "{}")
      ;; the stub for "{}" is invalid TCL.
      (if (and paths
               (treeview-exists tree stub))
          (treeview-delete tree stub)
          (return-from update-dir)))
    (dolist (p paths)
      (if (cl-fad:directory-pathname-p p)
          (let* ((id (make-id))
                 (stub (make-stub-id id)))
            (setf (gethash id dir-paths) p)
            (treeview-insert tree
                             :parent parent
                             :id id
                             :text (car (last (pathname-directory p))))
            (treeview-insert tree
                             :parent id
                             :id stub))
          (let ((id (make-id))
                (name (pathname-name p))
                (type (pathname-type p)))
            (treeview-insert tree
                             :parent parent
                             :id id
                             :text (if type
                                       (concatenate 'string
                                                    name
                                                    "."
                                                    type)
                                       name)))))))

(defmethod (setf ft-root-dir) :after (root (ft file-tree))
  (setf (gethash "{}" (ft-dir-paths ft)) root)
  (update-dir ft "{}"))

(defmethod initialize-instance :after ((ft file-tree)
                                       &key
                                       root-directory)
  (with-accessors ((tree ft-tree)
                   (scroll ft-scroll))
      ft
    (setf tree
          (make-instance 'treeview
                         :master ft
                         :columns "{1 2 3 4}")
          scroll
          (make-instance 'scrollbar
                         :master ft))


    (treeview-heading tree :#0
                      :text "name")
    (treeview-heading tree 1
                      :text "attrs")
    
    ;; connect the tree and scrollbar
    (configure tree "yscrollcommand" (format nil "~A set" (widget-path scroll)))
    (configure scroll "command" (format nil "~A yview" (widget-path tree)))
    ;; pack everything nicely
    (pack ft :side :left :fill :both :expand t)
    (pack tree :side :left :fill :both :expand t)
    (pack scroll :side :left :fill :y :expand nil)

    (bind tree "<<TreeviewOpen>>"
          (lambda (e)
            (declare (ignore e))
            (update-dir ft (treeview-focus tree)))))

  (when root-directory
    (setf (ft-root-dir ft) root-directory)))

(defun show-directory (&optional (directory *default-pathname-defaults*))
  "Simple wrapper around file-tree."
  (with-ltk ()
    (make-instance 'file-tree
                   :root-directory directory)))
-------------- next part --------------
From e94b068977051f444efb3f96a0144e1b2c8ca37f Mon Sep 17 00:00:00 2001
From: D Herring <dherring at at.tentpost.dot.com>
Date: Mon, 28 Jun 2010 01:05:11 -0400
Subject: [PATCH] treeview fixes and improvements

---
 ltk.lisp |   14 ++++++++------
 1 files changed, 8 insertions(+), 6 deletions(-)

diff --git a/ltk.lisp b/ltk.lisp
index 7fb36be..71bb6f1 100644
--- a/ltk.lisp
+++ b/ltk.lisp
@@ -2668,13 +2668,15 @@ set y [winfo y ~a]
 	       option value rest))
 
 (defgeneric treeview-delete (tree items))
-(defmethod treeview-delete ((tree treeview) items)
+(defmethod treeview-delete ((tree treeview) item)
+  (format-wish "~a delete {~a}" (widget-path tree) item))
+(defmethod treeview-delete ((tree treeview) (items cons))
   (format-wish "~a delete {~{~a~^ ~}}" (widget-path tree) items))
 
 (defgeneric treeview-exists (tree item))
 (defmethod treeview-exists ((tree treeview) item)
-  (format-wish "~a exists ~a" (widget-path tree) item)
-  (equal (read-data) 1))
+  (format-wish "senddata [~a exists ~a]" (widget-path tree) item)
+  (= (read-data) 1))
 
 (defgeneric treeview-focus (tree))
 (defmethod treeview-focus ((tree treeview))
@@ -2729,15 +2731,15 @@ set y [winfo y ~a]
   |#
   id)
 
-(defun treeview-item (tree column &rest options)
+(defun treeview-item (tree item &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))
+                  (widget-path tree) item options))
     (t ;; query
      (format-wish "senddatastring [~a item ~a ~@[ -~(~a~)~]]"
-                  (widget-path tree) column (car options))
+                  (widget-path tree) item (car options))
      (read-data))))
 
 (defun treeview-column (tree column &rest options)
-- 
1.7.1