

 This page uses content from Wikipedia. The original article was at AVL tree. The list of authors can be seen in the page history. As with Rosetta Code, the text of Wikipedia is available under the GNU FDL. (See links for details on variance)



In computer science, an AVL tree is a self-balancing binary search tree. In an AVL tree, the heights of the two child subtrees of any node differ by at most one; at no time do they differ by more than one because rebalancing is done ensure this is the case. Lookup, insertion, and deletion all take O(log n) time in both the average and worst cases, where n is the number of nodes in the tree prior to the operation. Insertions and deletions may require the tree to be rebalanced by one or more tree rotations. Note the tree of nodes comprise a set, so duplicate node keys are not allowed.

AVL trees are often compared with red-black trees because they support the same set of operations and because red-black trees also take O(log n) time for the basic operations. Because AVL trees are more rigidly balanced, they are faster than red-black trees for lookup-intensive applications. Similar to red-black trees, AVL trees are height-balanced, but in general not weight-balanced nor μ-balanced; that is, sibling nodes can have hugely differing numbers of descendants.



Task

Implement an AVL tree in the language of choice, and provide at least basic operations.




(cond-expand
  (r7rs)
  (chicken (import r7rs)))
 
(define-library (avl-trees)
 
  ;;
  ;; This library implements ‘persistent’ (that is, ‘immutable’) AVL
  ;; trees for R7RS Scheme.
  ;;
  ;; Included are generators of the key-data pairs in a tree. Because
  ;; the trees are persistent (‘immutable’), these generators are safe
  ;; from alterations of the tree.
  ;;
  ;; References:
  ;;
  ;;   * Niklaus Wirth, 1976. Algorithms + Data Structures =
  ;;     Programs. Prentice-Hall, Englewood Cliffs, New Jersey.
  ;;
  ;;   * Niklaus Wirth, 2004. Algorithms and Data Structures. Updated
  ;;     by Fyodor Tkachov, 2014.
  ;;
  ;; Note that the references do not discuss persistent
  ;; implementations. It seems worthwhile to compare the methods of
  ;; implementation.
  ;;
 
  (export avl)
  (export alist->avl)
  (export avl->alist)
  (export avl?)
  (export avl-empty?)
  (export avl-size)
  (export avl-insert)
  (export avl-delete)
  (export avl-delete-values)
  (export avl-has-key?)
  (export avl-search)
  (export avl-search-values)
  (export avl-make-generator)
  (export avl-pretty-print)
  (export avl-check-avl-condition)
  (export avl-check-usage)
 
  (import (scheme base))
  (import (scheme case-lambda))
  (import (scheme process-context))
  (import (scheme write))
 
  (cond-expand
    (chicken
     (import (only (chicken base) define-record-printer))
     (import (only (chicken format) format))) ; For debugging.
    (else))
 
  (begin
 
    ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    ;;
    ;; Tools for making generators. These use call/cc and so might be
    ;; inefficient in your Scheme. I am using CHICKEN, in which
    ;; call/cc is not so inefficient.
    ;;
    ;; Often I have made &fail a unique object rather than #f, but in
    ;; this case #f will suffice.
    ;;
 
    (define &fail #f)
 
    (define *suspend*
      (make-parameter (lambda (x) x)))
 
    (define (suspend v)
      ((*suspend*) v))
 
    (define (fail-forever)
      (let loop ()
        (suspend &fail)
        (loop)))
 
    (define (make-generator-procedure thunk)
      ;; Make a suspendable procedure that takes no arguments. The
      ;; result is a simple generator of values. (This can be
      ;; elaborated upon for generators to take values on resumption,
      ;; in the manner of Icon co-expressions.)
      (define (next-run return)
        (define (my-suspend v)
          (set! return (call/cc (lambda (resumption-point)
                                  (set! next-run resumption-point)
                                  (return v)))))
        (parameterize ((*suspend* my-suspend))
          (suspend (thunk))
          (fail-forever)))
      (lambda () (call/cc next-run)))
 
    ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 
    (define-syntax avl-check-usage
      (syntax-rules ()
        ((_ pred msg)
         (or pred (usage-error msg)))))
 
    ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 
    (define-record-type <avl>
      (%avl key data bal left right)
      avl?
      (key %key)
      (data %data)
      (bal %bal)
      (left %left)
      (right %right))
 
    (cond-expand
      (chicken (define-record-printer (<avl> rt out)
                 (display "#<avl " out)
                 (display (%key rt) out)
                 (display " " out)
                 (display (%data rt) out)
                 (display " " out)
                 (display (%bal rt) out)
                 (display " " out)
                 (display (%left rt) out)
                 (display " " out)
                 (display (%right rt) out)
                 (display ">" out)))
      (else))
 
    ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 
    (define avl
      (case-lambda
        (() (%avl #f #f #f #f #f))
        ((pred<? . args) (alist->avl pred<? args))))
 
    (define (avl-empty? tree)
      (avl-check-usage
       (avl? tree)
       "avl-empty? expects an AVL tree as argument")
      (not (%bal tree)))
 
    (define (avl-size tree)
      (define (traverse p sz)
        (if (not p)
            sz
            (traverse (%left p) (traverse (%right p) (+ sz 1)))))
      (if (avl-empty? tree)
          0
          (traverse tree 0)))
 
    (define (avl-has-key? pred<? tree key)
      (define (search p)
        (and p
             (let ((k (%key p)))
               (cond ((pred<? key k) (search (%left p)))
                     ((pred<? k key) (search (%right p)))
                     (else #t)))))
      (avl-check-usage
       (procedure? pred<?)
       "avl-has-key? expects a procedure as first argument")
      (and (not (avl-empty? tree))
           (search tree)))
 
    (define (avl-search pred<? tree key)
      ;; Return the data matching a key, or #f if the key is not
      ;; found. (Note that the data matching the key might be #f.)
      (define (search p)
        (and p
             (let ((k (%key p)))
               (cond ((pred<? key k) (search (%left p)))
                     ((pred<? k key) (search (%right p)))
                     (else (%data p))))))
      (avl-check-usage
       (procedure? pred<?)
       "avl-search expects a procedure as first argument")
      (and (not (avl-empty? tree))
           (search tree)))
 
    (define (avl-search-values pred<? tree key)
      ;; Return two values: the data matching the key, or #f is the
      ;; key is not found; and a second value that is either #f or #t,
      ;; depending on whether the key is found.
      (define (search p)
        (if (not p)
            (values #f #f)
            (let ((k (%key p)))
              (cond ((pred<? key k) (search (%left p)))
                    ((pred<? k key) (search (%right p)))
                    (else (values (%data p) #t))))))
      (avl-check-usage
       (procedure? pred<?)
       "avl-search-values expects a procedure as first argument")
      (if (avl-empty? tree)
          (values #f #f)
          (search tree)))
 
    (define (alist->avl pred<? alst)
      ;; Go from association list to AVL tree.
      (avl-check-usage
       (procedure? pred<?)
       "alist->avl expects a procedure as first argument")
      (let loop ((tree (avl))
                 (lst alst))
        (if (null? lst)
            tree
            (let ((head (car lst)))
              (loop (avl-insert pred<? tree (car head) (cdr head))
                    (cdr lst))))))
 
    (define (avl->alist tree)
      ;; Go from AVL tree to association list. The output will be in
      ;; order.
      (define (traverse p lst)
        ;; Reverse in-order traversal of the tree, to produce an
        ;; in-order cons-list.
        (if (not p)
            lst
            (traverse (%left p) (cons (cons (%key p) (%data p))
                                      (traverse (%right p) lst)))))
      (if (avl-empty? tree)
          '()
          (traverse tree '())))
 
    (define (avl-insert pred<? tree key data)
 
      (define (search p fix-balance?)
        (cond
         ((not p)
          ;; The key was not found. Make a new node and set
          ;; fix-balance?
          (values (%avl key data 0 #f #f) #t))
 
         ((pred<? key (%key p))
          ;; Continue searching.
          (let-values (((p1 fix-balance?)
                        (search (%left p) fix-balance?)))
            (cond
             ((not fix-balance?)
              (let ((p^ (%avl (%key p) (%data p) (%bal p)
                              p1 (%right p))))
                (values p^ #f)))
             (else
              ;; A new node has been inserted on the left side.
              (case (%bal p)
                ((1)
                 (let ((p^ (%avl (%key p) (%data p) 0
                                 p1 (%right p))))
                   (values p^ #f)))
                ((0)
                 (let ((p^ (%avl (%key p) (%data p) -1
                                 p1 (%right p))))
                   (values p^ fix-balance?)))
                ((-1)
                 ;; Rebalance.
                 (case (%bal p1)
                   ((-1)
                    ;; A single LL rotation.
                    (let* ((p^ (%avl (%key p) (%data p) 0
                                     (%right p1) (%right p)))
                           (p1^ (%avl (%key p1) (%data p1) 0
                                      (%left p1) p^)))
                      (values p1^ #f)))
                   ((0 1)
                    ;; A double LR rotation.
                    (let* ((p2 (%right p1))
                           (bal2 (%bal p2))
                           (p^ (%avl (%key p) (%data p)
                                     (- (min bal2 0))
                                     (%right p2) (%right p)))
                           (p1^ (%avl (%key p1) (%data p1)
                                      (- (max bal2 0))
                                      (%left p1) (%left p2)))
                           (p2^ (%avl (%key p2) (%data p2) 0
                                      p1^ p^)))
                      (values p2^ #f)))
                   (else (internal-error))))
                (else (internal-error)))))))
 
         ((pred<? (%key p) key)
          ;; Continue searching.
          (let-values (((p1 fix-balance?)
                        (search (%right p) fix-balance?)))
            (cond
             ((not fix-balance?)
              (let ((p^ (%avl (%key p) (%data p) (%bal p)
                              (%left p) p1)))
                (values p^ #f)))
             (else
              ;; A new node has been inserted on the right side.
              (case (%bal p)
                ((-1)
                 (let ((p^ (%avl (%key p) (%data p) 0
                                 (%left p) p1)))
                   (values p^ #f)))
                ((0)
                 (let ((p^ (%avl (%key p) (%data p) 1
                                 (%left p) p1)))
                   (values p^ fix-balance?)))
                ((1)
                 ;; Rebalance.
                 (case (%bal p1)
                   ((1)
                    ;; A single RR rotation.
                    (let* ((p^ (%avl (%key p) (%data p) 0
                                     (%left p) (%left p1)))
                           (p1^ (%avl (%key p1) (%data p1) 0
                                      p^ (%right p1))))
                      (values p1^ #f)))
                   ((-1 0)
                    ;; A double RL rotation.
                    (let* ((p2 (%left p1))
                           (bal2 (%bal p2))
                           (p^ (%avl (%key p) (%data p)
                                     (- (max bal2 0))
                                     (%left p) (%left p2)))
                           (p1^ (%avl (%key p1) (%data p1)
                                      (- (min bal2 0))
                                      (%right p2) (%right p1)))
                           (p2^ (%avl (%key p2) (%data p2) 0
                                      p^ p1^)))
                      (values p2^ #f)))
                   (else (internal-error))))
                (else (internal-error)))))))
 
         (else
          ;; The key was found; p is an existing node.
          (values (%avl key data (%bal p) (%left p) (%right p))
                  #f))))
 
      (avl-check-usage
       (procedure? pred<?)
       "avl-insert expects a procedure as first argument")
      (if (avl-empty? tree)
          (%avl key data 0 #f #f)
          (let-values (((p fix-balance?) (search tree #f)))
            p)))
 
    (define (avl-delete pred<? tree key)
      ;; If one is not interested in whether the key was in the tree,
      ;; then throw away that information.
      (let-values (((tree had-key?)
                    (avl-delete-values pred<? tree key)))
        tree))
 
    (define (balance-for-shrunken-left p)
      ;; Returns two values: a new p and a new fix-balance?
      (case (%bal p)
        ((-1) (values (%avl (%key p) (%data p) 0
                            (%left p) (%right p))
                      #t))
        ((0) (values (%avl (%key p) (%data p) 1
                           (%left p) (%right p))
                     #f))
        ((1)
         ;; Rebalance.
         (let* ((p1 (%right p))
                (bal1 (%bal p1)))
           (case bal1
             ((0)
              ;; A single RR rotation.
              (let* ((p^ (%avl (%key p) (%data p) 1
                               (%left p) (%left p1)))
                     (p1^ (%avl (%key p1) (%data p1) -1
                                p^ (%right p1))))
                (values p1^ #f)))
             ((1)
              ;; A single RR rotation.
              (let* ((p^ (%avl (%key p) (%data p) 0
                               (%left p) (%left p1)))
                     (p1^ (%avl (%key p1) (%data p1) 0
                                p^ (%right p1))))
                (values p1^ #t)))
             ((-1)
              ;; A double RL rotation.
              (let* ((p2 (%left p1))
                     (bal2 (%bal p2))
                     (p^ (%avl (%key p) (%data p) (- (max bal2 0))
                               (%left p) (%left p2)))
                     (p1^ (%avl (%key p1) (%data p1) (- (min bal2 0))
                                (%right p2) (%right p1)))
                     (p2^ (%avl (%key p2) (%data p2) 0 p^ p1^)))
                (values p2^ #t)))
             (else (internal-error)))))
        (else (internal-error))))
 
    (define (balance-for-shrunken-right p)
      ;; Returns two values: a new p and a new fix-balance?
      (case (%bal p)
        ((1) (values (%avl (%key p) (%data p) 0
                           (%left p) (%right p))
                     #t))
        ((0) (values (%avl (%key p) (%data p) -1
                           (%left p) (%right p))
                     #f))
        ((-1)
         ;; Rebalance.
         (let* ((p1 (%left p))
                (bal1 (%bal p1)))
           (case bal1
             ((0)
              ;; A single LL rotation.
              (let* ((p^ (%avl (%key p) (%data p) -1
                               (%right p1) (%right p)))
                     (p1^ (%avl (%key p1) (%data p1) 1
                                (%left p1) p^)))
                (values p1^ #f)))
             ((-1)
              ;; A single LL rotation.
              (let* ((p^ (%avl (%key p) (%data p) 0
                               (%right p1) (%right p)))
                     (p1^ (%avl (%key p1) (%data p1) 0
                                (%left p1) p^)))
                (values p1^ #t)))
             ((1)
              ;; A double LR rotation.
              (let* ((p2 (%right p1))
                     (bal2 (%bal p2))
                     (p^ (%avl (%key p) (%data p) (- (min bal2 0))
                               (%right p2) (%right p)))
                     (p1^ (%avl (%key p1) (%data p1) (- (max bal2 0))
                                (%left p1) (%left p2)))
                     (p2^ (%avl (%key p2) (%data p2) 0 p1^ p^)))
                (values p2^ #t)))
             (else (internal-error)))))
        (else (internal-error))))
 
    (define (avl-delete-values pred<? tree key)
 
      (define-syntax balance-L
        (syntax-rules ()
          ((_ p fix-balance?)
           (if fix-balance?
               (balance-for-shrunken-left p)
               (values p #f)))))
 
      (define-syntax balance-R
        (syntax-rules ()
          ((_ p fix-balance?)
           (if fix-balance?
               (balance-for-shrunken-right p)
               (values p #f)))))
 
      (define (del r fix-balance?)
        ;; Returns a new r, a new fix-balance?, and key and data to be
        ;; ‘moved up the tree’.
        (if (%right r)
            (let*-values
                (((q fix-balance? key^ data^)
                  (del (%right r) fix-balance?))
                 ((r fix-balance?)
                  (balance-R (%avl (%key r) (%data r) (%bal r)
                                   (%left r) q)
                             fix-balance?)))
              (values r fix-balance? key^ data^))
            (values (%left r) #t (%key r) (%data r))))
 
      (define (search p fix-balance?)
        ;; Return three values: a new p, a new fix-balance, and
        ;; whether the key was found.
        (cond
         ((not p) (values #f #f #f))
         ((pred<? key (%key p))
          ;; Recursive search down the left branch.
          (let*-values
              (((q fix-balance? found?)
                (search (%left p) fix-balance?))
               ((p fix-balance?)
                (balance-L (%avl (%key p) (%data p) (%bal p)
                                 q (%right p))
                           fix-balance?)))
            (values p fix-balance? found?)))
         ((pred<? (%key p) key)
          ;; Recursive search down the right branch.
          (let*-values
              (((q fix-balance? found?)
                (search (%right p) fix-balance?))
               ((p fix-balance?)
                (balance-R (%avl (%key p) (%data p) (%bal p)
                                 (%left p) q)
                           fix-balance?)))
            (values p fix-balance? found?)))
         ((not (%right p))
          ;; Delete p, replace it with its left branch, then
          ;; rebalance.
          (values (%left p) #t #t))
         ((not (%left p))
          ;; Delete p, replace it with its right branch, then
          ;; rebalance.
          (values (%right p) #t #t))
         (else
          ;; Delete p, but it has both left and right branches,
          ;; and therefore may have complicated branch structure.
          (let*-values
              (((q fix-balance? key^ data^)
                (del (%left p) fix-balance?))
               ((p fix-balance?)
                (balance-L (%avl key^ data^ (%bal p) q (%right p))
                           fix-balance?)))
            (values p fix-balance? #t)))))
 
      (avl-check-usage
       (procedure? pred<?)
       "avl-delete-values expects a procedure as first argument")
      (if (avl-empty? tree)
          (values tree #f)
          (let-values (((tree fix-balance? found?)
                        (search tree #f)))
            (if found?
                (values (or tree (avl)) #t)
                (values tree #f)))))
 
    (define avl-make-generator
      (case-lambda
        ((tree) (avl-make-generator tree 1))
        ((tree direction)
         (if (negative? direction)
             (make-generator-procedure
              (lambda ()
                (define (traverse p)
                  (unless (or (not p) (avl-empty? p))
                    (traverse (%right p))
                    (suspend (cons (%key p) (%data p)))
                    (traverse (%left p)))
                  &fail)
                (traverse tree)))
             (make-generator-procedure
              (lambda ()
                (define (traverse p)
                  (unless (or (not p) (avl-empty? p))
                    (traverse (%left p))
                    (suspend (cons (%key p) (%data p)))
                    (traverse (%right p)))
                  &fail)
                (traverse tree)))))))
 
    (define avl-pretty-print
      (case-lambda
        ((tree)
         (avl-pretty-print tree (current-output-port)))
        ((tree port)
         (avl-pretty-print tree port
                           (lambda (port key data)
                             (display "(" port)
                             (write key port)
                             (display ", " port)
                             (write data port)
                             (display ")" port))))
        ((tree port key-data-printer)
         ;; In-order traversal, so the printing is done in
         ;; order. Reflect the display diagonally to get the more
         ;; usual orientation of left-to-right, top-to-bottom.
         (define (pad depth)
           (unless (zero? depth)
             (display "  " port)
             (pad (- depth 1))))
         (define (traverse p depth)
           (when p
             (traverse (%left p) (+ depth 1))
             (pad depth)
             (key-data-printer port (%key p) (%data p))
             (display "\t\tdepth = " port)
             (display depth port)
             (display " bal = " port)
             (display (%bal p) port)
             (display "\n" port)
             (traverse (%right p) (+ depth 1))))
         (unless (avl-empty? tree)
           (traverse (%left tree) 1)
           (key-data-printer port (%key tree) (%data tree))
           (display "\t\tdepth = 0  bal = " port)
           (display (%bal tree) port)
           (display "\n" port)
           (traverse (%right tree) 1)))))
 
    (define (avl-check-avl-condition tree)
      ;; Check that the AVL condition is satisfied.
      (define (check-heights height-L height-R)
        (when (<= 2 (abs (- height-L height-R)))
          (display "*** AVL condition violated ***"
                   (current-error-port))
          (internal-error)))
      (define (get-heights p)
        (if (not p)
            (values 0 0)
            (let-values (((height-LL height-LR)
                          (get-heights (%left p)))
                         ((height-RL height-RR)
                          (get-heights (%right p))))
              (check-heights height-LL height-LR)
              (check-heights height-RL height-RR)
              (values (+ height-LL height-LR)
                      (+ height-RL height-RR)))))
      (unless (avl-empty? tree)
        (let-values (((height-L height-R) (get-heights tree)))
          (check-heights height-L height-R))))
 
    (define (internal-error)
      (display "internal error\n" (current-error-port))
      (emergency-exit 123))
 
    (define (usage-error msg)
      (display "Procedure usage error:\n" (current-error-port))
      (display "  " (current-error-port))
      (display msg (current-error-port))
      (newline (current-error-port))
      (exit 1))
 
    )) ;; end library (avl-trees)
 
 
(cond-expand
  (DEMONSTRATION
   (begin
     (import (avl-trees))
     (import (scheme base))
     (import (scheme time))
     (import (scheme process-context))
     (import (scheme write))
 
     (cond-expand
       (chicken
        (import (only (chicken format) format))) ; For debugging.
       (else))
 
     (define 2**64 (expt 2 64))
 
     (define seed (truncate-remainder (exact (current-second)) 2**64))
     (define random
       ;; A really slow (but presumably highly portable)
       ;; implementation of Donald Knuth’s linear congruential random
       ;; number generator, returning a rational number in [0,1). See
       ;; https://en.wikipedia.org/w/index.php?title=Linear_congruential_generator&oldid=1076681286
       (let ((a 6364136223846793005)
             (c 1442695040888963407))
         (lambda ()
           (let ((result (/ seed 2**64)))
             (set! seed (truncate-remainder (+ (* a seed) c) 2**64))
             result))))
     (do ((i 0 (+ i 1)))
         ((= i 10))
       (random))
 
     (define (fisher-yates-shuffle keys)
       (let ((n (vector-length keys)))
         (do ((i 1 (+ i 1)))
             ((= i n))
           (let* ((randnum (random))
                  (j (+ i (floor (* randnum (- n i)))))
                  (xi (vector-ref keys i))
                  (xj (vector-ref keys j)))
             (vector-set! keys i xj)
             (vector-set! keys j xi)))))
 
     (define (display-key-data key data)
       (display "(")
       (write key)
       (display ", ")
       (write data)
       (display ")"))
 
     (define (display-tree-contents tree)
       (do ((p (avl->alist tree) (cdr p)))
           ((null? p))
         (display-key-data (caar p) (cdar p))
         (newline)))
 
     (define (error-stop)
       (display "*** ERROR STOP ***\n" (current-error-port))
       (emergency-exit 1))
 
     (define n 20)
     (define keys (make-vector (+ n 1)))
     (do ((i 0 (+ i 1)))
         ((= i n))
       ;; To keep things more like Fortran, do not use index zero.
       (vector-set! keys (+ i 1) (+ i 1)))
 
     (fisher-yates-shuffle keys)
 
     ;; Insert key-data pairs in the shuffled order.
     (define tree (avl))
     (avl-check-avl-condition tree)
     (do ((i 1 (+ i 1)))
         ((= i (+ n 1)))
       (let ((ix (vector-ref keys i)))
         (set! tree (avl-insert < tree ix (inexact ix)))
         (avl-check-avl-condition tree)
         (do ((j 1 (+ j 1)))
             ((= j (+ n 1)))
           (let*-values (((k) (vector-ref keys j))
                         ((has-key?) (avl-has-key? < tree k))
                         ((data) (avl-search < tree k))
                         ((data^ has-key?^)
                          (avl-search-values < tree k)))
             (unless (exact? k) (error-stop))
             (if (<= j i)
                 (unless (and has-key? data data^ has-key?^
                              (inexact? data) (= data k)
                              (inexact? data^) (= data^ k))
                   (error-stop))
                 (when (or has-key? data data^ has-key?^)
                   (error-stop)))))))
 
     (display "----------------------------------------------------------------------\n")     
     (display "keys = ")
     (write (cdr (vector->list keys)))
     (newline)
     (display "----------------------------------------------------------------------\n")
     (avl-pretty-print tree)
     (display "----------------------------------------------------------------------\n")
     (display "tree size = ")
     (display (avl-size tree))
     (newline)
     (display-tree-contents tree)
     (display "----------------------------------------------------------------------\n")
 
     ;;
     ;; Reshuffle the keys, and change the data from inexact numbers
     ;; to strings.
     ;;
 
     (fisher-yates-shuffle keys)
 
     (do ((i 1 (+ i 1)))
         ((= i (+ n 1)))
       (let ((ix (vector-ref keys i)))
         (set! tree (avl-insert < tree ix (number->string ix)))
         (avl-check-avl-condition tree)))
 
     (avl-pretty-print tree)
     (display "----------------------------------------------------------------------\n")
     (display "tree size = ")
     (display (avl-size tree))
     (newline)
     (display-tree-contents tree)
     (display "----------------------------------------------------------------------\n")
 
     ;;
     ;; Reshuffle the keys, and delete the contents of the tree, but
     ;; also keep the original tree by saving it in a variable. Check
     ;; persistence of the tree.
     ;;
 
     (fisher-yates-shuffle keys)
 
     (define saved-tree tree)
 
     (do ((i 1 (+ i 1)))
         ((= i (+ n 1)))
       (let ((ix (vector-ref keys i)))
         (set! tree (avl-delete < tree ix))
         (avl-check-avl-condition tree)
         (unless (= (avl-size tree) (- n i)) (error-stop))
         ;; Try deleting a second time.
         (set! tree (avl-delete < tree ix))
         (avl-check-avl-condition tree)
         (unless (= (avl-size tree) (- n i)) (error-stop))
         (do ((j 1 (+ j 1)))
             ((= j (+ n 1)))
           (let ((jx (vector-ref keys j)))
             (unless (eq? (avl-has-key? < tree jx) (< i j))
               (error-stop))
             (let ((data (avl-search < tree jx)))
               (unless (eq? (not (not data)) (< i j))
                 (error-stop))
               (unless (or (not data)
                           (= (string->number data) jx))
                 (error-stop)))
             (let-values (((data found?)
                           (avl-search-values < tree jx)))
               (unless (eq? found? (< i j)) (error-stop))
               (unless (or (and (not data) (<= j i))
                           (and data (= (string->number data) jx)))
                 (error-stop)))))))
     (do ((i 1 (+ i 1)))
         ((= i (+ n 1)))
       ;; Is save-tree the persistent value of the tree we just
       ;; deleted?
       (let ((ix (vector-ref keys i)))
         (unless (equal? (avl-search < saved-tree ix)
                         (number->string ix))
           (error-stop))))
 
     (display "forwards generator:\n")
     (let ((gen (avl-make-generator saved-tree)))
       (do ((pair (gen) (gen)))
           ((not pair))
         (display-key-data (car pair) (cdr pair))
         (newline)))
 
     (display "----------------------------------------------------------------------\n")
 
     (display "backwards generator:\n")
     (let ((gen (avl-make-generator saved-tree -1)))
       (do ((pair (gen) (gen)))
           ((not pair))
         (display-key-data (car pair) (cdr pair))
         (newline)))
 
     (display "----------------------------------------------------------------------\n")
 
     ))
  (else))