371 lines
12 KiB
Plaintext
371 lines
12 KiB
Plaintext
;;;;
|
|
;;;; H i e r a r c h y . s t k l o s -- Hierachy management widget
|
|
;;;;
|
|
;;;; Copyright © 1998-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; Permission to use, copy, modify, distribute,and license this
|
|
;;;; software and its documentation for any purpose is hereby granted,
|
|
;;;; provided that existing copyright notices are retained in all
|
|
;;;; copies and that this notice is included verbatim in any
|
|
;;;; distributions. No written agreement, license, or royalty fee is
|
|
;;;; required for any of the authorized uses.
|
|
;;;; This software is provided ``AS IS'' without express or implied
|
|
;;;; warranty.
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@unice.fr]
|
|
;;;; Creation date: 19-Aug-1998 14:02
|
|
;;;; Last file update: 15-Sep-1999 23:15 (eg)
|
|
|
|
(require "Tk-classes")
|
|
|
|
(select-module STklos+Tk)
|
|
(export <Hierarchy-tree> <Hierarchy-item>
|
|
add-item add-node add-leave walk-hierarchy ;; <Hierarchy-tree> methods
|
|
label-item select-item open-item close-item ;; <Hierarchy-item> methods
|
|
remove-item!)
|
|
|
|
(define *hierarchy-font* '(Helvetica 12))
|
|
(define *hierarchy-y* 0)
|
|
(define *hierarchy-node* (make-image "dir.gif"))
|
|
(define *hierarchy-open-node* (make-image "diropen.gif"))
|
|
(define *hierarchy-leave* (make-image "file.gif"))
|
|
(define *hierarchy-box-plus* (make-image "box-plus.gif"))
|
|
(define *hierarchy-box-minus* (make-image "box-minus.gif"))
|
|
|
|
|
|
;=============================================================================
|
|
;
|
|
; < H i e r a r c h y - i t e m >
|
|
;
|
|
;=============================================================================
|
|
|
|
(define-class <Hierarchy-item> ()
|
|
((parent :init-keyword :parent)
|
|
(ancestor :init-keyword :ancestor)
|
|
(data :init-keyword :data)
|
|
(node? :init-keyword :node?)
|
|
(icon :init-keyword :icon :init-form #f)
|
|
(children :init-form '())
|
|
(label-id :init-form #f)
|
|
(open :init-form #f)))
|
|
|
|
|
|
(define-method initialize ((self <Hierarchy-item>) initargs)
|
|
(next-method)
|
|
(let ((ancestor (slot-ref self 'ancestor)))
|
|
;; Update the children list of the ancestor of this item
|
|
(if ancestor
|
|
(slot-set! ancestor 'children (append (slot-ref ancestor 'children)
|
|
(list self))))))
|
|
|
|
(define-method label-item((self <Hierarchy-item>))
|
|
(slot-ref self 'data))
|
|
|
|
|
|
(define-method select-item ((self <Hierarchy-item>))
|
|
(let* ((parent (slot-ref self 'parent))
|
|
(old-selection (slot-ref parent 'selection))
|
|
(old-data (and old-selection (slot-ref old-selection 'data)))
|
|
(data (slot-ref self 'data))
|
|
(scan-proc (lambda (i)
|
|
(let ((D (slot-ref i 'data)))
|
|
(if (and old-selection (eq? D old-data))
|
|
(set-item-background parent i #f))
|
|
(if (eq? D data)
|
|
(set-item-background parent i #t))))))
|
|
(unless (eq? old-data data)
|
|
(walk-hierarchy parent scan-proc)
|
|
(slot-set! parent 'selection self))))
|
|
|
|
(define-method open-item ((self <Hierarchy-item>))
|
|
(slot-set! self 'open #t)
|
|
(if (eq? (slot-ref self 'icon) *hierarchy-node*)
|
|
(slot-set! self 'icon *hierarchy-open-node*))
|
|
(maybe-update-hierarchy (slot-ref self 'parent)))
|
|
|
|
(define-method close-item ((self <Hierarchy-item>))
|
|
(slot-set! self 'open #f)
|
|
(if (eq? (slot-ref self 'icon) *hierarchy-open-node*)
|
|
(slot-set! self 'icon *hierarchy-node*))
|
|
(maybe-update-hierarchy (slot-ref self 'parent)))
|
|
|
|
;=============================================================================
|
|
;
|
|
; < H i e r a r c h y - t r e e >
|
|
;
|
|
;=============================================================================
|
|
|
|
(define-class <Hierarchy-tree> (<Scroll-Canvas>)
|
|
((%redisplay :init-form #f)
|
|
(class :init-keyword :class :init-form "HierarchyTree")
|
|
(root :init-form #f)
|
|
(items-type :init-form <Hierarchy-item> :keyword :items-type)
|
|
(selection :init-form #f)))
|
|
|
|
(define-method initialize ((self <Hierarchy-tree>) initargs)
|
|
(next-method)
|
|
(set! (background (canvas-of self)) "white") ;; Set the canvas bg to white
|
|
(unless (member :h-scroll-side initargs) ;; no horiz scrollbar
|
|
(set! (h-scroll-side self) #f))
|
|
;; Create the root of the hierarchy
|
|
(slot-set! self 'root (add-item self #f #f #t))) ;; self, ancestor, data, node
|
|
|
|
|
|
;;;;
|
|
;;;; add-item -- add an item in the hierarchy (low level. See
|
|
;;;; add-leave and add-node for higher level functions)
|
|
;;;;
|
|
(define-method add-item ((self <Hierarchy-tree>) ancestor data node? icon)
|
|
(let* ((ancestor (or ancestor (slot-ref self 'root)))
|
|
(class (slot-ref self 'items-type))
|
|
(res (make class :parent self :ancestor ancestor :data data
|
|
:node? node? :icon icon)))
|
|
(maybe-update-hierarchy self)
|
|
res))
|
|
|
|
|
|
(define-method add-item ((self <Hierarchy-tree>) ancestor data node?)
|
|
(add-item self ancestor data node? #f))
|
|
|
|
;;==== add-leave
|
|
(define-method add-leave ((self <Hierarchy-tree>) ancestor data)
|
|
(add-item self ancestor data #f *hierarchy-leave*))
|
|
|
|
;;==== add-node
|
|
(define-method add-node ((self <Hierarchy-tree>) ancestor data)
|
|
(add-item self ancestor data #t *hierarchy-node*))
|
|
;;;;
|
|
;;;; remove-item! -- remove an item in the hierarchy
|
|
;;;;
|
|
(define-method remove-item! ((self <Hierarchy-item>))
|
|
(let* ((parent (slot-ref self 'parent))
|
|
(ancestor (slot-ref self 'ancestor))
|
|
(children (slot-ref ancestor 'children)))
|
|
(slot-set! ancestor 'children (remove self children))
|
|
(maybe-update-hierarchy parent)))
|
|
|
|
;;;;
|
|
;;;; Internal use methods
|
|
;;;;
|
|
|
|
;;
|
|
;; set-item-background --
|
|
;;
|
|
(define-method set-item-background ((self <Hierarchy-tree>) item selected?)
|
|
(let ((bg (if selected? "red" "black"))
|
|
(item (slot-ref item 'label-id)))
|
|
((Id self) 'itemconfigure item :fill bg)))
|
|
|
|
|
|
;;
|
|
;; maybe-update-hierarchy -- retain that a hier. must be updated (if necessary)
|
|
;;
|
|
(define (maybe-update-hierarchy h)
|
|
(unless (slot-ref h '%redisplay)
|
|
;; No redisplay resquested yet. Add a request
|
|
(slot-set! h '%redisplay
|
|
(after 'idle (lambda ()
|
|
(update-hierarchy h)
|
|
(slot-set! h '%redisplay #f))))))
|
|
|
|
|
|
|
|
|
|
|
|
;;
|
|
;; update-hierarchy -- display the current hierarchy
|
|
;;
|
|
(define-method update-hierarchy ((self <Hierarchy-tree>))
|
|
;; Delete all items in the hierarchy
|
|
(canvas-delete self 'all)
|
|
;; Display something in 0,0 otherwise the canvas is not centered on the origin
|
|
;; when we finish display. Why?
|
|
((Id self) 'create 'line 0 0 0 0 :fill (background self))
|
|
(set! *hierarchy-y* 0)
|
|
(update-a-hierarchy-level self (slot-ref self 'root) 10)
|
|
;; Update the scroll region of the canvas
|
|
(let ((bbox (bounding-box self 'all)))
|
|
(unless (null? bbox)
|
|
(set! (scroll-region self) bbox)))
|
|
;; Display the selection
|
|
(let* ((selection (slot-ref self 'selection))
|
|
(data (and selection (slot-ref selection 'data)))
|
|
(proc (lambda (i)
|
|
(if (eq? (slot-ref i 'data) data)
|
|
(set-item-background self i #t)))))
|
|
(when selection
|
|
(walk-hierarchy self proc))))
|
|
|
|
|
|
;;
|
|
;; update-a-hierarchy-level -- display a hierachy level (recusrive cal if
|
|
;; -- a folder is encountered). Dont call it directly
|
|
;;
|
|
(define-method update-a-hierarchy-level ((self <Hierarchy-tree>) item indent)
|
|
(define w (Id self))
|
|
|
|
;; WARNING: We don't use Tk tags for bindings here because we use a
|
|
;; lot of bindings for each layer of the tree (several per item in fact).
|
|
;; When using tags, Tk doesn't delete the bindings when canvas items
|
|
;; are deleted but when the canvas itself is deleted. This consumes a lot
|
|
;; of memory for big hierarchies which are opened and closed several time.
|
|
|
|
(define (create-icon-n-label w i x y icon)
|
|
(let* ((label (label-item i))
|
|
(add-bind (lambda (who item)
|
|
(bind self who "<Double-1>" (lambda () (open-item i)))
|
|
(bind self who "<1>" (lambda () (select-item i)))))
|
|
(item (w 'create 'text x y :text label :anchor 'w
|
|
:font *hierarchy-font*)))
|
|
(when icon
|
|
(let ((icon (w 'create 'image (- x 4) y :image icon :anchor 'w)))
|
|
(add-bind icon item)
|
|
(w 'move item 16 0)))
|
|
(slot-set! i 'label-id item)
|
|
(add-bind item item)))
|
|
|
|
(define (create-box w i x y open)
|
|
(if open
|
|
(let ((img (w 'create 'image x y :image *hierarchy-box-minus*)))
|
|
(update-a-hierarchy-level self i (+ indent 18))
|
|
(bind self img "<1>" (lambda() (close-item i))))
|
|
(let ((img (w 'create 'image x y :image *hierarchy-box-plus*)))
|
|
(bind self img "<1>" (lambda() (open-item i))))))
|
|
|
|
(define (display-item i)
|
|
(let ((node? (slot-ref i 'node?))
|
|
(icon (slot-ref i 'icon))
|
|
(x (+ indent 15))
|
|
(y (+ (* 20 *hierarchy-y*) 20)))
|
|
(set! *hierarchy-y* (+ *hierarchy-y* 1))
|
|
(w 'create 'line indent y (+ indent 15) y :fill "gray50")
|
|
(create-icon-n-label w i x y icon)
|
|
(when node?
|
|
(create-box w i indent y (slot-ref i 'open)))))
|
|
|
|
;;============================
|
|
|
|
(let ((initial-y *hierarchy-y*)
|
|
(last-y 0))
|
|
(for-each (lambda (item)
|
|
(set! last-y *hierarchy-y*)
|
|
(display-item item))
|
|
(slot-ref item 'children))
|
|
;; Draw the vertical line linking siblings
|
|
(unless (= initial-y *hierarchy-y*)
|
|
(let ((line (w 'create 'line
|
|
indent (+ (* 20 initial-y) 7)
|
|
indent (* 20 (+ last-y 1))
|
|
:fill "gray50")))
|
|
((Id self) 'lower line)))))
|
|
|
|
(define-method walk-hierarchy ((self <Hierarchy-tree>) proc)
|
|
(let Loop ((item (slot-ref self 'root)))
|
|
(proc item)
|
|
(if (slot-ref item 'node?)
|
|
(for-each Loop (slot-ref item 'children)))))
|
|
|
|
|
|
(provide "Hierarchy")
|
|
|
|
;=============================================================================
|
|
|
|
#|
|
|
|
|
Simple usage of the <Hierarchy-tree> class:
|
|
|
|
(define T (make <Hierarchy-tree>))
|
|
(pack T :expand #t :fill "both")
|
|
|
|
(define d1 (add-node T #f "dir1"))
|
|
(define d2 (add-node T #f "dir2"))
|
|
(define d3 (add-node T d1 "dir3"))
|
|
|
|
(add-leave T d1 "file2")
|
|
(add-leave T d1 "file1")
|
|
(add-leave T d3 "file3")
|
|
(add-leave T d2 "file4")
|
|
|
|
Inheritance hierarchy
|
|
|
|
Another example where we make a subclass of <Hierarchy-tree> and
|
|
<Hierarchy-item>. The hierarchy tree must define the slot item-types
|
|
which contain the type of the items of the hierarchy. Furthermore,
|
|
open-item and close-item have been redefined to ensure that the
|
|
the subtree is cleaned when we close a node (i.e. re-opening a closed
|
|
node will query its *actual* leaves, even if they have changed).
|
|
|
|
(define-class <Inheritance-item> (<Hierarchy-item>) ())
|
|
|
|
(define-class <Inheritance-tree> (<Hierarchy-tree>)
|
|
((items-type :init-form <Inheritance-item>)))
|
|
|
|
(define-method open-item((self <Inheritance-item>))
|
|
(let* ((data (slot-ref self 'data))
|
|
(children (slot-ref self 'children))
|
|
(hierarchy (slot-ref self 'parent))
|
|
(subclasses (class-direct-subclasses data)))
|
|
|
|
(when (and (null? children) (not (null? subclasses)))
|
|
(for-each (lambda (x)
|
|
(if (null? (class-direct-subclasses x))
|
|
(add-leave hierarchy self x)
|
|
(add-node hierarchy self x)))
|
|
subclasses)))
|
|
;; Do the redisplay
|
|
(next-method))
|
|
|
|
(define-method close-item((self <Inheritance-item>))
|
|
(slot-set! self 'children '())
|
|
(next-method))
|
|
|
|
(define-method label-item((self <Hierarchy-item>))
|
|
(class-name (slot-ref self 'data)))
|
|
|
|
(define T (make <Inheritance-tree>))
|
|
(pack T :expand #t :fill "both")
|
|
(add-node T #f <top>)
|
|
|
|
File Hierarchy
|
|
|
|
In this example, we don't redefine close-item => we have a cache of the
|
|
hierarchy (which can be erroneous if disk state has changed)
|
|
|
|
(define-class <File-item> (<Hierarchy-item>) ())
|
|
|
|
(define-class <File-tree> (<Hierarchy-tree>)
|
|
((items-type :init-form <File-item>)))
|
|
|
|
|
|
(define-method open-item((self <File-item>))
|
|
(let* ((data (slot-ref self 'data))
|
|
(children (slot-ref self 'children))
|
|
(hierarchy (slot-ref self 'parent)))
|
|
|
|
(when (null? children)
|
|
;; This is the first time that we open this item and it has children
|
|
(for-each (lambda (x)
|
|
(if (file-is-directory? x)
|
|
(add-node hierarchy self x)
|
|
(add-leave hierarchy self x)))
|
|
(sort (glob (string-append data "/*")) string<?))))
|
|
;; Do the redisplay
|
|
(next-method))
|
|
|
|
(define-method label-item((self <File-item>))
|
|
(let ((name (slot-ref self 'data)))
|
|
(if (string=? name "/")
|
|
"/"
|
|
(basename name))))
|
|
|
|
(define-method select-item ((self <File-item>))
|
|
(let ((name (slot-ref self 'data)))
|
|
(unless (file-is-directory? name)
|
|
(system (string-append "xedit " name " &"))))
|
|
(next-method))
|
|
|
|
(define T (make <File-tree>))
|
|
(pack T :expand #t :fill "both")
|
|
(add-node T #f "/")
|
|
|#
|