;;; "wttree.scm" Weight balanced trees			-*-Scheme-*-

;; This is an early attempt to see how much can be gained when using
;; weight balanced trees to find file descriptors.

;;; Copyright (c) 1993-1994 Stephen Adams
;;;
;;; Modified by Joerg F. Wittenberger to virtualize object access.

;; Usage:
;;

;;;
;;; This note needs to be rewritten, since it's only sensible in the
;;; context of Askemos programming.
;;;
;;; The idea is, that "restore" is to be used to delay and redirect
;;; actuall resolution of tree nodes.  The code is careful to share as
;;; much as possible from the original tree.  That is, unmodified
;;; nodes are retained as their unresolved handles.  "dump" keep these
;;; handles and only store the difference in persistant memory.
;;;

;; To update a "string<?"-ordered-tree linked as "nodes" adding a new "value" under "name".
;;
;;      (let ((n (wt-tree/dump
;; 	       (wt-tree/add
;; 		(wt-tree/restore (make-wt-tree-type string<? (wt-marshall me identity literal))
;; 				 "nodes")
;; 		name value))))
;;        ((me 'get 'linker) "nodes"
;;	   (nunu-make-new-place-of me msg (node-list-first n))))
;;
;; To update a "<"-ordered-tree linked as "ints" adding a new "value" under "name".
;;
;;      (let ((n (wt-tree/dump
;; 	       (wt-tree/add
;; 		(wt-tree/restore (make-wt-tree-type < (wt-marshall me string->number literal))
;; 				 (me "ints"))
;; 		name value))))
;; 	  ((me 'get 'linker) "ints"
;; 	   (nunu-make-new-place-of me msg (node-list-first n))))

(declare
  (fixnum)
  (disable-interrupts)
  (usual-integrations) )

(module
 wttree
 (
  make-wt-tree-type
  string-wt-type number-wt-type
  make-wt-tree
  singleton-wt-tree
  alist->wt-tree
  wt-tree/empty?
  wt-tree/size
  wt-tree/add wt-tree/add!
  wt-tree/delete wt-tree/delete!
  wt-tree/member?
  wt-tree/lookup
  wt-tree/split<
  wt-tree/split>
  wt-tree/union
  wt-tree/intersection
  wt-tree/difference
  wt-tree/subset?
  wt-tree/set-equal?
  wt-tree/fold
  wt-tree/for-each
  wt-tree/index
  wt-tree/index-datum
  wt-tree/index-pair
  wt-tree/rank
  wt-tree/max
  wt-tree/min
  wt-tree/min-datum
  wt-tree/min-pair
  wt-tree/delete-min wt-tree/delete-min!

  string-wt-type
  number-wt-type
  wt-marshall

  wt-tree/dump
  wt-tree/restore
  )
(import scheme chicken ports)

(define-record-type <wt-environment>
  (make-wt-environment
   deref
   make-entry)
  wt-environment?
  (deref deref-entry)
  (make-entry make-entry))

(define-syntax wt:error
  (syntax-rules ()
    ((wt:error arg ...)
     (error (call-with-output-string
	     (lambda (port)
	       (for-each (lambda (a) (display a port) (display #\space port))
			 arg ...)))))))

(define wt-marshall #f)

;;; References:
;;;
;;;   Stephen Adams, Implementing Sets Efficiently in a Functional
;;;      Language, CSTR 92-10, Department of Electronics and Computer
;;;      Science, University of Southampton, 1992
;;;
;;;
;;; Copyright (c) 1993-94 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of Electrical
;;; Engineering and Computer Science.  Permission to copy and modify
;;; this software, to redistribute either the original software or a
;;; modified version, and to use this software for any purpose is
;;; granted, subject to the following restrictions and understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a) to
;;; return to the MIT Scheme project any improvements or extensions
;;; that they make, so that these may be included in future releases;
;;; and (b) to inform MIT of noteworthy uses of this software.
;;;
;;; 3. All materials developed as a consequence of the use of this
;;; software shall duly acknowledge such use, in accordance with the
;;; usual standards of acknowledging credit in academic research.
;;;
;;; 4. MIT has made no warranty or representation that the operation
;;; of this software will be error-free, and MIT is under no
;;; obligation to provide any services, by way of maintenance, update,
;;; or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the Massachusetts
;;; Institute of Technology nor of any adaptation thereof in any
;;; advertising, promotional, or sales literature without prior
;;; written consent from MIT in each case.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  Weight Balanced Binary Trees
;;
;;
;;
;;  This file has been modified from the MIT-Scheme library version to
;;  make it more standard. The main changes are
;;
;;   . The whole thing has been put in a LET as R4RS Scheme has no module
;;     system.
;;   . The MIT-Scheme define structure operations have been written out by
;;     hand.
;;
;;  It has been tested on MIT-Scheme, scheme48 and scm4e1
;;
;;  If your system has a compiler and you want this code to run fast, you
;;  should do whatever is necessary to inline all of the structure accessors.
;;
;;  This is MIT-Scheme's way of saying that +, car etc should all be inlined.
;;
;;(declare (usual-integrations))

;;;
;;; Interface to this package.
;;;
;;; ONLY these procedures (and TEST at the end of the file) will be
;;; (re)defined in your system.
;;;
;@
(define make-wt-tree-type #f)
(define number-wt-type #f)
(define string-wt-type #f)
;@
(define make-wt-tree #f)
(define singleton-wt-tree #f)
(define alist->wt-tree #f)
(define wt-tree/empty? #f)
(define wt-tree/size #f)
(define wt-tree/add #f)
(define wt-tree/delete #f)
(define wt-tree/add! #f)
(define wt-tree/delete! #f)
(define wt-tree/member? #f)
(define wt-tree/lookup #f)
(define wt-tree/split< #f)
(define wt-tree/split> #f)
(define wt-tree/union #f)
(define wt-tree/intersection #f)
(define wt-tree/difference #f)
(define wt-tree/subset? #f)
(define wt-tree/set-equal? #f)
(define wt-tree/fold #f)
(define wt-tree/for-each #f)
(define wt-tree/index #f)
(define wt-tree/index-datum #f)
(define wt-tree/index-pair #f)
(define wt-tree/rank #f)
(define wt-tree/max #f)
(define wt-tree/min #f)
(define wt-tree/min-datum #f)
(define wt-tree/min-pair #f)
(define wt-tree/delete-min #f)
(define wt-tree/delete-min! #f)

(define wt-tree/dump #f)
(define wt-tree/restore #f)

(define wttree-forms #f)

;; Record Type definitions moved out of the let since they translate
;; to classes in RScheme and these must be defined at to level.

(define-record-type <wt-tree-type>
  (%make-tree-type key<?       alist->tree
		   add         insert!
		   delete      delete!
		   member?     lookup
		   split-lt    split-gt
		   union       intersection
		   difference  subset?
		   rank
		   ;;
		   environment
		   )
  tree-type?
  (key<? tree-type/key<?)
  (alist->tree tree-type/alist->tree)
  (add tree-type/add)
  (insert! tree-type/insert!)
  (delete tree-type/delete)
  (delete! tree-type/delete!)
  (member? tree-type/member?)
  (lookup tree-type/lookup)
  (split-lt tree-type/split-lt)
  (split-gt tree-type/split-gt)
  (union tree-type/union)
  (intersection tree-type/intersection)
  (difference tree-type/difference)
  (subset? tree-type/subset?)
  (rank tree-type/rank)
  ;;
  (environment tree-type/environment)
  )

(define-record-type <wt-tree>
  (%make-wt-tree type root)
  wt-tree?
  (type tree/type)
  (root tree/root set-tree/root!))

(cond-expand
 (chicken-forget-it-there-is-nothing-to-gain
  (define (%make-node k v l r w)  (##sys#make-structure 'wt-tree-node k v l r w))
  (define-inline (%node? obj) (##sys#structure? obj 'wt-tree-node))
  (define-inline (node/k t) (##sys#slot t 1))
  (define-inline (node/v t) (##sys#slot t 2))
  (define-inline (node/l t) (##sys#slot t 3))
  (define-inline (node/r t) (##sys#slot t 4))
  (define-inline (node/w t) (##sys#slot t 5)))
 (else
  (define-record-type <wt-tree-node>
    (%make-node k v l r w)
    %node?
    (k node/k)
    (v node/v)
    (l node/l)
    (r node/r)
    (w node/w))))

;; This LET sets all of the above variables.

(let ()

  ;;  A TREE-TYPE is a collection of those procedures that depend on the
  ;;  ordering relation.

  ;; MIT-Scheme structure definition
  ;;(define-structure
  ;;    (tree-type
  ;;     (conc-name tree-type/)
  ;;     (constructor %make-tree-type))
  ;;  (key<?       #F read-only true)
  ;;  (alist->tree #F read-only true)
  ;;  (add         #F read-only true)
  ;;  (insert!     #F read-only true)
  ;;  (delete      #F read-only true)
  ;;  (delete!     #F read-only true)
  ;;  (member?     #F read-only true)
  ;;  (lookup      #F read-only true)
  ;;  (split-lt    #F read-only true)
  ;;  (split-gt    #F read-only true)
  ;;  (union       #F read-only true)
  ;;  (intersection #F read-only true)
  ;;  (difference  #F read-only true)
  ;;  (subset?     #F read-only true)
  ;;  (rank        #F read-only true)
  ;;
  ;;  (environment #f read-only true)
  ;;)

  ;; Written out by hand, using vectors:
  ;;
  ;; If possible, you should teach your system to print out something
  ;; like #[tree-type <] instead of the whole vector.

;;   (define tag:tree-type (string->symbol "#[(runtime wttree)tree-type]"))

;;   (define (%make-tree-type key<?       alist->tree
;;                            add         insert!
;;                            delete      delete!
;;                            member?     lookup
;;                            split-lt    split-gt
;;                            union       intersection
;;                            difference  subset?
;;                            rank
;; 			   ;;
;; 			   environment
;; 			   )
;;     (vector tag:tree-type
;;             key<?       alist->tree   add         insert!
;;             delete      delete!       member?     lookup
;;             split-lt    split-gt      union       intersection
;;             difference  subset?       rank
;; 	    environment))

;;   (define (tree-type? tt)
;;     (and (vector? tt)
;;          (eq? (vector-ref tt 0) tag:tree-type)))

;;   (define (tree-type/key<?        tt) (vector-ref tt 1))
;;   (define (tree-type/alist->tree  tt) (vector-ref tt 2))
;;   (define (tree-type/add          tt) (vector-ref tt 3))
;;   (define (tree-type/insert!      tt) (vector-ref tt 4))
;;   (define (tree-type/delete       tt) (vector-ref tt 5))
;;   (define (tree-type/delete!      tt) (vector-ref tt 6))
;;   (define (tree-type/member?      tt) (vector-ref tt 7))
;;   (define (tree-type/lookup       tt) (vector-ref tt 8))
;;   (define (tree-type/split-lt     tt) (vector-ref tt 9))
;;   (define (tree-type/split-gt     tt) (vector-ref tt 10))
;;   (define (tree-type/union        tt) (vector-ref tt 11))
;;   (define (tree-type/intersection tt) (vector-ref tt 12))
;;   (define (tree-type/difference   tt) (vector-ref tt 13))
;;   (define (tree-type/subset?      tt) (vector-ref tt 14))
;;   (define (tree-type/rank         tt) (vector-ref tt 15))
;;   (define (tree-type/environment  tt) (vector-ref tt 16))

;;   ;;  User level tree representation.
;;   ;;
;;   ;;  WT-TREE is a wrapper for trees of nodes.

;;   ;;
;;   ;;MIT-Scheme:
;;   ;;(define-structure
;;   ;;    (wt-tree
;;   ;;     (conc-name tree/)
;;   ;;     (constructor %make-wt-tree))
;;   ;;  (type  #F read-only true)
;;   ;;  (root  #F read-only false))

;;   ;; If possible, you should teach your system to print out something
;;   ;; like #[wt-tree] instread of the whole vector.

;;   (define tag:wt-tree (string->symbol "#[(runtime wttree)wt-tree]"))

;;   (define (%make-wt-tree type root)
;;     (vector tag:wt-tree type root))

;;   (define (wt-tree? t)
;;     (and (vector? t)
;;          (eq? (vector-ref t 0) tag:wt-tree)))

;;   (define (tree/type t) (vector-ref t 1))
;;   (define (tree/root t) (vector-ref t 2))
;;   (define (set-tree/root! t v) (vector-set! t 2 v))

;;   ;;  Nodes are the thing from which the real trees are built.  There are
;;   ;;  lots of these and the uninquisitibe user will never see them, so
;;   ;;  they are represented as untagged to save the slot that would be
;;   ;;  used for tagging structures.

;;   ;;  In MIT-Scheme these were all DEFINE-INTEGRABLE

;;   (define (%make-node k v l r w) (vector w l k r v))
;;   (define %node? vector?)
;;   (define (node/k node) (vector-ref node 2))
;;   (define (node/v node) (vector-ref node 4))
;;   (define (node/l node) (vector-ref node 1))
;;   (define (node/r node) (vector-ref node 3))
;;   (define (node/w node) (vector-ref node 0))
;;;;;;;;

  (define empty  'empty)
  (define (empty? x) (eq? x 'empty))

  (define-syntax deref
    (syntax-rules ()
      ((deref e r) ((deref-entry e) %make-node r))))

  (define (node/size node)
    (if (empty? node) 0 (node/w node)))

  (define (node/singleton k v) (%make-node k v empty empty 1))

  (define (with-n-node e node receiver)
    (let ((node (deref e node)))
      (receiver e (node/k node) (node/v node) (node/l node) (node/r node))))

  ;;
  ;;  Constructors for building node trees of various complexity
  ;;

  (define (n-join e k v l r)
    (%make-node k v l r (fx+ 1 (fx+ (node/size (deref e l)) (node/size (deref e r))))))

  (define (single-l e a.k a.v x r)
    (with-n-node e r
      (lambda (e b.k b.v y z) (n-join e b.k b.v (n-join e a.k a.v x y) z))))

  (define (double-l e a.k a.v x r)
    (with-n-node e r
      (lambda (e c.k c.v r.l z)
        (with-n-node e r.l
          (lambda (e b.k b.v y1 y2)
            (n-join e b.k b.v
                    (n-join e a.k a.v x y1)
                    (n-join e c.k c.v y2 z)))))))

  (define (single-r e b.k b.v l z)
    (with-n-node e l
      (lambda (e a.k a.v x y) (n-join e a.k a.v x (n-join e b.k b.v y z)))))

  (define (double-r e c.k c.v l z)
    (with-n-node e l
      (lambda (e a.k a.v x l.r)
        (with-n-node e l.r
          (lambda (e b.k b.v y1 y2)
            (n-join e b.k b.v
                    (n-join e a.k a.v x y1)
                    (n-join e c.k c.v y2 z)))))))

  ;; (define-integrable wt-tree-ratio 5)
  (define wt-tree-ratio 5)

  (define (t-join e k v l r)
    (let ((l (deref e l))
	  (r (deref e r)))
      (define (simple-join) (n-join e k v l r))
      (let ((l.n  (node/size l))
	    (r.n  (node/size r)))
	(cond ((fx< (fx+ l.n r.n) 2)   (simple-join))
	      ((fx> r.n (fx* wt-tree-ratio l.n))
	       ;; right is too big
	       (let ((r.l.n  (node/size (deref e (node/l r))))
		     (r.r.n  (node/size (deref e (node/r r)))))
		 (if (fx< r.l.n r.r.n)
		     (single-l e k v l r)
		     (double-l e k v l r))))
	      ((fx> l.n (fx* wt-tree-ratio r.n))
	       ;; left is too big
	       (let ((l.l.n  (node/size (deref e (node/l l))))
		     (l.r.n  (node/size (deref e (node/r l)))))
		 (if (fx< l.r.n l.l.n)
		     (single-r e k v l r)
		     (double-r e k v l r))))
	      (else
	       (simple-join))))))
  ;;
  ;;  Node tree procedures that are independent of key<?
  ;;

  (define (node/max e node)
    (if (empty? node) (error:empty 'max)
	(let ((node (deref e node)))
	  (if (empty? (node/r node)) node
	      (node/max e (deref e (node/r node)))))))

  (define (node/min e node)
    (if (empty? node) (error:empty 'min)
	(let ((node (deref e node)))
	  (if (empty? (node/l node)) node
	      (node/min e (deref e (node/l node)))))))

  (define (node/delmin e node)
    (if (empty? node) (error:empty 'delmin)
	(let ((node (deref e node)))
	  (cond
	   ((empty? (node/l node))  (node/r node))
	   (else   (t-join e (node/k node) (node/v node)
			   (node/delmin e (node/l node)) (node/r node)))))))

  (define (node/concat2 e node1 node2)
    (cond ((empty? node1)   node2)
          ((empty? node2)   node1)
          (else
           (let ((min-node (deref e (node/min e node2))))
             (t-join e (node/k min-node) (node/v min-node)
                     node1 (node/delmin e node2))))))

  (define (node/inorder-fold e procedure base node)
    (define (fold base node)
      (if (empty? node)
          base
          (with-n-node e node
            (lambda (e k v l r)
              (fold (procedure k v (fold base r)) l)))))
    (fold base node))

  (define (node/dump e node)
    (define (fold base node)
      (if (empty? node)
          base
          (with-n-node e node
            (lambda (e k v l r)
              (let ((l (deref e l))
		    (r (deref e r)))
		(let ((nr (fold '() r)))
		  ((make-entry e) k v (fold '() l) nr (+ 1 (node/size l) (node/size r)))))))))
    (fold '() node))

  (define (node/for-each e procedure node)
    (if (not (empty? node))
        (with-n-node e node
          (lambda (e k v l r)
            (node/for-each e procedure l)
            (procedure k v)
            (node/for-each e procedure r)))))

  (define (node/height e node)
    (if (empty? node)
        0
        (+ 1 (let ((node (deref e node)))
	       (max (node/height e (node/l node))
		    (node/height e (node/r node)))))))

  (define (node/index e node index)
    (define (loop node index)
      (let* ((l (deref e (node/l node)))
	     (size.l  (node/size l)))
	(cond ((fx< index size.l)  (loop l index))
	      ((fx> index size.l)  (loop (deref e (node/r node))
					   (fx- index (fx+ 1 size.l))))
	      (else                  node))))
    (let ((node (deref e node)))
      (let ((bound  (node/size node)))
	(if (or (< index 0)
		(>= index bound)
		(not (fixnum? index)))
	    (wt:error 'bad-range-argument index 'node/index)
	    (loop node index)))))

  (define (error:empty owner)
    (wt:error "Operation requires non-empty tree:" owner))

  (define (identity _ x) x)
  (define default-wt-environment
    (make-wt-environment identity (lambda (k v l r) #f)))

  (define (local:make-wt-tree-type key<? . opt)

    (define e (if (pair? opt) (car opt) default-wt-environment))

    ;; MIT-Scheme definitions:
    ;;(declare (integrate key<?))
    ;;(define-integrable (key>? x y)  (key<? y x))

    (define (key>? x y)  (key<? y x))

    (define (node/find k node)
      ;; Returns either the node or #f.
      ;; Loop takes D comparisons where D is the depth of the tree
      ;; rather than the traditional compare-low, compare-high which
      ;; takes on average 1.5(D-1) comparisons
      (define (loop this best)
	(if (empty? this) best
	    (let ((this (deref e this)))
	      (if (key<? k (node/k this))
		  (loop (node/l this) best)
		  (loop (node/r this) this)))))
      (let ((best (loop node #f)))
        (cond ((not best)               #f)
              ((key<? (node/k best) k)  #f)
              (else                     best))))

    (define (node/rank k node rank)
      (if (empty? node)             #f
	  (let ((node (deref e node)))
	    (cond ((key<? k (node/k node))  (node/rank k (node/l node) rank))
		  ((key>? k (node/k node))
		   (node/rank
		    k (node/r node)
		    (fx+ 1 (fx+ rank (node/size (deref e (node/l node)))))))
		  (else(fx+ rank (node/size (deref e (node/l node)))))))))

    (define (node/add node k v)
      (if (empty? node)
          (node/singleton k v)
          (with-n-node e node
            (lambda (e key val l r)
              (cond ((key<? k key)   (t-join e key val (node/add l k v) r))
                    ((key<? key k)   (t-join e key val l (node/add r k v)))
                    (else            (n-join e key v   l r)))))))

    (define (node/delete x node)
      (if (empty? node)
          empty
          (with-n-node e node
            (lambda (e key val l r)
              (cond ((key<? x key)   (t-join e key val (node/delete x l) r))
                    ((key<? key x)   (t-join e key val l (node/delete x r)))
                    (else            (node/concat2 e l r)))))))

    (define (node/concat tree1 tree2)
      (cond ((empty? tree1)  tree2)
            ((empty? tree2)  tree1)
            (else
             (let* ((tree2 (deref e tree2))
		    (min-node (deref e (node/min e tree2))))
               (node/concat3 (node/k min-node) (node/v min-node) tree1
                             (node/delmin e tree2))))))

    (define (node/concat3 k v l r)
      (cond ((empty? l)   (node/add r k v))
            ((empty? r)   (node/add l k v))
            (else
             (let ((l (deref e l))
		   (r (deref e r)))
	       (let ((n1  (node/size l))
		     (n2  (node/size r)))
		 (cond ((fx< (fx* wt-tree-ratio n1) n2)
			(with-n-node e r
				     (lambda (e k2 v2 l2 r2)
				       (t-join e k2 v2 (node/concat3 k v l l2) r2))))
		       ((fx< (fx* wt-tree-ratio n2) n1)
			(with-n-node e l
				     (lambda (e k1 v1 l1 r1)
				       (t-join e k1 v1 l1 (node/concat3 k v r1 r)))))
		       (else
			(n-join e k v l r))))))))

    (define (node/split-lt node x)
      (if (empty? node)  empty
	  (let ((node (deref e node)))
	    (cond ((key<? x (node/k node))
		   (node/split-lt (node/l node) x))
		  ((key<? (node/k node) x)
		   (node/concat3 (node/k node) (node/v node) (node/l node)
				 (node/split-lt (node/r node) x)))
		  (else (node/l node))))))

    (define (node/split-gt node x)
      (if (empty? node)  empty
	  (let ((node (deref e node)))
	    (cond ((key<? (node/k node) x)
		   (node/split-gt (node/r node) x))
		  ((key<? x (node/k node))
		   (node/concat3 (node/k node) (node/v node)
				 (node/split-gt (node/l node) x) (node/r node)))
		  (else (node/r node))))))

    (define (node/union tree1 tree2)
      (cond ((empty? tree1)  tree2)
            ((empty? tree2)  tree1)
            (else
             (with-n-node e tree2
               (lambda (e ak av l r)
                 (let ((l1  (node/split-lt tree1 ak))
                       (r1  (node/split-gt tree1 ak)))
                   (node/concat3 ak av (node/union l1 l) (node/union r1 r))))))))

    (define (node/difference tree1 tree2)
      (cond ((empty? tree1)   empty)
            ((empty? tree2)   tree1)
            (else
             (with-n-node e tree2
               (lambda (e ak av l r)
                 (let ((l1  (node/split-lt tree1 ak))
                       (r1  (node/split-gt tree1 ak)))
                   av
                   (node/concat (node/difference l1 l)
				(node/difference r1 r))))))))

    (define (node/intersection tree1 tree2)
      (cond ((empty? tree1)   empty)
            ((empty? tree2)   empty)
            (else
             (with-n-node e tree2
               (lambda (e ak av l r)
                 (let ((l1  (node/split-lt tree1 ak))
                       (r1  (node/split-gt tree1 ak)))
                   (if (node/find ak tree1)
                       (node/concat3 ak av (node/intersection l1 l)
                                     (node/intersection r1 r))
                       (node/concat (node/intersection l1 l)
				    (node/intersection r1 r)))))))))

    (define (node/subset? tree1 tree2)
      (or (empty? tree1)
          (and (not (empty? tree2))
	       (let ((tree1 (deref e tree1)) (tree2 (deref e tree2)))
		 (fx<= (node/size tree1) (node/size tree2)))
               (with-n-node e tree1
                 (lambda (e k v l r)
                   v
                   (cond ((key<? k (node/k tree2))
                          (and (node/subset? l (node/l tree2))
                               (node/find k tree2)
                               (node/subset? r tree2)))
                         ((key>? k (node/k tree2))
                          (and (node/subset? r (node/r tree2))
                               (node/find k tree2)
                               (node/subset? l tree2)))
                         (else
                          (and (node/subset? l (node/l tree2))
                               (node/subset? r (node/r tree2))))))))))


    ;;; Tree interface: stripping off or injecting the tree types

    (define (tree/map-add tree k v)
      (%make-wt-tree (tree/type tree)
                     (node/add (tree/root tree) k v)))

    (define (tree/insert! tree k v)
      (set-tree/root! tree (node/add (tree/root tree) k v)))

    (define (tree/delete tree k)
      (%make-wt-tree (tree/type tree)
                     (node/delete k (tree/root tree))))

    (define (tree/delete! tree k)
      (set-tree/root! tree (node/delete k (tree/root tree))))

    (define (tree/split-lt tree key)
      (%make-wt-tree (tree/type tree)
                     (node/split-lt (tree/root tree) key)))

    (define (tree/split-gt tree key)
      (%make-wt-tree (tree/type tree)
                     (node/split-gt (tree/root tree) key)))

    (define (tree/union tree1 tree2)
      (%make-wt-tree (tree/type tree1)
                     (node/union (tree/root tree1) (tree/root tree2))))

    (define (tree/intersection tree1 tree2)
      (%make-wt-tree (tree/type tree1)
                     (node/intersection (tree/root tree1) (tree/root tree2))))

    (define (tree/difference tree1 tree2)
      (%make-wt-tree (tree/type tree1)
                     (node/difference (tree/root tree1) (tree/root tree2))))

    (define (tree/subset? tree1 tree2)
      (node/subset? (tree/root tree1) (tree/root tree2)))

    (define (alist->tree alist)
      (define (loop alist node)
        (cond ((null? alist)  node)
              ((pair? alist)  (loop (cdr alist)
                                    (node/add node (caar alist) (cdar alist))))
              (else
               (wt:error 'wrong-type-argument alist "alist" 'alist->tree))))
      (%make-wt-tree my-type (loop alist empty)))

    (define (tree/get tree key default)
      (let ((node  (node/find key (tree/root tree))))
        (if node
            (node/v node)
            default)))

    (define (tree/rank tree key)  (node/rank key (tree/root tree) 0))

    (define (tree/member? key tree)
      (and (node/find key (tree/root tree))
           #t))

    (define my-type #f)

    (set! my-type
          (%make-tree-type
           key<?                        ;  key<?
           alist->tree                  ;  alist->tree
           tree/map-add                 ;  add
           tree/insert!                 ;  insert!
           tree/delete                  ;  delete
           tree/delete!                 ;  delete!
           tree/member?                 ;  member?
           tree/get                     ;  lookup
           tree/split-lt                ;  split-lt
           tree/split-gt                ;  split-gt
           tree/union                   ;  union
           tree/intersection            ;  intersection
           tree/difference              ;  difference
           tree/subset?                 ;  subset?
           tree/rank                    ;  rank
	   e				; environment
           ))

    my-type)

  (define (guarantee-tree tree procedure)
    (if (not (wt-tree? tree))
        (wt:error 'wrong-type-argument
		    tree "weight-balanced tree" procedure)))

  (define (guarantee-tree-type type procedure)
    (if (not (tree-type? type))
        (wt:error 'wrong-type-argument
		    type "weight-balanced tree type" procedure)))

  (define (guarantee-compatible-trees tree1 tree2 procedure)
    (guarantee-tree tree1 procedure)
    (guarantee-tree tree2 procedure)
    (if (not (eq? (tree/type tree1) (tree/type tree2)))
        (wt:error "The trees" tree1 'and tree2 'have 'incompatible 'types
		    (tree/type tree1) 'and (tree/type tree2))))

;;;______________________________________________________________________
;;;
;;;  Export interface
;;;
  (set! make-wt-tree-type local:make-wt-tree-type)

  (set! make-wt-tree
	(lambda (tree-type)
          (%make-wt-tree tree-type empty)))

  (set! singleton-wt-tree
        (lambda (type key value)
          (guarantee-tree-type type 'singleton-wt-tree)
          (%make-wt-tree type (node/singleton key value))))

  (set! alist->wt-tree
        (lambda (type alist)
          (guarantee-tree-type type 'alist->wt-tree)
          ((tree-type/alist->tree type) alist)))

  (set! wt-tree/empty?
        (lambda (tree)
          (guarantee-tree tree 'wt-tree/empty?)
          (empty? (tree/root tree))))

  (set! wt-tree/size
        (lambda (tree)
          (guarantee-tree tree 'wt-tree/size)
          (node/size (deref (tree-type/environment (tree/type tree)) (tree/root tree)))))

  (set! wt-tree/add
        (lambda (tree key datum)
          (guarantee-tree tree 'wt-tree/add)
          ((tree-type/add (tree/type tree)) tree key datum)))

  (set! wt-tree/delete
        (lambda (tree key)
          (guarantee-tree tree 'wt-tree/delete)
          ((tree-type/delete (tree/type tree)) tree key)))

  (set! wt-tree/add!
        (lambda (tree key datum)
          (guarantee-tree tree 'wt-tree/add!)
          ((tree-type/insert! (tree/type tree)) tree key datum)))

  (set! wt-tree/delete!
        (lambda (tree key)
          (guarantee-tree tree 'wt-tree/delete!)
          ((tree-type/delete! (tree/type tree)) tree key)))

  (set! wt-tree/member?
        (lambda (key tree)
          (guarantee-tree tree 'wt-tree/member?)
          ((tree-type/member? (tree/type tree)) key tree)))

  (set! wt-tree/lookup
        (lambda (tree key default)
          (guarantee-tree tree 'wt-tree/lookup)
          ((tree-type/lookup (tree/type tree)) tree key default)))

  (set! wt-tree/split<
        (lambda (tree key)
          (guarantee-tree tree 'wt-tree/split<)
          ((tree-type/split-lt (tree/type tree)) tree key)))

  (set! wt-tree/split>
        (lambda (tree key)
          (guarantee-tree tree 'wt-tree/split>)
          ((tree-type/split-gt (tree/type tree)) tree key)))

  (set! wt-tree/union
        (lambda (tree1 tree2)
          (guarantee-compatible-trees tree1 tree2 'wt-tree/union)
          ((tree-type/union (tree/type tree1)) tree1 tree2)))

  (set! wt-tree/intersection
        (lambda (tree1 tree2)
          (guarantee-compatible-trees tree1 tree2 'wt-tree/intersection)
          ((tree-type/intersection (tree/type tree1)) tree1 tree2)))

  (set! wt-tree/difference
        (lambda (tree1 tree2)
          (guarantee-compatible-trees tree1 tree2 'wt-tree/difference)
          ((tree-type/difference (tree/type tree1)) tree1 tree2)))

  (set! wt-tree/subset?
        (lambda (tree1 tree2)
          (guarantee-compatible-trees tree1 tree2 'wt-tree/subset?)
          ((tree-type/subset? (tree/type tree1)) tree1 tree2)))

  (set! wt-tree/set-equal?
        (lambda (tree1 tree2)
          (and (wt-tree/subset? tree1 tree2)
               (wt-tree/subset? tree2 tree1))))

  (set! wt-tree/fold
        (lambda (combiner-key-datum-result init tree)
          (guarantee-tree tree 'wt-tree/fold)
          (node/inorder-fold (tree-type/environment (tree/type tree))
			     combiner-key-datum-result
                             init
                             (tree/root tree))))

  (set! wt-tree/for-each
        (lambda (action-key-datum tree)
          (guarantee-tree tree 'wt-tree/for-each)
          (node/for-each (tree-type/environment (tree/type tree))
			 action-key-datum (tree/root tree))))

  (set! wt-tree/dump
        (lambda (tree . rest)
          (guarantee-tree tree 'wt-tree/dump)
          (apply node/dump (tree-type/environment (tree/type tree)) (tree/root tree) rest)))

  (set! wt-tree/restore
	(lambda (tree-type ref)
	  (%make-wt-tree tree-type (if ref (deref (tree-type/environment tree-type) ref) empty))))

  (set! wt-tree/index
        (lambda (tree index)
          (guarantee-tree tree 'wt-tree/index)
          (let ((node  (node/index (tree-type/environment (tree/type tree))
				   (tree/root tree) index)))
            (and node (node/k node)))))

  (set! wt-tree/index-datum
        (lambda (tree index)
          (guarantee-tree tree 'wt-tree/index-datum)
          (let ((node  (node/index (tree-type/environment (tree/type tree))
				   (tree/root tree) index)))
            (and node (node/v node)))))

  (set! wt-tree/index-pair
        (lambda (tree index)
          (guarantee-tree tree 'wt-tree/index-pair)
          (let ((node  (node/index (tree-type/environment (tree/type tree))
				   (tree/root tree) index)))
            (and node (cons (node/k node) (node/v node))))))

  (set! wt-tree/rank
        (lambda (tree key)
          (guarantee-tree tree 'wt-tree/rank)
          ((tree-type/rank (tree/type tree)) tree key)))

  (set! wt-tree/max
        (lambda (tree)
          (guarantee-tree tree 'wt-tree/max)
          (node/k (node/max (tree-type/environment (tree/type tree)) (tree/root tree)))))

  (set! wt-tree/min
        (lambda (tree)
          (guarantee-tree tree 'wt-tree/min)
          (node/k (node/min (tree-type/environment (tree/type tree)) (tree/root tree)))))

  (set! wt-tree/min-datum
        (lambda (tree)
          (guarantee-tree tree 'wt-tree/min-datum)
          (node/v (node/min (tree-type/environment (tree/type tree)) (tree/root tree)))))

  (set! wt-tree/min-pair
        (lambda (tree)
          (guarantee-tree tree 'wt-tree/min-pair)
          (let ((node  (node/min (tree-type/environment (tree/type tree)) (tree/root tree))))
            (cons (node/k node) (node/v node)))))

  (set! wt-tree/delete-min
        (lambda (tree)
          (guarantee-tree tree 'wt-tree/delete-min)
          (%make-wt-tree (tree/type tree)
                         (node/delmin (tree-type/environment (tree/type tree))
				      (tree/root tree)))))

  (set! wt-tree/delete-min!
        (lambda (tree)
          (guarantee-tree tree 'wt-tree/delete-min!)
          (set-tree/root! tree (node/delmin (tree-type/environment (tree/type tree))
					    (tree/root tree)))))

  ;; < is a lexpr. Many compilers can open-code < so the lambda is faster
  ;; than passing <.
  (set! number-wt-type (local:make-wt-tree-type  (lambda (u v) (< u v))))
  (set! string-wt-type (local:make-wt-tree-type  string<?))

  ;; TBD
  (set! wt-marshall
	(lambda (rd wr)
	  (make-wt-environment
	   (lambda (%make-node id)
	     (if (or (%node? id) (empty? id)) id (rd %make-node id)))
	   wr)))

  #t)

) ;; module wttree-static