OS/2 Shareware BBS: 10 Tools/10-Tools.zip/mitsch75.zip/scheme-7_5_17-src.zip/scheme-7.5.17/src/runtime/wttree.scm

Text File | 1999-01-02 | 22KB | 694 lines

#| -*-Scheme-*-

$Id: wttree.scm,v 1.10 1999/01/02 06:19:10 cph Exp $

Copyright (c) 1993-1999 Massachusetts Institute of Technology

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.


Copyright (c) 1993-1994 Stephen Adams

This program was written by Stephen Adams, based on the following
reference:

  Stephen Adams, Implemeting Sets Efficiently in a Functional
     Language, CSTR 92-10, Department of Electronics and Computer
     Science, University of Southampton, 1992
|#

;;;; Weight-balanced tree (wt-tree) Operations
;;; package: (runtime wt-tree)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(declare (usual-integrations))


;;;  A tree type is a collection of those procedures that depend on the ordering
;;;  relation.

(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)
  ;;;min        ; ?  also delmin, max, delmax, delmin!, delmax!
  (split-lt    #F read-only true)
  (split-gt    #F read-only true)
  (union       #F read-only true)
  (union-merge #F read-only true)
  (intersection #F read-only true)
  (difference  #F read-only true)
  (subset?     #F read-only true)
  (rank        #F read-only true)
)

;;;  Tree representation
;;;
;;;  WT-TREE is a wrapper for trees of nodes
;;;
(define-structure
  (wt-tree
   (conc-name tree/)
   (constructor %make-wt-tree))
  (type  #F read-only true)
  (root  #F read-only false))

;;;  Nodes are the thing from which the real trees are built.

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

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

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

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

(define-integrable (with-n-node node receiver)
  (receiver (node/k node) (node/v node) (node/l node) (node/r node)))


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

(define (n-join k v l r)
  (make-node k v l r (fix:+ 1 (fix:+ (node/size l) (node/size r)))))
(declare (integrate-operator n-join))

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

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

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

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

(define-integrable wt-tree-ratio 5)

(define (t-join k v l r)
  (define (simple-join) (n-join k v l r))
  (let ((l.n  (node/size l))
    (r.n  (node/size r)))
    (cond ((fix:< (fix:+ l.n r.n) 2)   (simple-join))
      ((fix:> r.n (fix:* wt-tree-ratio l.n))
       ;; right is too big
       (let ((r.l.n  (node/size (node/l r)))
         (r.r.n  (node/size (node/r r))))
         (if (fix:< r.l.n r.r.n)
         (single-l k v l r)
         (double-l k v l r))))
      ((fix:> l.n (fix:* wt-tree-ratio r.n))
       ;; left is too big
       (let ((l.l.n  (node/size (node/l l)))
         (l.r.n  (node/size (node/r l))))
         (if (fix:< l.r.n l.l.n)
         (single-r k v l r)
         (double-r k v l r))))
      (else
       (simple-join)))))

;;;
;;;  Node tree Procedures that are independent of key<?
;;;

(define (node/min node)
  (cond  ((empty? node)           (error:empty 'min))
     ((empty? (node/l node))  node)
     (else                   (node/min (node/l node)))))

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

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

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

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

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

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

(define (error:empty owner)
  ((access error system-global-environment)
   "Operation requires non-empty tree:" owner))


(define (make-wt-tree-type key<?)

  (declare (integrate key<?))

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

  (define (node/find k node)
    ;; returns either the node or #f.
    ;; Loop takes D comparisons (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)
      (cond ((empty? this)  best)
        ((key<? k (node/k this))   (loop (node/l this) best))
        (else (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)
    (cond ((empty? node)             #f)
      ((key<? k (node/k node))  (node/rank k (node/l node) rank))
      ((key>? k (node/k node))
       (node/rank k (node/r node)
                (fix:+ 1 (fix:+ rank (node/size (node/l node))))))
      (else                     (fix:+ rank (node/size (node/l node))))))

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

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

  (define (node/concat tree1 tree2)
    (cond ((empty? tree1)  tree2)
      ((empty? tree2)  tree1)
      (else
       (let ((min-node (node/min tree2)))
         (node/concat3 (node/k min-node) (node/v min-node) tree1
               (node/delmin 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 ((n1  (node/size l))
         (n2  (node/size r)))
         (cond ((fix:< (fix:* wt-tree-ratio n1) n2)
            (with-n-node r
                 (lambda (k2 v2 l2 r2)
                   (t-join k2 v2 (node/concat3 k v l l2) r2))))
           ((fix:< (fix:* wt-tree-ratio n2) n1)
            (with-n-node l
                 (lambda (k1 v1 l1 r1)
                   (t-join k1 v1 l1 (node/concat3 k v r1 r)))))
           (else
            (n-join k v l r)))))))

  (define (node/split-lt node x)
    (cond ((empty? node)  empty)
      ((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)
    (cond ((empty? node)  empty)
      ((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 tree2
          (lambda (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/union-merge tree1 tree2 merge)
    (cond ((empty? tree1)  tree2)
      ((empty? tree2)  tree1)
      (else
       (with-n-node tree2
         (lambda (ak av l r)
           (let* ((node1  (node/find ak tree1))
              (l1     (node/split-lt tree1 ak))
              (r1     (node/split-gt tree1 ak))
              (value  (if node1
                  (merge ak av (node/v node1))
                  av)))
         (node/concat3 ak value
                   (node/union-merge l1 l merge)
                   (node/union-merge r1 r merge))))))))

  (define (node/difference tree1 tree2)
    (cond ((empty? tree1)   empty)
      ((empty? tree2)   tree1)
      (else
       (with-n-node tree2
         (lambda (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 tree2
         (lambda (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 (fix:<= (node/size tree1) (node/size tree2))
         (with-n-node tree1
               (lambda (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/set-add tree k)  (tree/map-add tree k #f))

  (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/union-merge tree1 tree2 merge)
    (%make-wt-tree (tree/type tree1)
           (node/union-merge (tree/root tree1) (tree/root tree2)
                     merge)))

  (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
         (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
    (%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/union-merge     ;  union-merge
     tree/intersection    ;  intersection
     tree/difference      ;  difference
     tree/subset?         ;  subset?
     tree/rank            ;  rank
     ))

  my-type)



;;;
;;;
;;;

(define (guarantee-tree/report tree procedure)
  (error:wrong-type-argument tree "weight-balanced tree" procedure))

(define-integrable (guarantee-tree tree procedure)
  (if (not (wt-tree? tree))
      (guarantee-tree/report tree procedure)))

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

(define-integrable (guarantee-compatible-trees/report tree1 tree2 procedure)
  (guarantee-tree tree1 procedure)
  (guarantee-tree tree2 procedure)
  (error "The trees" tree1 'and tree2 'have 'incompatible 'types
     (tree/type tree1) 'and (tree/type tree2)))

(define-integrable (guarantee-compatible-trees tree1 tree2 procedure)
  (if (or (not (wt-tree? tree1))
      (not (wt-tree? tree2))
      (not (eq? (tree/type tree1) (tree/type tree2))))
      (guarantee-compatible-trees/report tree1 tree2 procedure)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Exported interface
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define (make-wt-tree tree-type)
  (%make-wt-tree tree-type empty))

(define (singleton-wt-tree type key value)
  (guarantee-tree-type type 'singleton-wt-tree)
  (%make-wt-tree type (node/singleton key value)))

(define (alist->wt-tree type alist)
  (guarantee-tree-type type 'alist->wt-tree)
  ((tree-type/alist->tree type) alist))

(define (wt-tree/empty? tree)
  (guarantee-tree tree 'wt-tree/empty?)
  (empty? (tree/root tree)))

(define (wt-tree/size tree)
  (guarantee-tree tree 'wt-tree/size)
  (node/size (tree/root tree)))

(define (wt-tree/add tree key datum)
  (guarantee-tree tree 'wt-tree/add)
  ((tree-type/add (tree/type tree)) tree key datum))

(define (wt-tree/delete tree key)
  (guarantee-tree tree 'wt-tree/delete)
  ((tree-type/delete (tree/type tree)) tree key))

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

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

(define (wt-tree/member? key tree)
  (guarantee-tree tree 'wt-tree/member?)
  ((tree-type/member? (tree/type tree)) key tree))

(define (wt-tree/lookup tree key default)
  (guarantee-tree tree 'wt-tree/lookup)
  ((tree-type/lookup (tree/type tree)) tree key default))

(define (wt-tree/split< tree key)
  (guarantee-tree tree 'wt-tree/split<)
  ((tree-type/split-lt (tree/type tree)) tree key))

(define (wt-tree/split> tree key)
  (guarantee-tree tree 'wt-tree/split>)
  ((tree-type/split-gt (tree/type tree)) tree key))

(define (wt-tree/union tree1 tree2)
  (guarantee-compatible-trees tree1 tree2 'wt-tree/union)
  ((tree-type/union (tree/type tree1)) tree1 tree2))

(define (wt-tree/union-merge tree1 tree2 merge)
  (guarantee-compatible-trees tree1 tree2 'wt-tree/union-merge)
  ((tree-type/union-merge (tree/type tree1)) tree1 tree2 merge))

(define (wt-tree/intersection tree1 tree2)
  (guarantee-compatible-trees tree1 tree2 'wt-tree/intersection)
  ((tree-type/intersection (tree/type tree1)) tree1 tree2))

(define (wt-tree/difference tree1 tree2)
  (guarantee-compatible-trees tree1 tree2 'wt-tree/difference)
  ((tree-type/difference (tree/type tree1)) tree1 tree2))

(define (wt-tree/subset? tree1 tree2)
  (guarantee-compatible-trees tree1 tree2 'wt-tree/subset?)
  ((tree-type/subset? (tree/type tree1)) tree1 tree2))

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

(define (wt-tree/fold combiner-key-datum-result init tree)
  (guarantee-tree tree 'wt-tree/fold)
  (node/inorder-fold combiner-key-datum-result init (tree/root tree)))

(define (wt-tree/for-each action-key-datum tree)
  (guarantee-tree tree 'wt-tree/for-each)
  (node/for-each action-key-datum (tree/root tree)))

(define (wt-tree/index tree index)
  (guarantee-tree tree 'wt-tree/index)
  (let ((node  (node/index (tree/root tree) index)))
    (and node (node/k node))))

(define (wt-tree/index-datum tree index)
  (guarantee-tree tree 'wt-tree/index-datum)
  (let ((node  (node/index (tree/root tree) index)))
    (and node (node/v node))))

(define (wt-tree/index-pair tree index)
  (guarantee-tree tree 'wt-tree/index-pair)
  (let ((node  (node/index (tree/root tree) index)))
    (and node (cons (node/k node) (node/v node)))))

(define (wt-tree/rank tree key)
  (guarantee-tree tree 'wt-tree/rank)
  ((tree-type/rank (tree/type tree)) tree key))

(define (wt-tree/min tree)
  (guarantee-tree tree 'wt-tree/min)
  (node/k (node/min (tree/root tree))))

(define (wt-tree/min-datum tree)
  (guarantee-tree tree 'wt-tree/min-datum)
  (node/v (node/min (tree/root tree))))

(define (wt-tree/min-pair tree)
  (guarantee-tree tree 'wt-tree/min-pair)
  (let ((node  (node/min (tree/root tree))))
    (cons (node/k node) (node/v node))))

(define (wt-tree/delete-min tree)
  (guarantee-tree tree 'wt-tree/delete-min)
  (%make-wt-tree (tree/type tree) (node/delmin (tree/root tree))))

(define (wt-tree/delete-min! tree)
  (guarantee-tree tree 'wt-tree/delete-min!)
  (set-tree/root! tree (node/delmin (tree/root tree))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;

(define ttype (make-wt-tree-type <))

(define number-wt-type
  ((lambda()
     (declare (integrate-operator make-wt-tree-type))
     (make-wt-tree-type  (lambda (x y) (< x y))))))

(define string-wt-type
  ((lambda()
     (declare (integrate-operator make-wt-tree-type))
     (make-wt-tree-type  string<?))))

;;;
;;;
;;;

#|

Test code, using maps from digit strings to the numbers they represent.

(load-option 'wt-tree)

(define (make-map lo hi step)
  (let loop ((i lo) (map (make-wt-tree string-wt-type)))
    (if (> i hi)
    map
    (loop (+ i step) (wt-tree/add map (number->string i) i)))))

(define t1 (make-map 0 99 2))   ; 0,2,4,...,98
(define t2 (make-map 1 100 2))  ; 1,3,5,...,99
(define t3 (make-map 0 100 3))  ; 0,3,6,...,99

(define (wt-tree->alist t)
  (wt-tree/fold (lambda (k d r) (cons (cons k d) r)) '() t))

(wt-tree->alist t3);
  => (("0" . 0) ("12" . 12) ("15" . 15) ("18" . 18) ("21" . 21) ("24" . 24) ("27" . 27) ("3" . 3) ("30" . 30) ("33" . 33) ("36" . 36) ("39" . 39) ("42" . 42) ("45" . 45) ("48" . 48) ("51" . 51) ("54" . 54) ("57" . 57) ("6" . 6) ("60" . 60) ("63" . 63) ("66" . 66) ("69" . 69) ("72" . 72) ("75" . 75) ("78" . 78) ("81" . 81) ("84" . 84) ("87" . 87) ("9" . 9) ("90" . 90) ("93" . 93) ("96" . 96) ("99" . 99))

(define (try-all operation trees)
  (map (lambda (t1)
     (map (lambda (t2)
        (operation t1 t2))
          trees))
       trees))

(try-all (lambda (t1 t2) (wt-tree/size (wt-tree/union t1 t2)))
     (list t1 t2 t3))
  => ((50 100 67) (100 50 67) (67 67 34))

(try-all (lambda (t1 t2) (wt-tree/size (wt-tree/difference t1 t2)))
     (list t1 t2 t3))
  => ((0 50 33) (50 0 33) (17 17 0))

(try-all (lambda (t1 t2) (wt-tree/size (wt-tree/intersection t1 t2)))
     (list t1 t2 t3))
  => ((50 0 17) (0 50 17) (17 17 34))

(try-all (lambda (t1 t2) (wt-tree/set-equal? (wt-tree/difference t1 t2)
                         (wt-tree/difference t2 t1)))
     (list t1 t2 t3))
  => ((#t #f #f) (#f #t #f) (#f #f #t))

|#