;;;;
;;;; 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 "/")
|#