AVL tree

From Rosetta Code
Task
AVL tree
You are encouraged to solve this task according to the task description, using any language you may know.
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.

Related task

Red_black_tree_sort

AArch64 Assembly

Works with: as version Raspberry Pi 3B version Buster 64 bits
/* ARM assembly AARCH64 Raspberry PI 3B */
/*  program avltree64.s   */

/*******************************************/
/* Constantes file                         */
/*******************************************/
/* for this file see task include a file in language AArch64 assembly*/
.include "../includeConstantesARM64.inc"

.equ NBVAL,    12

/*******************************************/
/* Structures                               */
/********************************************/
/* structure tree     */
    .struct  0
tree_root:                             // root pointer (or node right)
    .struct  tree_root + 8 
tree_size:                             // number of element of tree
    .struct  tree_size + 8 
tree_suite:
    .struct  tree_suite + 24           // for alignement to node
tree_fin:
/* structure node tree */
    .struct  0
node_right:                            // right pointer
    .struct  node_right + 8 
node_left:                             // left pointer
    .struct  node_left + 8 
node_value:                            // element value
    .struct  node_value + 8 
node_height:                          // element value
    .struct  node_height + 8 
node_parent:                          // element value
    .struct  node_parent + 8
node_fin:

/*******************************************/
/* Initialized data                        */
/*******************************************/
.data
szMessPreOrder:       .asciz "PreOrder :\n"
szCarriageReturn:     .asciz "\n"
/* datas error display */
szMessErreur:         .asciz "Error detected.\n"
szMessKeyDbl:         .asciz "Key exists in tree.\n"
szMessInsInv:         .asciz "Insertion in inverse order.\n"
/* datas message display */
szMessResult:         .asciz "Ele: @ G: @ D: @ val @ h @ \npere @\n"

/*******************************************/
/* UnInitialized data                      */
/*******************************************/
.bss 
sZoneConv:            .skip 24
stTree:               .skip tree_fin    // place to structure tree
stTree1:              .skip tree_fin    // place to structure tree
/*******************************************/
/*  code section                           */
/*******************************************/
.text
.global main 
main: 
    mov x20,#1                           // node tree value
1:                                      // loop insertion in order
    ldr x0,qAdrstTree                   // structure tree address
    mov x1,x20
    bl insertElement                    // add element value x1
    cmp x0,-1
    beq 99f
    add x20,x20,1                           // increment value
    cmp x20,NBVAL                       // end ?
    ble 1b                              // no -> loop

    ldr x0,qAdrstTree                   // structure tree address
    mov x1,11                           // verif key dobble
    bl insertElement                    // add element value x1
    cmp x0,-1
    bne 2f
    ldr x0,qAdrszMessErreur
    bl affichageMess
2:
    ldr x0,qAdrszMessPreOrder           // load verification
    bl affichageMess
    ldr x3,qAdrstTree                   // tree root address (begin structure)
    ldr x0,[x3,tree_root]
    ldr x1,qAdrdisplayElement           // function to execute
    bl preOrder
    

    ldr x0,qAdrszMessInsInv
    bl affichageMess
    mov x20,NBVAL                       // node tree value
3:                                      // loop insertion inverse order
    ldr x0,qAdrstTree1                  // structure tree address
    mov x1,x20
    bl insertElement                    // add element value x1
    cmp x0,-1
    beq 99f
    sub x20,x20,1                           // increment value
    cmp x20,0                           // end ?
    bgt 3b                              // no -> loop

    ldr x0,qAdrszMessPreOrder           // load verification
    bl affichageMess
    ldr x3,qAdrstTree1                  // tree root address (begin structure)
    ldr x0,[x3,tree_root]
    ldr x1,qAdrdisplayElement           // function to execute
    bl preOrder

                                        // search value
    ldr x0,qAdrstTree1                  // tree root address (begin structure)
    mov x1,11                          // value to search
    bl searchTree
    cmp x0,-1
    beq 100f
    mov x2,x0
    ldr x0,qAdrszMessKeyDbl             // key exists
    bl affichageMess
                                        // suppresssion previous value
    mov x0,x2
    ldr x1,qAdrstTree1
    bl supprimer

    ldr x0,qAdrszMessPreOrder           // verification
    bl affichageMess
    ldr x3,qAdrstTree1                  // tree root address (begin structure)
    ldr x0,[x3,tree_root]
    ldr x1,qAdrdisplayElement           // function to execute
    bl preOrder

    b 100f
99:                                     // display error
    ldr x0,qAdrszMessErreur
    bl affichageMess
100:                                    // standard end of the program
    mov x8, #EXIT                       // request to exit program
    svc 0                               // perform system call
qAdrszMessPreOrder:        .quad szMessPreOrder
qAdrszMessErreur:          .quad szMessErreur
qAdrszCarriageReturn:      .quad szCarriageReturn
qAdrstTree:                .quad stTree
qAdrstTree1:               .quad stTree1
qAdrdisplayElement:        .quad displayElement
qAdrszMessInsInv:          .quad szMessInsInv
/******************************************************************/
/*     insert element in the tree                                 */ 
/******************************************************************/
/* x0 contains the address of the tree structure */
/* x1 contains the value of element              */
/* x0 returns address of element or - 1 if error */
insertElement:                        // INFO: insertElement
    stp x1,lr,[sp,-16]!               // save  registers
    mov x6,x0                         // save head
    mov x0,#node_fin                  // reservation place one element
    bl allocHeap
    cmp x0,#-1                        // allocation error
    beq 100f
    mov x5,x0
    str x1,[x5,#node_value]           // store value in address heap
    mov x3,#0
    str x3,[x5,#node_left]            // init left pointer with zero
    str x3,[x5,#node_right]           // init right pointer with zero
    str x3,[x5,#node_height]          // init balance with zero
    ldr x2,[x6,#tree_size]            // load tree size
    cmp x2,#0                         // 0 element ?
    bne 1f
    str x5,[x6,#tree_root]            // yes -> store in root
    b 4f
1:                                    // else search free address in tree
    ldr x3,[x6,#tree_root]            // start with address root
2:                                    // begin loop to insertion
    ldr x4,[x3,#node_value]           // load key 
    cmp x1,x4
    beq 6f                            // key equal
    blt 3f                            // key <
                                      // key >  insertion right
    ldr x8,[x3,#node_right]           // node empty ?
    cmp x8,#0
    csel x3,x8,x3,ne                  // current = right node if not
    //movne x3,x8                       // no -> next node
    bne 2b                            // and loop
    str x5,[x3,#node_right]           // store node address in right pointer
    b 4f
3:                                    // left
    ldr x8,[x3,#node_left]            // left pointer empty ?
    cmp x8,#0
    csel x3,x8,x3,ne                  // current = left node if not
    //movne x3,x8                       //
    bne 2b                            // no -> loop
    str x5,[x3,#node_left]            // store node address in left pointer
4:
    str x3,[x5,#node_parent]          // store parent
    mov x4,#1
    str x4,[x5,#node_height]          // store height = 1
    mov x0,x5                         // begin node to requilbrate
    mov x1,x6                         // head address
    bl equilibrer

5:
    add x2,x2,#1                        // increment tree size
    str x2,[x6,#tree_size]
    mov x0,#0
    b 100f
6:                                   // key equal ?
    ldr x0,qAdrszMessKeyDbl
    bl affichageMess
    mov x0,#-1
    b 100f
100:
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
qAdrszMessKeyDbl:           .quad szMessKeyDbl
/******************************************************************/
/*     equilibrer after insertion                                    */ 
/******************************************************************/
/* x0 contains the address of the node       */
/* x1 contains the address of head */
equilibrer:                       // INFO: equilibrer
    stp x1,lr,[sp,-16]!           // save  registers
    stp x2,x3,[sp,-16]!           // save  registers
    stp x4,x5,[sp,-16]!           // save  registers
    stp x6,x7,[sp,-16]!           // save  registers
    mov x3,#0                     // balance factor
1:                                // begin loop
    ldr x5,[x0,#node_parent]      // load father
    cmp x5,#0                     // end ?
    beq 8f
    cmp x3,#2                     // right tree too long
    beq 8f
    cmp x3,#-2                    // left tree too long
    beq 8f
    mov x6,x0                     // s = current
    ldr x0,[x6,#node_parent]      // current = father
    ldr x7,[x0,#node_left]
    mov x4,#0
    cmp x7,#0
    beq 2f
    ldr x4,[x7,#node_height]     // height left tree 
2:
    ldr x7,[x0,#node_right]
    mov x2,#0
    cmp x7,#0
    beq 3f
    ldr x2,[x7,#node_height]     // height right tree 
3:
    cmp x4,x2
    ble 4f
    add x4,x4,#1
    str x4,[x0,#node_height]
    b 5f
4:
    add x2,x2,#1
    str x2,[x0,#node_height]
5:
    ldr x7,[x0,#node_right]
    mov x4,0
    cmp x7,#0
    beq 6f
    ldr x4,[x7,#node_height]
6:
    ldr x7,[x0,#node_left]
    mov x2,0
    cmp x7,#0
    beq 7f
    ldr x2,[x7,#node_height]
7:
    sub x3,x4,x2                    // compute balance factor
    b 1b
8:
    cmp x3,#2
    beq 9f
    cmp x3,#-2
    beq 9f
    b 100f
9:
    mov x3,x1
    mov x4,x0
    mov x1,x6
    bl equiUnSommet
                                      // change head address ?
    ldr x2,[x3,#tree_root]
    cmp x2,x4
    bne 100f
    str x6,[x3,#tree_root]
100:
    ldp x6,x7,[sp],16              // restaur  2 registers
    ldp x4,x5,[sp],16              // restaur  2 registers
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*     equilibre 1 sommet                                     */ 
/******************************************************************/
/* x0 contains the address of the node       */
/* x1 contains the address of the node    */
equiUnSommet:                             // INFO: equiUnSommet
    stp x1,lr,[sp,-16]!           // save  registers
    stp x2,x3,[sp,-16]!           // save  registers
    stp x4,x5,[sp,-16]!           // save  registers
    stp x6,x7,[sp,-16]!           // save  registers
    mov x5,x0                             // save p
    mov x6,x1    // s
    ldr x2,[x5,#node_left]
    cmp x2,x6
    bne 6f
    ldr x7,[x5,#node_right]
    mov x4,#0
    cmp x7,#0
    beq 1f
    ldr x4,[x7,#node_height]
1:
    ldr x7,[x5,#node_left]
    mov x2,0
    cmp x7,#0
    beq 2f
    ldr x2,[x7,#node_height]
2:
    sub x3,x4,x2
    cmp x3,#-2
    bne 100f
    ldr x7,[x6,#node_right]
    mov x4,0
    cmp x7,#0
    beq 3f
    ldr x4,[x7,#node_height]
3:
    ldr x7,[x6,#node_left]
    mov x2,0
    cmp x7,#0
    beq 4f
    ldr x2,[x7,#node_height]
4:
    sub x3,x4,x2
    cmp x3,#1
    bge 5f
    mov x0,x5
    bl rotRight
    b 100f
5:
    mov x0,x6
    bl rotLeft
    mov x0,x5
    bl rotRight
    b 100f

6:
    ldr x7,[x5,#node_right]
    mov x4,0
    cmp x7,#0
    beq 7f
    ldr x4,[x7,#node_height]
7:
    ldr x7,[x5,#node_left]
    mov x2,0
    cmp x7,#0
    beq 8f
    ldr x2,[x7,#node_height]
8:
    sub x3,x4,x2
    cmp x3,2
    bne 100f
    ldr x7,[x6,#node_right]
    mov x4,0
    cmp x7,#0
    beq 9f
    ldr x4,[x7,#node_height]
9:
    ldr x7,[x6,#node_left]
    mov x2,0
    cmp x7,#0
    beq 10f
    ldr x2,[x7,#node_height]
10:
    sub x3,x4,x2
    cmp x3,#-1
    ble 11f
    mov x0,x5
    bl rotLeft
    b 100f
11:
    mov x0,x6
    bl rotRight
    mov x0,x5
    bl rotLeft

100:
    ldp x6,x7,[sp],16              // restaur  2 registers
    ldp x4,x5,[sp],16              // restaur  2 registers
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*     right rotation                                     */ 
/******************************************************************/
/* x0 contains the address of the node       */
rotRight:                           // INFO: rotRight 
    stp x1,lr,[sp,-16]!           // save  registers
    stp x2,x3,[sp,-16]!           // save  registers
    stp x4,x5,[sp,-16]!           // save  registers
    //   x2                  x2
    //      x0                   x1
    //   x1                         x0
    //      x3                    x3
    ldr x1,[x0,#node_left]          // load left children
    ldr x2,[x0,#node_parent]        // load father
    cmp x2,#0                       // no father ???
    beq 2f
    ldr x3,[x2,#node_left]          // load left node father
    cmp x3,x0                       // equal current node ?
    bne 1f
    str x1,[x2,#node_left]        // yes store left children
    b 2f
1:
    str x1,[x2,#node_right]       // no store right
2:
    str x2,[x1,#node_parent]        // change parent
    str x1,[x0,#node_parent]
    ldr x3,[x1,#node_right]
    str x3,[x0,#node_left]
    cmp x3,#0
    beq 3f
    str x0,[x3,#node_parent]      // change parent node left
3:
    str x0,[x1,#node_right]

    ldr x3,[x0,#node_left]          // compute newbalance factor 
    mov x4,0
    cmp x3,#0
    beq 4f
    ldr x4,[x3,#node_height]
4:
    ldr x3,[x0,#node_right]
    mov x5,0
    cmp x3,#0
    beq 5f
    ldr x5,[x3,#node_height]
5:
    cmp x4,x5
    ble 6f
    add x4,x4,#1
    str x4,[x0,#node_height]
    b 7f
6:
    add x5,x5,#1
    str x5,[x0,#node_height]
7:
//
    ldr x3,[x1,#node_left]         // compute new balance factor
    mov x4,0
    cmp x3,#0
    beq 8f
    ldr x4,[x3,#node_height]
8:
    ldr x3,[x1,#node_right]
    mov x5,0
    cmp x3,#0
    beq 9f
    ldr x5,[x3,#node_height]
9:
    cmp x4,x5
    ble 10f
    add x4,x4,#1
    str x4,[x1,#node_height]
    b 100f
10:
    add x5,x5,#1
    str x5,[x1,#node_height]
100:
    ldp x4,x5,[sp],16              // restaur  2 registers
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*     left rotation                                     */ 
/******************************************************************/
/* x0 contains the address of the node  sommet     */
rotLeft:                             // INFO: rotLeft 
    stp x1,lr,[sp,-16]!              // save  registers
    stp x2,x3,[sp,-16]!              // save  registers
    stp x4,x5,[sp,-16]!              // save  registers
    //   x2                  x2
    //      x0                   x1
    //          x1            x0
    //        x3                 x3
    ldr x1,[x0,#node_right]          // load right children
    ldr x2,[x0,#node_parent]         // load father (racine)
    cmp x2,#0                        // no father ???
    beq 2f
    ldr x3,[x2,#node_left]           // load left node father
    cmp x3,x0                        // equal current node ?
    bne 1f
    str x1,[x2,#node_left]         // yes store left children
    b 2f
1:
    str x1,[x2,#node_right]        // no store to right
2:
    str x2,[x1,#node_parent]         // change parent of right children
    str x1,[x0,#node_parent]         // change parent of sommet
    ldr x3,[x1,#node_left]           // left children 
    str x3,[x0,#node_right]          // left children pivot exists ? 
    cmp x3,#0
    beq 3f
    str x0,[x3,#node_parent]       // yes store in 
3:
    str x0,[x1,#node_left]
//
    ldr x3,[x0,#node_left]           // compute new height for old summit
    mov x4,0
    cmp x3,#0
    beq 4f
    ldr x4,[x3,#node_height]       // left height
4:
    ldr x3,[x0,#node_right]
    mov x5,0
    cmp x3,#0
    beq 5f
    ldr x5,[x3,#node_height]       // right height
5:
    cmp x4,x5
    ble 6f
    add x4,x4,#1
    str x4,[x0,#node_height]       // if right > left
    b 7f
6:
    add x5,x5,#1
    str x5,[x0,#node_height]       // if left > right
7:
//
    ldr x3,[x1,#node_left]           // compute new height for new
    mov x4,0
    cmp x3,#0
    beq 8f
    ldr x4,[x3,#node_height]
8:
    ldr x3,[x1,#node_right]
    mov x5,0
    cmp x3,#0
    beq 9f
    ldr x5,[x3,#node_height]
9:
    cmp x4,x5
    ble 10f
    add x4,x4,#1
    str x4,[x1,#node_height]
    b 100f
10:
    add x5,x5,#1
    str x5,[x1,#node_height]
100:
    ldp x4,x5,[sp],16              // restaur  2 registers
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*     search value in tree                                       */ 
/******************************************************************/
/* x0 contains the address of structure of tree */
/* x1 contains the value to search  */
searchTree:                           // INFO: searchTree
    stp x2,lr,[sp,-16]!              // save  registers
    stp x3,x4,[sp,-16]!              // save  registers
    ldr x2,[x0,#tree_root]

1:                                    // begin loop
    ldr x4,[x2,#node_value]           // load key 
    cmp x1,x4
    beq 3f                            // key equal
    blt 2f                            // key <
                                      // key >  insertion right
    ldr x3,[x2,#node_right]           // node empty ?
    cmp x3,#0
    csel x2,x3,x2,ne
    //movne x2,x3                       // no -> next node
    bne 1b                            // and loop
    mov x0,#-1                        // not find
    b 100f
2:                                    // left
    ldr x3,[x2,#node_left]            // left pointer empty ?
    cmp x3,#0
    csel x2,x3,x2,ne
    bne 1b                            // no -> loop
    mov x0,#-1                        // not find
    b 100f
3:
    mov x0,x2                         // return node address
100:
    ldp x3,x4,[sp],16              // restaur  2 registers
    ldp x2,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*     suppression node                                           */ 
/******************************************************************/
/* x0 contains the address of the node */
/* x1 contains structure tree address  */
supprimer:                       // INFO: supprimer
    stp x1,lr,[sp,-16]!           // save  registers
    stp x2,x3,[sp,-16]!           // save  registers
    stp x4,x5,[sp,-16]!           // save  registers
    stp x6,x7,[sp,-16]!           // save  registers
    ldr x1,[x0,#node_left]
    cmp x1,#0
    bne 5f
    ldr x1,[x0,#node_right]
    cmp x1,#0
    bne 5f
                                 // is a leaf
    mov x4,#0
    ldr x3,[x0,#node_parent]     // father
    cmp x3,#0
    bne 11f
    str x4,[x1,#tree_root]
    b 100f
11:
    ldr x1,[x3,#node_left]
    cmp x1,x0
    bne 2f
    str x4,[x3,#node_left]       // suppression left children
    ldr x5,[x3,#node_right]
    mov x6,#0
    cmp x5,#0
    beq 12f
    ldr x6,[x5,#node_height]
12:
    add x6,x6,#1
    str x6,[x3,#node_height]
    b 3f
2:                                // suppression right children
    str x4,[x3,#node_right]
    ldr x5,[x3,#node_left]
    mov x6,#0
    cmp x5,#0
    beq 21f
    ldr x6,[x5,#node_height]
21:
    add x6,x6,#1
    str x6,[x3,#node_height]
3:                                // new balance
    mov x0,x3
    bl equilibrerSupp
    b 100f
5:                                // is not à leaf
    ldr x7,[x0,#node_right]
    cmp x7,#0
    beq 7f
    mov x2,x0
    mov x0,x7
6:
    ldr x6,[x0,#node_left]  // search the litle element
    cmp x6,#0
    beq 9f
    mov x0,x6
    b 6b
7:
    ldr x7,[x0,#node_left]        
    cmp x7,#0
    beq 9f
    mov x2,x0
    mov x0,x7
8:
    ldr x6,[x0,#node_right]        // search the great element
    cmp x6,#0
    beq 9f
    mov x0,x6
    b 8b
9:
    ldr x5,[x0,#node_value]         // copy value
    str x5,[x2,#node_value]
    bl supprimer                    // suppression node x0
100:
    ldp x6,x7,[sp],16              // restaur  2 registers
    ldp x4,x5,[sp],16              // restaur  2 registers
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30

/******************************************************************/
/*     equilibrer after suppression                                   */ 
/******************************************************************/
/* x0 contains the address of the node       */
/* x1 contains the address of head */
equilibrerSupp:                   // INFO: equilibrerSupp
    stp x1,lr,[sp,-16]!           // save  registers
    stp x2,x3,[sp,-16]!           // save  registers
    stp x4,x5,[sp,-16]!           // save  registers
    stp x6,x7,[sp,-16]!           // save  registers
    mov x3,#1                     // balance factor
    ldr x2,[x1,#tree_root]
1:
    ldr x5,[x0,#node_parent]      // load father
    cmp x5,#0                     // no father 
    beq 100f
    cmp x3,#0                     // balance equilibred
    beq 100f
    mov x6,x0                     // save entry node
    ldr x0,[x6,#node_parent]      // current = father
    ldr x7,[x0,#node_left]
    mov x4,#0
    cmp x7,#0
    b 11f
    ldr x4,[x7,#node_height]    // height left tree 
11:
    ldr x7,[x0,#node_right]
    mov x5,#0
    cmp x7,#0
    beq 12f
    ldr x5,[x7,#node_height]    // height right tree 
12:
    cmp x4,x5
    ble 13f
    add x4,x4,1
    str x4,[x0,#node_height]
    b 14f
13:
    add x5,x5,1
    str x5,[x0,#node_height]
14:
    ldr x7,[x0,#node_right]
    mov x4,#0
    cmp x7,#0
    beq 15f
    ldr x4,[x7,#node_height]
15:
    ldr x7,[x0,#node_left]
    mov x5,0
    cmp x7,#0
    beq 16f
    ldr x5,[x7,#node_height]
16:
    sub x3,x4,x5                   // compute balance factor
    mov x2,x1
    mov x7,x0                      // save current
    mov x1,x6
    bl equiUnSommet
                                   // change head address ?
    cmp x2,x7
    bne 17f
    str x6,[x3,#tree_root]
17:
    mov x0,x7                      // restaur current
    b 1b

100:
    ldp x6,x7,[sp],16              // restaur  2 registers
    ldp x4,x5,[sp],16              // restaur  2 registers
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*     preOrder                                  */ 
/******************************************************************/
/* x0 contains the address of the node */
/* x1 function address                 */
preOrder:                                 // INFO: preOrder
    stp x2,lr,[sp,-16]!           // save  registers
    cmp x0,#0
    beq 100f
    mov x2,x0
    blr x1                                // call function
    ldr x0,[x2,#node_left]
    bl preOrder
    ldr x0,[x2,#node_right]
    bl preOrder
100:
    ldp x2,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30

/******************************************************************/
/*     display node                                               */ 
/******************************************************************/
/* x0 contains node  address          */
displayElement:                   // INFO: displayElement
    stp x1,lr,[sp,-16]!           // save  registers
    stp x2,x3,[sp,-16]!           // save  registers
    stp x4,x5,[sp,-16]!           // save  registers
    mov x2,x0
    ldr x1,qAdrsZoneConv
    bl conversion16
    //strb wzr,[x1,x0]
    ldr x0,qAdrszMessResult
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc
    mov x3,x0
    ldr x0,[x2,#node_left]
    ldr x1,qAdrsZoneConv
    bl conversion16
    //strb wzr,[x1,x0]
    mov x0,x3
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc
    mov x3,x0
    ldr x0,[x2,#node_right]
    ldr x1,qAdrsZoneConv
    bl conversion16
    //strb wzr,[x1,x0]
    mov x0,x3
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc
    mov x3,x0
    ldr x0,[x2,#node_value]
    ldr x1,qAdrsZoneConv
    bl conversion10
    //strb wzr,[x1,x0]
    mov x0,x3
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc
    mov x3,x0
    ldr x0,[x2,#node_height]
    ldr x1,qAdrsZoneConv
    bl conversion10
    //strb wzr,[x1,x0]
    mov x0,x3
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc
    mov x3,x0
    ldr x0,[x2,#node_parent]
    ldr x1,qAdrsZoneConv
    bl conversion16
    //strb wzr,[x1,x0]
    mov x0,x3
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc
    bl affichageMess
100:
    ldp x4,x5,[sp],16              // restaur  2 registers
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
qAdrszMessResult:          .quad szMessResult
qAdrsZoneConv:             .quad sZoneConv

/******************************************************************/
/*     memory allocation on the heap                                  */ 
/******************************************************************/
/* x0 contains the size to allocate */
/* x0 returns address of memory heap or - 1 if error */
/* CAUTION : The size of the allowance must be a multiple of 4  */
allocHeap:
    stp x1,lr,[sp,-16]!            // save  registers
    stp x2,x8,[sp,-16]!            // save  registers
    // allocation
    mov x1,x0                      // save size
    mov x0,0                       // read address start heap
    mov x8,BRK                     // call system 'brk'
    svc 0
    mov x2,x0                      // save address heap for return
    add x0,x0,x1                   // reservation place for size
    mov x8,BRK                     // call system 'brk'
    svc 0
    cmp x0,-1                      // allocation error
    beq 100f
    mov x0,x2                      // return address memory heap
100:
    ldp x2,x8,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/********************************************************/
/*        File Include fonctions                        */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"

Ada

Translation of: C++
with Ada.Text_IO, Ada.Finalization, Ada.Unchecked_Deallocation;

procedure Main is

   generic
      type Key_Type is private;
      with function "<"(a, b : Key_Type) return Boolean is <>;
      with function "="(a, b : Key_Type) return Boolean is <>;
      with function "<="(a, b : Key_Type) return Boolean is <>;
   package AVL_Tree is
      type Tree is tagged limited private;
      function insert(self : in out Tree; key : Key_Type) return Boolean;
      procedure delete(self : in out Tree; key : Key_Type);
      procedure print_balance(self : in out Tree);

   private
      type Height_Amt is range -1 .. Integer'Last;

      -- Since only one key is inserted before each rebalance, the balance of
      -- all trees/subtrees will stay in range -2 .. 2
      type Balance_Amt is range -2 .. 2;

      type Node;
      type Node_Ptr is access Node;
      type Node is new Ada.Finalization.Limited_Controlled with record
         left, right, parent : Node_Ptr := null;
         key : Key_Type;
         balance : Balance_Amt := 0;
      end record;
      overriding procedure Finalize(self : in out Node);
      subtype Node_Parent is Ada.Finalization.Limited_Controlled;

      type Tree is new Ada.Finalization.Limited_Controlled with record
         root : Node_Ptr := null;
      end record;
      overriding procedure Finalize(self : in out Tree);

   end AVL_Tree;

   package body AVL_Tree is

      procedure Free_Node is new Ada.Unchecked_Deallocation(Node, Node_Ptr);

      overriding procedure Finalize(self : in out Node) is
      begin
         Free_Node(self.left);
         Free_Node(self.right);
      end Finalize;

      overriding procedure Finalize(self : in out Tree) is
      begin
         Free_Node(self.root);
      end Finalize;


      function height(n : Node_Ptr) return Height_Amt is
      begin
         if n = null then
            return -1;
         else
            return 1 + Height_Amt'Max(height(n.left), height(n.right));
         end if;
      end height;

      procedure set_balance(n : not null Node_Ptr) is
      begin
         n.balance := Balance_Amt(height(n.right) - height(n.left));
      end set_balance;

      procedure update_parent(parent : Node_Ptr; new_child : Node_Ptr; old_child : Node_Ptr) is
      begin
         if parent /= null then
            if parent.right = old_child then
               parent.right := new_child;
            else
               parent.left := new_child;
            end if;
         end if;
      end update_parent;

      function rotate_left(a : not null Node_Ptr) return Node_Ptr is
         b : Node_Ptr := a.right;
      begin
         b.parent := a.parent;
         a.right := b.left;
         if a.right /= null then
            a.right.parent := a;
         end if;
         b.left := a;
         a.parent := b;
         update_parent(parent => b.parent, new_child => b, old_child => a);

         set_balance(a);
         set_balance(b);
         return b;
      end rotate_left;

      function rotate_right(a : not null Node_Ptr) return Node_Ptr is
         b : Node_Ptr := a.left;
      begin
         b.parent := a.parent;
         a.left := b.right;
         if a.left /= null then
            a.left.parent := a;
         end if;
         b.right := a;
         a.parent := b;
         update_parent(parent => b.parent, new_child => b, old_child => a);

         set_balance(a);
         set_balance(b);
         return b;
      end rotate_right;

      function rotate_left_right(n : not null Node_Ptr) return Node_Ptr is
      begin
         n.left := rotate_left(n.left);
         return rotate_right(n);
      end rotate_left_right;

      function rotate_right_left(n : not null Node_Ptr) return Node_Ptr is
      begin
         n.right := rotate_right(n.right);
         return rotate_left(n);
      end rotate_right_left;

      procedure rebalance(self : in out Tree; n : not null Node_Ptr) is
         new_n : Node_Ptr := n;
      begin
         set_balance(new_n);
         if new_n.balance = -2 then
            if height(new_n.left.left) >= height(new_n.left.right) then
               new_n := rotate_right(new_n);
            else
               new_n := rotate_left_right(new_n);
            end if;
         elsif new_n.balance = 2 then
            if height(new_n.right.right) >= height(new_n.right.left) then
               new_n := rotate_left(new_n);
            else
               new_n := rotate_right_left(new_n);
            end if;
         end if;

         if new_n.parent /= null then
            rebalance(self, new_n.parent);
         else
            self.root := new_n;
         end if;
      end rebalance;

      function new_node(key : Key_Type) return Node_Ptr is
        (new Node'(Node_Parent with key => key, others => <>));

      function insert(self : in out Tree; key : Key_Type) return Boolean is
         curr, parent : Node_Ptr;
         go_left : Boolean;
      begin
         if self.root = null then
            self.root := new_node(key);
            return True;
         end if;

         curr := self.root;
         while curr.key /= key loop
            parent := curr;
            go_left := key < curr.key;
            curr := (if go_left then curr.left else curr.right);
            if curr = null then
               if go_left then
                  parent.left := new_node(key);
                  parent.left.parent := parent;
               else
                  parent.right := new_node(key);
                  parent.right.parent := parent;
               end if;
               rebalance(self, parent);
               return True;
            end if;
         end loop;
         return False;
      end insert;

      procedure delete(self : in out Tree; key : Key_Type) is
         successor, parent, child : Node_Ptr := self.root;
         to_delete : Node_Ptr := null;
      begin
         if self.root = null then
            return;
         end if;

         while child /= null loop
            parent := successor;
            successor := child;
            child := (if successor.key <= key then successor.right else successor.left);
            if successor.key = key then
               to_delete := successor;
            end if;
         end loop;

         if to_delete = null then
            return;
         end if;
         to_delete.key := successor.key;
         child := (if successor.left = null then successor.right else successor.left);
         if self.root.key = key then
            self.root := child;
         else
            update_parent(parent => parent, new_child => child, old_child => successor);
            rebalance(self, parent);
         end if;
         Free_Node(successor);
      end delete;

      procedure print_balance(n : Node_Ptr) is
      begin
         if n /= null then
            print_balance(n.left);
            Ada.Text_IO.Put(n.balance'Image);
            print_balance(n.right);
         end if;
      end print_balance;

      procedure print_balance(self : in out Tree) is
      begin
         print_balance(self.root);
      end print_balance;
   end AVL_Tree;

   package Int_AVL_Tree is new AVL_Tree(Integer);

   tree : Int_AVL_Tree.Tree;
   success : Boolean;
begin
   for i in 1 .. 10 loop
      success := tree.insert(i);
   end loop;
   Ada.Text_IO.Put("Printing balance: ");
   tree.print_balance;
   Ada.Text_IO.New_Line;
end Main;
Output:
Printing balance:  0 0 0 1 0 0 0 0 1 0

Agda

This implementation uses the type system to enforce the height invariants, though not the BST invariants

module Avl where

-- The Peano naturals
data Nat : Set where
 z : Nat
 s : Nat -> Nat

-- An AVL tree's type is indexed by a natural.
-- Avl N is the type of AVL trees of depth N. There arj 3 different
-- node constructors:
--   Left: The left subtree is one level deeper than the right
--   Balanced: The subtrees have the same depth
--   Right: The right Subtree is one level deeper than the left
-- Since the AVL invariant is that the depths of a node's subtrees
-- always differ by at most 1, this perfectly encodes the AVL depth invariant.
data Avl : Nat -> Set where
  Empty : Avl z
  Left : {X : Nat} -> Nat -> Avl (s X) -> Avl X -> Avl (s (s X))
  Balanced : {X : Nat} -> Nat -> Avl X -> Avl X -> Avl (s X)
  Right : {X : Nat} -> Nat -> Avl X -> Avl (s X) -> Avl (s (s X))

-- A wrapper type that hides the AVL tree invariant. This is the interface
-- exposed to the user.
data Tree : Set where
  avl : {N : Nat} -> Avl N -> Tree

-- Comparison result
data Ord : Set where
  Less : Ord
  Equal : Ord
  Greater : Ord

-- Comparison function
cmp : Nat -> Nat -> Ord
cmp z (s X) = Less
cmp z z = Equal
cmp (s X) z = Greater
cmp (s X) (s Y) = cmp X Y

-- Insertions can either leave the depth the same or
-- increase it by one. Encode this in the type.
data InsertResult : Nat -> Set where
  Same : {X : Nat} -> Avl X -> InsertResult X
  Bigger : {X : Nat} -> Avl (s X) -> InsertResult X

-- If the left subtree is 2 levels deeper than the right, rotate to the right.
-- balance-left X L R means X is the root, L is the left subtree and R is the right.
balance-left : {N : Nat} -> Nat -> Avl (s (s N)) -> Avl N -> InsertResult (s (s N))
balance-left X (Right Y A (Balanced Z B C)) D = Same (Balanced Z (Balanced X A B) (Balanced Y C D))
balance-left X (Right Y A (Left Z B C)) D = Same (Balanced Z (Balanced X A B) (Right Y C D))
balance-left X (Right Y A (Right Z B C)) D = Same (Balanced Z (Left X A B) (Balanced Y C D))
balance-left X (Left Y (Balanced Z A B) C) D = Same (Balanced Z (Balanced X A B) (Balanced Y C D))
balance-left X (Left Y (Left Z A B) C) D = Same (Balanced Z (Left X A B) (Balanced Y C D))
balance-left X (Left Y (Right Z A B) C) D = Same (Balanced Z (Right X A B) (Balanced Y C D))
balance-left X (Balanced Y (Balanced Z A B) C) D = Bigger (Right Z (Balanced X A B) (Left Y C D))
balance-left X (Balanced Y (Left Z A B) C) D =  Bigger (Right Z (Left X A B) (Left Y C D))
balance-left X (Balanced Y (Right Z A B) C) D = Bigger (Right Z (Right X A B) (Left Y C D))

-- Symmetric with balance-left
balance-right : {N : Nat} -> Nat -> Avl N -> Avl (s (s N)) -> InsertResult (s (s N))
balance-right X A (Left Y (Left Z B C) D) = Same (Balanced Z (Balanced X A B) (Right Y C D))
balance-right X A (Left Y (Balanced Z B C) D) = Same(Balanced Z (Balanced  X A B) (Balanced Y C D))
balance-right X A (Left Y (Right Z B C) D) = Same(Balanced Z (Left X A B) (Balanced Y C D))
balance-right X A (Balanced Z B (Left Y C D)) = Bigger(Left Z (Right X A B) (Left Y C D))
balance-right X A (Balanced Z B (Balanced Y C D)) = Bigger (Left Z (Right X A B) (Balanced Y C D))
balance-right X A (Balanced Z B (Right Y C D)) = Bigger (Left Z (Right X A B) (Right Y C D))
balance-right X A (Right Z B (Left Y C D)) = Same (Balanced Z (Balanced X A B) (Left Y C D))
balance-right X A (Right Z B (Balanced Y C D)) = Same (Balanced Z (Balanced X A B) (Balanced Y C D))
balance-right X A (Right Z B (Right Y C D)) =  Same (Balanced Z (Balanced X A B) (Right Y C D))

-- insert' T N does all the work of inserting the element N into the tree T.
insert' : {N : Nat} -> Avl N -> Nat -> InsertResult N
insert' Empty N = Bigger (Balanced N Empty Empty)
insert' (Left Y L R) X with cmp X Y
insert' (Left Y L R) X | Less with insert' L X
insert' (Left Y L R) X | Less | Same L' = Same (Left Y L' R)
insert' (Left Y L R) X | Less | Bigger L' = balance-left Y L' R
insert' (Left Y L R) X | Equal = Same (Left Y L R)
insert' (Left Y L R) X | Greater with insert' R X
insert' (Left Y L R) X | Greater | Same R' = Same (Left Y L R')
insert' (Left Y L R) X | Greater | Bigger R' = Same (Balanced Y L R')
insert' (Balanced Y L R) X with cmp X Y
insert' (Balanced Y L R) X | Less with insert' L X
insert' (Balanced Y L R) X | Less | Same L'  = Same (Balanced Y L' R)
insert' (Balanced Y L R) X | Less | Bigger L' = Bigger (Left Y L' R)
insert' (Balanced Y L R) X | Equal = Same (Balanced Y L R)
insert' (Balanced Y L R) X | Greater with insert' R X
insert' (Balanced Y L R) X | Greater | Same R' = Same (Balanced Y L R')
insert' (Balanced Y L R) X | Greater | Bigger R' = Bigger (Right Y L R')
insert' (Right Y L R) X with cmp X Y
insert' (Right Y L R) X | Less with insert' L X
insert' (Right Y L R) X | Less | Same L' = Same (Right Y L' R)
insert' (Right Y L R) X | Less | Bigger L' = Same (Balanced Y L' R)
insert' (Right Y L R) X | Equal = Same (Right Y L R)
insert' (Right Y L R) X | Greater with insert' R X
insert' (Right Y L R) X | Greater | Same R' = Same (Right Y L R')
insert' (Right Y L R) X | Greater | Bigger R' = balance-right Y L R'

-- Wrapper around insert' to use the depth-agnostic type Tree.
insert : Tree -> Nat  -> Tree
insert (avl T) X with insert' T X
... | Same T' = avl T'
... | Bigger T' = avl T'

ARM Assembly

Works with: as version Raspberry Pi
/* ARM assembly Raspberry PI  */
/*  program avltree2.s   */

/* REMARK 1 : this program use routines in a include file 
   see task Include a file language arm assembly 
   for the routine affichageMess conversion10 
   see at end of this program the instruction include */

/*******************************************/
/* Constantes                              */
/*******************************************/
.equ STDOUT, 1           @ Linux output console
.equ EXIT,   1           @ Linux syscall
.equ WRITE,  4           @ Linux syscall
.equ BRK,    0x2d        @ Linux syscall
.equ CHARPOS,     '@'

.equ NBVAL,    12

/*******************************************/
/* Structures                               */
/********************************************/
/* structure tree     */
    .struct  0
tree_root:                             @ root pointer (or node right)
    .struct  tree_root + 4 
tree_size:                             @ number of element of tree
    .struct  tree_size + 4 
tree_suite:
    .struct  tree_suite + 12           @ for alignement to node
tree_fin:
/* structure node tree */
    .struct  0
node_right:                            @ right pointer
    .struct  node_right + 4 
node_left:                             @ left pointer
    .struct  node_left + 4 
node_value:                            @ element value
    .struct  node_value + 4 
node_height:                          @ element value
    .struct  node_height + 4 
node_parent:                          @ element value
    .struct  node_parent + 4 
node_fin:
/* structure queue*/
    .struct  0
queue_begin:                           @ next pointer
    .struct  queue_begin + 4 
queue_end:                             @ element value
    .struct  queue_end + 4 
queue_fin:
/* structure node queue    */
    .struct  0
queue_node_next:                       @ next pointer
    .struct  queue_node_next + 4 
queue_node_value:                      @ element value
    .struct  queue_node_value + 4 
queue_node_fin:
/*******************************************/
/* Initialized data                        */
/*******************************************/
.data
szMessPreOrder:       .asciz "PreOrder :\n"
szCarriageReturn:     .asciz "\n"
/* datas error display */
szMessErreur:         .asciz "Error detected.\n"
szMessKeyDbl:         .asciz "Key exists in tree.\n"
szMessInsInv:         .asciz "Insertion in inverse order.\n"
/* datas message display */
szMessResult:         .asciz "Ele: @ G: @ D: @ val @ h @ pere @\n"
sValue:               .space 12,' '
                      .asciz "\n"
/*******************************************/
/* UnInitialized data                      */
/*******************************************/
.bss 
sZoneConv:            .skip 24
stTree:               .skip tree_fin    @ place to structure tree
stTree1:              .skip tree_fin    @ place to structure tree
stQueue:              .skip queue_fin   @ place to structure queue
/*******************************************/
/*  code section                           */
/*******************************************/
.text
.global main 
main: 
    mov r8,#1                           @ node tree value
1:                                      @ loop insertion in order
    ldr r0,iAdrstTree                   @ structure tree address
    mov r1,r8
    bl insertElement                    @ add element value r1
    cmp r0,#-1
    beq 99f
    //ldr r3,iAdrstTree                 @ tree root address (begin structure)
    //ldr r0,[r3,#tree_root]
    //ldr r1,iAdrdisplayElement           @ function to execute
    //bl preOrder
    add r8,#1                           @ increment value
    cmp r8,#NBVAL                       @ end ?
    ble 1b                              @ no -> loop

    ldr r0,iAdrstTree                   @ structure tree address
    mov r1,#11                          @ verif key dobble
    bl insertElement                    @ add element value r1
    cmp r0,#-1
    bne 2f
    ldr r0,iAdrszMessErreur
    bl affichageMess
2:
    ldr r0,iAdrszMessPreOrder           @ load verification
    bl affichageMess
    ldr r3,iAdrstTree                   @ tree root address (begin structure)
    ldr r0,[r3,#tree_root]
    ldr r1,iAdrdisplayElement           @ function to execute
    bl preOrder
    

    ldr r0,iAdrszMessInsInv
    bl affichageMess
    mov r8,#NBVAL                       @ node tree value
3:                                      @ loop insertion inverse order
    ldr r0,iAdrstTree1                  @ structure tree address
    mov r1,r8
    bl insertElement                    @ add element value r1
    cmp r0,#-1
    beq 99f
    sub r8,#1                           @ increment value
    cmp r8,#0                           @ end ?
    bgt 3b                              @ no -> loop

    ldr r0,iAdrszMessPreOrder           @ load verification
    bl affichageMess
    ldr r3,iAdrstTree1                  @ tree root address (begin structure)
    ldr r0,[r3,#tree_root]
    ldr r1,iAdrdisplayElement           @ function to execute
    bl preOrder

                                        @ search value
    ldr r0,iAdrstTree1                  @ tree root address (begin structure)
    mov r1,#11                          @ value to search
    bl searchTree
    cmp r0,#-1
    beq 100f
    mov r2,r0
    ldr r0,iAdrszMessKeyDbl             @ key exists
    bl affichageMess
                                        @ suppresssion previous value
    mov r0,r2
    ldr r1,iAdrstTree1
    bl supprimer

    ldr r0,iAdrszMessPreOrder           @ verification
    bl affichageMess
    ldr r3,iAdrstTree1                  @ tree root address (begin structure)
    ldr r0,[r3,#tree_root]
    ldr r1,iAdrdisplayElement           @ function to execute
    bl preOrder

    b 100f
99:                                     @ display error
    ldr r0,iAdrszMessErreur
    bl affichageMess
100:                                    @ standard end of the program
    mov r7, #EXIT                       @ request to exit program
    svc 0                               @ perform system call
iAdrszMessPreOrder:        .int szMessPreOrder
iAdrszMessErreur:          .int szMessErreur
iAdrszCarriageReturn:      .int szCarriageReturn
iAdrstTree:                .int stTree
iAdrstTree1:               .int stTree1
iAdrstQueue:               .int stQueue
iAdrdisplayElement:        .int displayElement
iAdrszMessInsInv:          .int szMessInsInv
/******************************************************************/
/*     insert element in the tree                                 */ 
/******************************************************************/
/* r0 contains the address of the tree structure */
/* r1 contains the value of element              */
/* r0 returns address of element or - 1 if error */
insertElement:                        @ INFO: insertElement
    push {r1-r8,lr}                   @ save  registers 
    mov r7,r0                         @ save head
    mov r0,#node_fin                  @ reservation place one element
    bl allocHeap
    cmp r0,#-1                        @ allocation error
    beq 100f
    mov r5,r0
    str r1,[r5,#node_value]           @ store value in address heap
    mov r3,#0
    str r3,[r5,#node_left]            @ init left pointer with zero
    str r3,[r5,#node_right]           @ init right pointer with zero
    str r3,[r5,#node_height]          @ init balance with zero
    ldr r2,[r7,#tree_size]            @ load tree size
    cmp r2,#0                         @ 0 element ?
    bne 1f
    str r5,[r7,#tree_root]            @ yes -> store in root
    b 4f
1:                                    @ else search free address in tree
    ldr r3,[r7,#tree_root]            @ start with address root
2:                                    @ begin loop to insertion
    ldr r4,[r3,#node_value]           @ load key 
    cmp r1,r4
    beq 6f                            @ key equal
    blt 3f                            @ key <
                                      @ key >  insertion right
    ldr r8,[r3,#node_right]           @ node empty ?
    cmp r8,#0
    movne r3,r8                       @ no -> next node
    bne 2b                            @ and loop
    str r5,[r3,#node_right]           @ store node address in right pointer
    b 4f
3:                                    @ left
    ldr r8,[r3,#node_left]            @ left pointer empty ?
    cmp r8,#0
    movne r3,r8                       @
    bne 2b                            @ no -> loop
    str r5,[r3,#node_left]            @ store node address in left pointer
4:
    str r3,[r5,#node_parent]          @ store parent
    mov r4,#1
    str r4,[r5,#node_height]          @ store height = 1
    mov r0,r5                         @ begin node to requilbrate
    mov r1,r7                         @ head address
    bl equilibrer

5:
    add r2,#1                        @ increment tree size
    str r2,[r7,#tree_size]
    mov r0,#0
    b 100f
6:                                   @ key equal ?
    ldr r0,iAdrszMessKeyDbl
    bl affichageMess
    mov r0,#-1
    b 100f
100:
    pop {r1-r8,lr}                    @ restaur registers
    bx lr                             @ return
iAdrszMessKeyDbl:           .int szMessKeyDbl
/******************************************************************/
/*     equilibrer after insertion                                    */ 
/******************************************************************/
/* r0 contains the address of the node       */
/* r1 contains the address of head */
equilibrer:                       @ INFO: equilibrer
    push {r1-r8,lr}               @ save  registers 
    mov r3,#0                     @ balance factor
1:                                @ begin loop
    ldr r5,[r0,#node_parent]      @ load father
    cmp r5,#0                     @ end ?
    beq 5f
    cmp r3,#2                     @ right tree too long
    beq 5f
    cmp r3,#-2                    @ left tree too long
    beq 5f
    mov r6,r0                     @ s = current
    ldr r0,[r6,#node_parent]      @ current = father
    ldr r7,[r0,#node_left]
    cmp r7,#0
    ldrne r8,[r7,#node_height]     @ height left tree 
    moveq r8,#0
    ldr r7,[r0,#node_right]
    cmp r7,#0
    ldrne r9,[r7,#node_height]     @ height right tree 
    moveq r9,#0
    cmp r8,r9
    addgt r8,#1
    strgt r8,[r0,#node_height]
    addle r9,#1
    strle r9,[r0,#node_height]
    //
    ldr r7,[r0,#node_right]
    cmp r7,#0
    ldrne r8,[r7,#node_height]
    moveq r8,#0
    ldr r7,[r0,#node_left]
    cmp r7,#0
    ldrne r9,[r7,#node_height]
    moveq r9,#0
    sub r3,r8,r9                    @ compute balance factor
    b 1b
5:
    cmp r3,#2
    beq 6f
    cmp r3,#-2
    beq 6f
    b 100f
6:
    mov r3,r1
    mov r4,r0
    mov r1,r6
    bl equiUnSommet
                                      @ change head address ?
    ldr r2,[r3,#tree_root]
    cmp r2,r4
    streq r6,[r3,#tree_root]
100:
    pop {r1-r8,lr}                    @ restaur registers
    bx lr                             @ return
/******************************************************************/
/*     equilibre 1 sommet                                     */ 
/******************************************************************/
/* r0 contains the address of the node       */
/* r1 contains the address of the node    */
equiUnSommet:                             @ INFO: equiUnSommet
    push {r1-r9,lr}                       @ save  registers 
    mov r5,r0                             @ save p
    mov r6,r1    // s
    ldr r2,[r5,#node_left]
    cmp r2,r6
    bne 5f
    ldr r7,[r5,#node_right]
    cmp r7,#0
    moveq r8,#0
    ldrne r8,[r7,#node_height]
    ldr r7,[r5,#node_left]
    cmp r7,#0
    moveq r9,#0
    ldrne r9,[r7,#node_height]
    sub r3,r8,r9
    cmp r3,#-2
    bne 100f
    ldr r7,[r6,#node_right]
    cmp r7,#0
    moveq r8,#0
    ldrne r8,[r7,#node_height]
    ldr r7,[r6,#node_left]
    cmp r7,#0
    moveq r9,#0
    ldrne r9,[r7,#node_height]
    sub r3,r8,r9
    cmp r3,#1
    bge 2f
    mov r0,r5
    bl rotRight
    b 100f
2:
    mov r0,r6
    bl rotLeft
    mov r0,r5
    bl rotRight
    b 100f

5:
    ldr r7,[r5,#node_right]
    cmp r7,#0
    moveq r8,#0
    ldrne r8,[r7,#node_height]
    ldr r7,[r5,#node_left]
    cmp r7,#0
    moveq r9,#0
    ldrne r9,[r7,#node_height]
    sub r3,r8,r9
    cmp r3,#2
    bne 100f
    ldr r7,[r6,#node_right]
    cmp r7,#0
    moveq r8,#0
    ldrne r8,[r7,#node_height]
    ldr r7,[r6,#node_left]
    cmp r7,#0
    moveq r9,#0
    ldrne r9,[r7,#node_height]
    sub r3,r8,r9
    cmp r3,#-1
    ble 2f
    mov r0,r5
    bl rotLeft
    b 100f
2:
    mov r0,r6
    bl rotRight
    mov r0,r5
    bl rotLeft
    b 100f

100:
    pop {r1-r9,lr}                    @ restaur registers
    bx lr                             @ return
/******************************************************************/
/*     right rotation                                     */ 
/******************************************************************/
/* r0 contains the address of the node       */
rotRight:                           @ INFO: rotRight 
    push {r1-r5,lr}                 @ save  registers 
    //   r2                  r2
    //      r0                   r1
    //   r1                         r0
    //      r3                    r3
    ldr r1,[r0,#node_left]          @ load left children
    ldr r2,[r0,#node_parent]        @ load father
    cmp r2,#0                       @ no father ???
    beq 2f
    ldr r3,[r2,#node_left]          @ load left node father
    cmp r3,r0                       @ equal current node ?
    streq r1,[r2,#node_left]        @ yes store left children
    strne r1,[r2,#node_right]       @ no store right
2:
    str r2,[r1,#node_parent]        @ change parent
    str r1,[r0,#node_parent]
    ldr r3,[r1,#node_right]
    str r3,[r0,#node_left]
    cmp r3,#0
    strne r0,[r3,#node_parent]      @ change parent node left
    str r0,[r1,#node_right]

    ldr r3,[r0,#node_left]          @ compute newbalance factor 
    cmp r3,#0
    moveq r4,#0
    ldrne r4,[r3,#node_height]
    ldr r3,[r0,#node_right]
    cmp r3,#0
    moveq r5,#0
    ldrne r5,[r3,#node_height]
    cmp r4,r5
    addgt r4,#1
    strgt r4,[r0,#node_height]
    addle r5,#1
    strle r5,[r0,#node_height]
//
    ldr r3,[r1,#node_left]         @ compute new balance factor
    cmp r3,#0
    moveq r4,#0
    ldrne r4,[r3,#node_height]
    ldr r3,[r1,#node_right]
    cmp r3,#0
    moveq r5,#0
    ldrne r5,[r3,#node_height]
    cmp r4,r5
    addgt r4,#1
    strgt r4,[r1,#node_height]
    addle r5,#1
    strle r5,[r1,#node_height]
100:
    pop {r1-r5,lr}                   @ restaur registers
    bx lr
/******************************************************************/
/*     left rotation                                     */ 
/******************************************************************/
/* r0 contains the address of the node  sommet     */
rotLeft:                             @ INFO: rotLeft 
    push {r1-r5,lr}                  @ save  registers 
    //   r2                  r2
    //      r0                   r1
    //          r1            r0
    //        r3                 r3
    ldr r1,[r0,#node_right]          @ load right children
    ldr r2,[r0,#node_parent]         @ load father (racine)
    cmp r2,#0                        @ no father ???
    beq 2f
    ldr r3,[r2,#node_left]           @ load left node father
    cmp r3,r0                        @ equal current node ?
    streq r1,[r2,#node_left]         @ yes store left children
    strne r1,[r2,#node_right]        @ no store to right
2:
    str r2,[r1,#node_parent]         @ change parent of right children
    str r1,[r0,#node_parent]         @ change parent of sommet
    ldr r3,[r1,#node_left]           @ left children 
    str r3,[r0,#node_right]          @ left children pivot exists ? 
    cmp r3,#0
    strne r0,[r3,#node_parent]       @ yes store in 
    str r0,[r1,#node_left]
//
    ldr r3,[r0,#node_left]           @ compute new height for old summit
    cmp r3,#0
    moveq r4,#0
    ldrne r4,[r3,#node_height]       @ left height
    ldr r3,[r0,#node_right]
    cmp r3,#0
    moveq r5,#0
    ldrne r5,[r3,#node_height]       @ right height
    cmp r4,r5
    addgt r4,#1
    strgt r4,[r0,#node_height]       @ if right > left
    addle r5,#1
    strle r5,[r0,#node_height]       @ if left > right
//
    ldr r3,[r1,#node_left]           @ compute new height for new
    cmp r3,#0
    moveq r4,#0
    ldrne r4,[r3,#node_height]
    ldr r3,[r1,#node_right]
    cmp r3,#0
    moveq r5,#0
    ldrne r5,[r3,#node_height]
    cmp r4,r5
    addgt r4,#1
    strgt r4,[r1,#node_height]
    addle r5,#1
    strle r5,[r1,#node_height]
100:
    pop {r1-r5,lr}                        @ restaur registers
    bx lr
/******************************************************************/
/*     search value in tree                                       */ 
/******************************************************************/
/* r0 contains the address of structure of tree */
/* r1 contains the value to search  */
searchTree:                           @ INFO: searchTree
    push {r1-r4,lr}                   @ save  registers 
    ldr r2,[r0,#tree_root]

1:                                    @ begin loop
    ldr r4,[r2,#node_value]           @ load key 
    cmp r1,r4
    beq 3f                            @ key equal
    blt 2f                            @ key <
                                      @ key >  insertion right
    ldr r3,[r2,#node_right]           @ node empty ?
    cmp r3,#0
    movne r2,r3                       @ no -> next node
    bne 1b                            @ and loop
    mov r0,#-1                        @ not find
    b 100f
2:                                    @ left
    ldr r3,[r2,#node_left]            @ left pointer empty ?
    cmp r3,#0
    movne r2,r3                       @
    bne 1b                            @ no -> loop
    mov r0,#-1                        @ not find
    b 100f
3:
    mov r0,r2                         @ return node address
100:
    pop {r1-r4,lr}                    @ restaur registers
    bx lr
/******************************************************************/
/*     suppression node                                           */ 
/******************************************************************/
/* r0 contains the address of the node */
/* r1 contains structure tree address  */
supprimer:                       @ INFO: supprimer
    push {r1-r8,lr}              @ save  registers 
    ldr r1,[r0,#node_left]
    cmp r1,#0
    bne 5f
    ldr r1,[r0,#node_right]
    cmp r1,#0
    bne 5f
                                 @ is a leaf
    mov r4,#0
    ldr r3,[r0,#node_parent]     @ father
    cmp r3,#0
    streq r4,[r1,#tree_root]
    beq 100f
    ldr r1,[r3,#node_left]
    cmp r1,r0
    bne 2f
    str r4,[r3,#node_left]       @ suppression left children
    ldr r5,[r3,#node_right]
    cmp r5,#0
    moveq r6,#0
    ldrne r6,[r5,#node_height]
    add r6,#1
    str r6,[r3,#node_height]
    b 3f
2:                                @ suppression right children
    str r4,[r3,#node_right]
    ldr r5,[r3,#node_left]
    cmp r5,#0
    moveq r6,#0
    ldrne r6,[r5,#node_height]
    add r6,#1
    str r6,[r3,#node_height]
3:                                @ new balance
    mov r0,r3
    bl equilibrerSupp
    b 100f
5:                                @ is not à leaf
    ldr r7,[r0,#node_right]
    cmp r7,#0
    beq 7f
    mov r8,r0
    mov r0,r7
6:
    ldr r6,[r0,#node_left]
    cmp r6,#0
    movne r0,r6
    bne 6b
    b 9f
7:
    ldr r7,[r0,#node_left]         @ search the litle element
    cmp r7,#0
    beq 9f
    mov r8,r0
    mov r0,r7
8:
    ldr r6,[r0,#node_right]        @ search the great element
    cmp r6,#0
    movne r0,r6
    bne 8b
9:
    ldr r5,[r0,#node_value]         @ copy value
    str r5,[r8,#node_value]
    bl supprimer                    @ suppression node r0
100:
    pop {r1-r8,lr}                  @ restaur registers
    bx lr

/******************************************************************/
/*     equilibrer after suppression                                   */ 
/******************************************************************/
/* r0 contains the address of the node       */
/* r1 contains the address of head */
equilibrerSupp:                   @ INFO: equilibrerSupp
    push {r1-r8,lr}               @ save  registers 
    mov r3,#1                     @ balance factor
    ldr r2,[r1,#tree_root]
1:
    ldr r5,[r0,#node_parent]      @ load father
    cmp r5,#0                     @ no father 
    beq 100f
    cmp r3,#0                     @ balance equilibred
    beq 100f
    mov r6,r0                     @ save entry node
    ldr r0,[r6,#node_parent]      @ current = father
    ldr r7,[r0,#node_left]
    cmp r7,#0
    ldrne r8,[r7,#node_height]    @ height left tree 
    moveq r8,#0
    ldr r7,[r0,#node_right]
    cmp r7,#0
    ldrne r9,[r7,#node_height]    @ height right tree 
    moveq r9,#0
    cmp r8,r9
    addgt r8,#1
    strgt r8,[r0,#node_height]
    addle r9,#1
    strle r9,[r0,#node_height]
    //
    ldr r7,[r0,#node_right]
    cmp r7,#0
    ldrne r8,[r7,#node_height]
    moveq r8,#0
    ldr r7,[r0,#node_left]
    cmp r7,#0
    ldrne r9,[r7,#node_height]
    moveq r9,#0
    sub r3,r8,r9                   @ compute balance factor
    mov r2,r1
    mov r4,r0                      @ save current
    mov r1,r6
    bl equiUnSommet
                                   @ change head address ?
    cmp r2,r4
    streq r6,[r3,#tree_root]
    mov r0,r4                      @ restaur current
    b 1b

100:
    pop {r1-r8,lr}                  @ restaur registers
    bx lr                           @ return
/******************************************************************/
/*     preOrder                                  */ 
/******************************************************************/
/* r0 contains the address of the node */
/* r1 function address                 */
preOrder:                                 @ INFO: preOrder
    push {r1-r2,lr}                       @ save  registers 
    cmp r0,#0
    beq 100f
    mov r2,r0
    blx r1                                @ call function

    ldr r0,[r2,#node_left]
    bl preOrder
    ldr r0,[r2,#node_right]
    bl preOrder
100:
    pop {r1-r2,lr}                        @ restaur registers
    bx lr       

/******************************************************************/
/*     display node                                               */ 
/******************************************************************/
/* r0 contains node  address          */
displayElement:                        @ INFO: displayElement
    push {r1,r2,r3,lr}                 @ save  registers 
    mov r2,r0
    ldr r1,iAdrsZoneConv
    bl conversion16
    mov r4,#0
    strb r4,[r1,r0]
    ldr r0,iAdrszMessResult
    ldr r1,iAdrsZoneConv
    bl strInsertAtCharInc
    mov r3,r0
    ldr r0,[r2,#node_left]
    ldr r1,iAdrsZoneConv
    bl conversion16
    mov r4,#0
    strb r4,[r1,r0]
    mov r0,r3
    ldr r1,iAdrsZoneConv
    bl strInsertAtCharInc
    mov r3,r0
    ldr r0,[r2,#node_right]
    ldr r1,iAdrsZoneConv
    bl conversion16
    mov r4,#0
    strb r4,[r1,r0]
    mov r0,r3
    ldr r1,iAdrsZoneConv
    bl strInsertAtCharInc
    mov r3,r0
    ldr r0,[r2,#node_value]
    ldr r1,iAdrsZoneConv
    bl conversion10
    mov r4,#0
    strb r4,[r1,r0]
    mov r0,r3
    ldr r1,iAdrsZoneConv
    bl strInsertAtCharInc
    mov r3,r0
    ldr r0,[r2,#node_height]
    ldr r1,iAdrsZoneConv
    bl conversion10
    mov r4,#0
    strb r4,[r1,r0]
    mov r0,r3
    ldr r1,iAdrsZoneConv
    bl strInsertAtCharInc
    mov r3,r0
    ldr r0,[r2,#node_parent]
    ldr r1,iAdrsZoneConv
    bl conversion16
    mov r4,#0
    strb r4,[r1,r0]
    mov r0,r3
    ldr r1,iAdrsZoneConv
    bl strInsertAtCharInc
    bl affichageMess
100:
    pop {r1,r2,r3,lr}                        @ restaur registers
    bx lr                              @ return
iAdrszMessResult:          .int szMessResult
iAdrsZoneConv:             .int sZoneConv
iAdrsValue:                .int sValue

/******************************************************************/
/*     memory allocation on the heap                                  */ 
/******************************************************************/
/* r0 contains the size to allocate */
/* r0 returns address of memory heap or - 1 if error */
/* CAUTION : The size of the allowance must be a multiple of 4  */
allocHeap:
    push {r5-r7,lr}                   @ save  registers 
    @ allocation
    mov r6,r0                         @ save size
    mov r0,#0                         @ read address start heap
    mov r7,#0x2D                      @ call system 'brk'
    svc #0
    mov r5,r0                         @ save address heap for return
    add r0,r6                         @ reservation place for size
    mov r7,#0x2D                      @ call system 'brk'
    svc #0
    cmp r0,#-1                        @ allocation error
    movne r0,r5                       @ return address memory heap
    pop {r5-r7,lr}                    @ restaur registers
    bx lr                             @ return
/***************************************************/
/*      ROUTINES INCLUDE                 */
/***************************************************/
.include "../affichage.inc"
Output:
Key exists in tree.
Error detected.
PreOrder :
Ele: 007EC08C G: 007EC03C D: 007EC0B4 val 8 h 4 pere 00000000
Ele: 007EC03C G: 007EC014 D: 007EC064 val 4 h 3 pere 007EC08C
Ele: 007EC014 G: 007EC000 D: 007EC028 val 2 h 2 pere 007EC03C
Ele: 007EC000 G: 00000000 D: 00000000 val 1 h 1 pere 007EC014
Ele: 007EC028 G: 00000000 D: 00000000 val 3 h 1 pere 007EC014
Ele: 007EC064 G: 007EC050 D: 007EC078 val 6 h 2 pere 007EC03C
Ele: 007EC050 G: 00000000 D: 00000000 val 5 h 1 pere 007EC064
Ele: 007EC078 G: 00000000 D: 00000000 val 7 h 1 pere 007EC064
Ele: 007EC0B4 G: 007EC0A0 D: 007EC0C8 val 10 h 3 pere 007EC08C
Ele: 007EC0A0 G: 00000000 D: 00000000 val 9 h 1 pere 007EC0B4
Ele: 007EC0C8 G: 00000000 D: 007EC0DC val 11 h 2 pere 007EC0B4
Ele: 007EC0DC G: 00000000 D: 00000000 val 12 h 1 pere 007EC0C8
Insertion in inverse order.
PreOrder :
Ele: 007ED0F9 G: 007ED121 D: 007ED0A9 val 5 h 4 pere 00000000
Ele: 007ED121 G: 007ED135 D: 007ED10D val 3 h 3 pere 007ED0F9
Ele: 007ED135 G: 007ED149 D: 00000000 val 2 h 2 pere 007ED121
Ele: 007ED149 G: 00000000 D: 00000000 val 1 h 1 pere 007ED135
Ele: 007ED10D G: 00000000 D: 00000000 val 4 h 1 pere 007ED121
Ele: 007ED0A9 G: 007ED0D1 D: 007ED081 val 9 h 3 pere 007ED0F9
Ele: 007ED0D1 G: 007ED0E5 D: 007ED0BD val 7 h 2 pere 007ED0A9
Ele: 007ED0E5 G: 00000000 D: 00000000 val 6 h 1 pere 007ED0D1
Ele: 007ED0BD G: 00000000 D: 00000000 val 8 h 1 pere 007ED0D1
Ele: 007ED081 G: 007ED095 D: 007ED06D val 11 h 2 pere 007ED0A9
Ele: 007ED095 G: 00000000 D: 00000000 val 10 h 1 pere 007ED081
Ele: 007ED06D G: 00000000 D: 00000000 val 12 h 1 pere 007ED081
Key exists in tree.
PreOrder :
Ele: 007ED0F9 G: 007ED121 D: 007ED0A9 val 5 h 4 pere 00000000
Ele: 007ED121 G: 007ED135 D: 007ED10D val 3 h 3 pere 007ED0F9
Ele: 007ED135 G: 007ED149 D: 00000000 val 2 h 2 pere 007ED121
Ele: 007ED149 G: 00000000 D: 00000000 val 1 h 1 pere 007ED135
Ele: 007ED10D G: 00000000 D: 00000000 val 4 h 1 pere 007ED121
Ele: 007ED0A9 G: 007ED0D1 D: 007ED081 val 9 h 3 pere 007ED0F9
Ele: 007ED0D1 G: 007ED0E5 D: 007ED0BD val 7 h 2 pere 007ED0A9
Ele: 007ED0E5 G: 00000000 D: 00000000 val 6 h 1 pere 007ED0D1
Ele: 007ED0BD G: 00000000 D: 00000000 val 8 h 1 pere 007ED0D1
Ele: 007ED081 G: 007ED095 D: 00000000 val 12 h 2 pere 007ED0A9
Ele: 007ED095 G: 00000000 D: 00000000 val 10 h 1 pere 007ED081

ATS

Persistent, non-linear trees

Translation of: Scheme

See also Fortran.

The following implementation does not have many proofs. I hope it is a good example of how you can do ATS programming without many proofs, and thus have an easier time than programming the same thing in C.

It would be an interesting exercise to write a C interface to the the following, for given key and value types. Unlike with many languages, no large runtime library would be needed.

Insertion, deletion, and search are implemented, of course. Conversion to and from (linked) lists is provided. So also there are functions to create ‘generator’ closures, which traverse the tree one node at a time. (ATS does not have call-with-current-continuation, so the generators are implemented quite differently from how I implemented similar generators in Scheme.)

(*------------------------------------------------------------------*)

#define ATS_DYNLOADFLAG 0

#include "share/atspre_staload.hats"

(*------------------------------------------------------------------*)

(*

  Persistent AVL trees.

  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: Wirth’s implementations, which are in Pascal and Oberon, are
  for non-persistent trees.)

*)

(*------------------------------------------------------------------*)

(*

  For now, a very simple interface, without much provided in the way
  of proofs.

  You could put all this interface stuff into a .sats file. (You would
  have to remove the word ‘extern’ from the definitions.)

  You might also make avl_t abstract, and put these details in the
  .dats file; you would use ‘assume’ to identify the abstract type
  with an implemented type. That approach would require some name
  changes, and also would make pattern matching on the trees
  impossible outside their implementation. Having users do pattern
  matching on the AVL trees probably is a terrible idea, anyway.

*)

datatype bal_t =
| bal_minus1
| bal_zero
| bal_plus1

datatype avl_t (key_t  : t@ype+,
                data_t : t@ype+,
                size   : int) =
| avl_t_nil (key_t, data_t, 0)
| {size_L, size_R : nat}
  avl_t_cons (key_t, data_t, size_L + size_R + 1) of
    (key_t, data_t, bal_t,
     avl_t (key_t, data_t, size_L),
     avl_t (key_t, data_t, size_R))
typedef avl_t (key_t  : t@ype+,
               data_t : t@ype+) =
  [size : int] avl_t (key_t, data_t, size)

extern prfun
lemma_avl_t_param :
  {key_t, data_t : t@ype}
  {size : int}
  avl_t (key_t, data_t, size) -<prf> [0 <= size] void

(* Implement this template, for whichever type of key you are
   using. It should return a negative number if u < v, zero if
   u = v, or a positive number if u > v. *)
extern fun {key_t : t@ype}
avl_t$compare (u : key_t, v : key_t) :<> int

(* Is the AVL tree empty? *)
extern fun
avl_t_is_empty
          {key_t  : t@ype}
          {data_t : t@ype}
          {size   : int}
          (avl    : avl_t (key_t, data_t, size)) :<>
    [b : bool | b == (size == 0)]
    bool b

(* Does the AVL tree contain at least one association? *)
extern fun
avl_t_isnot_empty
          {key_t  : t@ype}
          {data_t : t@ype}
          {size   : int}
          (avl    : avl_t (key_t, data_t, size)) :<>
    [b : bool | b == (size <> 0)]
    bool b

(* How many associations are stored in the AVL tree? (Currently we
   have no way to do an avl_t_size that preserves the ‘size’ static
   value. This is the best we can do.) *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
avl_t_size {size : int}
           (avl  : avl_t (key_t, data_t, size)) :<>
    [sz : int | (size == 0 && sz == 0) || (0 < size && 0 < sz)]
    size_t sz

(* Does the AVL tree contain the given key? *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
avl_t_has_key
          {size : int}
          (avl  : avl_t (key_t, data_t, size),
           key  : key_t) :<>
    bool

(* Search for a key. If the key is found, return the data value
   associated with it. Otherwise return the value of ‘dflt’. *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
avl_t_search_dflt
          {size : int}
          (avl  : avl_t (key_t, data_t, size),
           key  : key_t,
           dflt : data_t) :<>
    data_t

(* Search for a key. If the key is found, return
   ‘Some(data)’. Otherwise return ‘None()’. *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
avl_t_search_opt
          {size : int}
          (avl  : avl_t (key_t, data_t, size),
           key  : key_t) :<>
    Option (data_t)

(* Search for a key. If the key is found, set ‘found’ to true, and set
   ‘data’. Otherwise set ‘found’ to false. *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
avl_t_search_ref
          {size  : int}
          (avl   : avl_t (key_t, data_t, size),
           key   : key_t,
           data  : &data_t? >> opt (data_t, found),
           found : &bool? >> bool found) :<!wrt>
    #[found : bool]
    void

(* Overload avl_t_search; these functions are easy for the compiler to
   distinguish. *)
overload avl_t_search with avl_t_search_dflt
overload avl_t_search with avl_t_search_opt
overload avl_t_search with avl_t_search_ref

(* If a key is not present in the AVL tree, insert the key-data
   association; return the new AVL tree. If the key *is* present in
   the AVL tree, then *replace* the key-data association; return the
   new AVL tree. *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
avl_t_insert
          {size : int}
          (avl  : avl_t (key_t, data_t, size),
           key  : key_t,
           data : data_t) :<>
    [sz : pos]
    avl_t (key_t, data_t, sz)

(* If a key is not present in the AVL tree, insert the key-data
   association; return the new AVL tree and ‘true’. If the key *is*
   present in the AVL tree, then *replace* the key-data association;
   return the new AVL tree and ‘false’. *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
avl_t_insert_or_replace
          {size : int}
          (avl  : avl_t (key_t, data_t, size),
           key  : key_t,
           data : data_t) :<>
    [sz : pos]
    (avl_t (key_t, data_t, sz), bool)

(* If a key is present in the AVL tree, delete the key-data
   association; otherwise return the tree as it came. *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
avl_t_delete
          {size : int}
          (avl  : avl_t (key_t, data_t, size),
           key  : key_t) :<>
    [sz : nat]
    avl_t (key_t, data_t, sz)

(* If a key is present in the AVL tree, delete the key-data
   association; otherwise return the tree as it came. Also, return a
   bool to indicate whether or not the key was found; ‘true’ if found,
   ‘false’ if not. *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
avl_t_delete_if_found
          {size : int}
          (avl  : avl_t (key_t, data_t, size),
           key  : key_t) :<>
    [sz : nat]
    (avl_t (key_t, data_t, sz), bool)

(* Return a sorted list of the association pairs in an AVL
   tree. (Currently we have no way to do an avl_t_pairs that preserves
   the ‘size’ static value. This is the best we can do.) *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
avl_t_pairs {size : int}
            (avl  : avl_t (key_t, data_t, size)) :<>
    [sz : int | (size == 0 && sz == 0) || (0 < size && 0 < sz)]
    list ((key_t, data_t), sz)

(* Return a sorted list of the keys in an AVL tree. (Currently we have
   no way to do an avl_t_keys that preserves the ‘size’ static
   value. This is the best we can do.) *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
avl_t_keys {size : int}
           (avl  : avl_t (key_t, data_t, size)) :<>
    [sz : int | (size == 0 && sz == 0) || (0 < size && 0 < sz)]
    list (key_t, sz)

(* Return a list of the data values in an AVL tree, sorted in the
   order of their keys. (Currently we have no way to do an avl_t_data
   that preserves the ‘size’ static value. This is the best we can
   do.) *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
avl_t_data {size : int}
           (avl  : avl_t (key_t, data_t, size)) :<>
    [sz : int | (size == 0 && sz == 0) || (0 < size && 0 < sz)]
    list (data_t, sz)

(* list2avl_t does the reverse of what avl_t_pairs does (although
   they are not inverses of each other).
   Currently we have no way to do a list2avl_t that preserves the
   ‘size’ static value. This is the best we can do. *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
list2avl_t {size : int}
           (lst  : list ((key_t, data_t), size)) :<>
    [sz : int | (size == 0 && sz == 0) || (0 < size && 0 < sz)]
    avl_t (key_t, data_t, sz)

(* Make a closure that returns association pairs in either forwards or
   reverse order. *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
avl_t_make_pairs_generator
          {size      : int}
          (avl       : avl_t (key_t, data_t, size),
           direction : int) :
    () -<cloref1> Option @(key_t, data_t)

(* Make a closure that returns keys in either forwards or reverse
   order. *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
avl_t_make_keys_generator
          {size      : int}
          (avl       : avl_t (key_t, data_t, size),
           direction : int) :
    () -<cloref1> Option key_t

(* Make a closure that returns data values in forwards or reverse
   order of their keys. *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
avl_t_make_data_generator
          {size      : int}
          (avl       : avl_t (key_t, data_t, size),
           direction : int) :
    () -<cloref1> Option data_t

(* Raise an assertion if the AVL condition is not met. This template
   is for testing the code. *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
avl_t_check_avl_condition
          {size : int}
          (avl  : avl_t (key_t, data_t, size)) :
    void

(* Print an AVL tree to standard output, in some useful and perhaps
   even pretty format. *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
avl_t_pretty_print
          {size : int}
          (avl  : avl_t (key_t, data_t, size)) :
    void

(* Implement this template for whichever types of keys and data you
   wish to pretty print. *)
extern fun {key_t  : t@ype}
           {data_t : t@ype}
avl_t_pretty_print$key_and_data
          (key  : key_t,
           data : data_t) :
    void

(*------------------------------------------------------------------*)

(*

  What follows is the implementation. It would go into a .dats
  file. Note, however, that the .dats file would have to be staloaded!
  (Preferably anonymously.) This is because the implementation
  contains template functions.

  Notice there are several assertions with ‘$effmask_ntm’ (as opposed
  to proofs) that the routines are terminating. One hopes to remedy
  that problem (with proofs).
  
  Also there are some ‘$effmask_wrt’, but these effect masks are safe,
  because the writing is to our own stack variables.

*)

#define NIL avl_t_nil ()
#define CONS avl_t_cons
#define LNIL list_nil ()
#define :: list_cons
#define F false
#define T true

typedef fixbal_t = bool

primplement
lemma_avl_t_param avl =
  case+ avl of
  | NIL => ()
  | CONS _ => ()

fn {}
minus_neg_bal (bal : bal_t) :<> bal_t =
  case+ bal of
  | bal_minus1 () => bal_plus1
  | _ => bal_zero ()

fn {}
minus_pos_bal (bal : bal_t) :<> bal_t =
  case+ bal of
  | bal_plus1 () => bal_minus1
  | _ => bal_zero ()

fn {}
bal2int (bal : bal_t) :<> int =
  case+ bal of
  | bal_minus1 () => ~1
  | bal_zero () => 0
  | bal_plus1 () => 1

implement
avl_t_is_empty avl =
  case+ avl of
  | NIL => T
  | CONS _ => F

implement
avl_t_isnot_empty avl =
  ~avl_t_is_empty avl

implement {key_t} {data_t}
avl_t_size {siz} avl =
  let
    fun
    traverse {size : int}
             (p    : avl_t (key_t, data_t, size)) :<!ntm>
        [sz : int | (size == 0 && sz == 0) ||
                    (0 < size && 0 < sz)]
        size_t sz =
      case+ p of
      | NIL => i2sz 0
      | CONS (_, _, _, left, right) =>
        let
          val [sz_L : int] sz_L = traverse left
          val [sz_R : int] sz_R = traverse right
          prval _ = prop_verify {0 <= sz_L} ()
          prval _ = prop_verify {0 <= sz_R} ()
        in
          succ (sz_L + sz_R)
        end

    val [sz : int] sz = $effmask_ntm (traverse {siz} avl)
    prval _ = prop_verify {(siz == 0 && sz == 0) ||
                           (0 < siz && 0 < sz)} ()
  in
    sz
  end

implement {key_t} {data_t}
avl_t_has_key (avl, key) =
  let
    fun
    search {size : int}
           (p    : avl_t (key_t, data_t, size)) :<!ntm>
        bool =
      case+ p of
      | NIL => F
      | CONS (k, _, _, left, right) =>
        begin
          case+ avl_t$compare<key_t> (key, k) of
          | cmp when cmp < 0 => search left
          | cmp when cmp > 0 => search right
          | _ => T
        end
  in
    $effmask_ntm search avl
  end

implement {key_t} {data_t}
avl_t_search_dflt (avl, key, dflt) =
  let
    var data : data_t?
    var found : bool?
    val _ = $effmask_wrt avl_t_search_ref (avl, key, data, found)
  in
    if found then
      let
        prval _ = opt_unsome data
      in
        data
      end
    else
      let
        prval _ = opt_unnone data
      in
        dflt
      end
  end

implement {key_t} {data_t}
avl_t_search_opt (avl, key) =
  let
    var data : data_t?
    var found : bool?
    val _ = $effmask_wrt avl_t_search_ref (avl, key, data, found)
  in
    if found then
      let
        prval _ = opt_unsome data
      in
        Some {data_t} data
      end
    else
      let
        prval _ = opt_unnone data
      in
        None {data_t} ()
      end
  end

implement {key_t} {data_t}
avl_t_search_ref (avl, key, data, found) =
  let
    fun
    search (p     : avl_t (key_t, data_t),
            data  : &data_t? >> opt (data_t, found),
            found : &bool? >> bool found) :<!wrt,!ntm>
        #[found : bool] void =
      case+ p of
      | NIL =>
        {
          prval _ = opt_none {data_t} data
          val _ = found := F
        }
      | CONS (k, d, _, left, right) =>
        begin
          case+ avl_t$compare<key_t> (key, k) of
          | cmp when cmp < 0 => search (left, data, found)
          | cmp when cmp > 0 => search (right, data, found)
          | _ =>
            {
              val _ = data := d
              prval _ = opt_some {data_t} data
              val _ = found := T
            }
        end
  in
    $effmask_ntm search (avl, data, found)
  end

implement {key_t} {data_t}
avl_t_insert (avl, key, data) =
  let
    val (avl, _) =
      avl_t_insert_or_replace<key_t><data_t> (avl, key, data)
  in
    avl
  end

implement {key_t} {data_t}
avl_t_insert_or_replace (avl, key, data) =
  let
    fun
    search {size   : nat}
           (p      : avl_t (key_t, data_t, size),
            fixbal : fixbal_t,
            found  : bool) :<!ntm>
        [sz : pos]
        (avl_t (key_t, data_t, sz), fixbal_t, bool) =
      case+ p of
      | NIL =>
        (* The key was not found. Insert a new node. The tree will
            need rebalancing. *)
        (CONS (key, data, bal_zero, NIL, NIL), T, F)
      | CONS (k, d, bal, left, right) =>
        case+ avl_t$compare<key_t> (key, k) of
        | cmp when cmp < 0 =>
          let
            val (p1, fixbal, found) = search (left, fixbal, found)
          in
            (* If fixbal is T, then a node has been inserted
               on the left, and rebalancing may be necessary. *)
            case+ (fixbal, bal) of
            | (F, _) =>
              (* No rebalancing is necessary. *)
              (CONS (k, d, bal, p1, right), F, found)
            | (T, bal_plus1 ()) =>
              (* No rebalancing is necessary. *)
              (CONS (k, d, bal_zero (), p1, right), F, found)
            | (T, bal_zero ()) =>
              (* Rebalancing might still be necessary. *)
              (CONS (k, d, bal_minus1 (), p1, right), fixbal, found)
            | (T, bal_minus1 ()) =>
              (* Rebalancing is necessary. *)
              let
                val+ CONS (k1, d1, bal1, left1, right1) = p1
              in
                case+ bal1 of
                | bal_minus1 () =>
                  (* A single LL rotation. *)
                  let
                    val q = CONS (k, d, bal_zero (), right1, right)
                    val q1 = CONS (k1, d1, bal_zero (), left1, q)
                  in
                    (q1, F, found)
                  end
                | _ =>
                  (* A double LR rotation. *)
                  let
                    val p2 = right1
                    val- CONS (k2, d2, bal2, left2, right2) = p2
                    val q = CONS (k, d, minus_neg_bal bal2,
                                  right2, right)
                    val q1 = CONS (k1, d1, minus_pos_bal bal2,
                                   left1, left2)
                    val q2 = CONS (k2, d2, bal_zero (), q1, q)
                  in
                    (q2, F, found)
                  end
              end
          end
        | cmp when cmp > 0 =>
          let
            val (p1, fixbal, found) = search (right, fixbal, found)
          in
            (* If fixbal is T, then a node has been inserted
               on the right, and rebalancing may be necessary. *)
            case+ (fixbal, bal) of
            | (F, _) =>
              (* No rebalancing is necessary. *)
              (CONS (k, d, bal, left, p1), F, found)
            | (T, bal_minus1 ()) =>
              (* No rebalancing is necessary. *)
              (CONS (k, d, bal_zero (), left, p1), F, found)
            | (T, bal_zero ()) =>
              (* Rebalancing might still be necessary. *)
              (CONS (k, d, bal_plus1 (), left, p1), fixbal, found)
            | (T, bal_plus1 ()) =>
              (* Rebalancing is necessary. *)
              let
                val+ CONS (k1, d1, bal1, left1, right1) = p1
              in
                case+ bal1 of
                | bal_plus1 () =>
                  (* A single RR rotation. *)
                  let
                    val q = CONS (k, d, bal_zero (), left, left1)
                    val q1 = CONS (k1, d1, bal_zero (), q, right1)
                  in
                    (q1, F, found)
                  end
                | _ =>
                  (* A double RL rotation. *)
                  let
                    val p2 = left1
                    val- CONS (k2, d2, bal2, left2, right2) = p2
                    val q = CONS (k, d, minus_pos_bal bal2,
                                  left, left2)
                    val q1 = CONS (k1, d1, minus_neg_bal bal2,
                                   right2, right1)
                    val q2 = CONS (k2, d2, bal_zero (), q, q1)
                  in
                    (q2, F, found)
                  end
              end
          end
        | _ =>
          (* The key was found; p is an existing node. Replace
             it. The tree needs no rebalancing. *)
          (CONS (key, data, bal, left, right), F, T)
  in
    if avl_t_is_empty avl then
      (* Start a new tree. *)
      (CONS (key, data, bal_zero, NIL, NIL), F)
    else
      let
        prval _ = lemma_avl_t_param avl
        val (avl, _, found) = $effmask_ntm search (avl, F, F)
      in
        (avl, found)
      end
  end

fn {key_t  : t@ype}
   {data_t : t@ype}
balance_for_shrunken_left
          {size : pos}
          (p    : avl_t (key_t, data_t, size)) :<>
    (* Returns a new avl_t, and a ‘fixbal’ flag. *)
    [sz : pos]
    (avl_t (key_t, data_t, sz), fixbal_t) =
  let
    val+ CONS (k, d, bal, left, right) = p
  in
    case+ bal of
    | bal_minus1 () => (CONS (k, d, bal_zero, left, right), T)
    | bal_zero () => (CONS (k, d, bal_plus1, left, right), F)
    | bal_plus1 () =>
      (* Rebalance. *)
      let
        val p1 = right
        val- CONS (k1, d1, bal1, left1, right1) = p1
      in
        case+ bal1 of
        | bal_zero () =>
          (* A single RR rotation. *)
          let
            val q = CONS (k, d, bal_plus1, left, left1)
            val q1 = CONS (k1, d1, bal_minus1, q, right1)
          in
            (q1, F)
          end
        | bal_plus1 () =>
          (* A single RR rotation. *)
          let
            val q = CONS (k, d, bal_zero, left, left1)
            val q1 = CONS (k1, d1, bal_zero, q, right1)
          in
            (q1, T)
          end
        | bal_minus1 () =>
          (* A double RL rotation. *)
          let
            val p2 = left1
            val- CONS (k2, d2, bal2, left2, right2) = p2
            val q = CONS (k, d, minus_pos_bal bal2, left, left2)
            val q1 = CONS (k1, d1, minus_neg_bal bal2, right2, right1)
            val q2 = CONS (k2, d2, bal_zero, q, q1)
          in
            (q2, T)
          end
      end
  end

fn {key_t  : t@ype}
   {data_t : t@ype}
balance_for_shrunken_right
          {size : pos}
          (p    : avl_t (key_t, data_t, size)) :<>
    (* Returns a new avl_t, and a ‘fixbal’ flag. *)
    [sz : pos]
    (avl_t (key_t, data_t, sz), fixbal_t) =
  let
    val+ CONS (k, d, bal, left, right) = p
  in
    case+ bal of
    | bal_plus1 () => (CONS (k, d, bal_zero, left, right), T)
    | bal_zero () => (CONS (k, d, bal_minus1, left, right), F)
    | bal_minus1 () =>
      (* Rebalance. *)
      let
        val p1 = left
        val- CONS (k1, d1, bal1, left1, right1) = p1
      in
        case+ bal1 of
        | bal_zero () =>
          (* A single LL rotation. *)
          let
            val q = CONS (k, d, bal_minus1, right1, right)
            val q1 = CONS (k1, d1, bal_plus1, left1, q)
          in
            (q1, F)
          end
        | bal_minus1 () =>
          (* A single LL rotation. *)
          let
            val q = CONS (k, d, bal_zero, right1, right)
            val q1 = CONS (k1, d1, bal_zero, left1, q)
          in
            (q1, T)
          end
        | bal_plus1 () =>
          (* A double LR rotation. *)
          let
            val p2 = right1
            val- CONS (k2, d2, bal2, left2, right2) = p2
            val q = CONS (k, d, minus_neg_bal bal2, right2, right)
            val q1 = CONS (k1, d1, minus_pos_bal bal2, left1, left2)
            val q2 = CONS (k2, d2, bal_zero, q1, q)
          in
            (q2, T)
          end
      end
  end

implement {key_t} {data_t}
avl_t_delete (avl, key) =
  (avl_t_delete_if_found (avl, key)).0

implement {key_t} {data_t}
avl_t_delete_if_found (avl, key) =
  let
    fn
    balance_L__ {size : pos}
                (p    : avl_t (key_t, data_t, size)) :<>
        [sz : pos]
        (avl_t (key_t, data_t, sz), fixbal_t) =
      balance_for_shrunken_left<key_t><data_t> p
    fn
    balance_R__ {size : pos}
                (p    : avl_t (key_t, data_t, size)) :<>
        [sz : pos]
        (avl_t (key_t, data_t, sz), fixbal_t) =
      balance_for_shrunken_right<key_t><data_t> p

    fn {}
    balance_L {size   : pos}
              (p      : avl_t (key_t, data_t, size),
               fixbal : fixbal_t) :<>
        [sz : pos]
        (avl_t (key_t, data_t, sz), fixbal_t) =
      if fixbal then
        balance_L__ p
      else
        (p, F)

    fn {}
    balance_R {size   : pos}
              (p      : avl_t (key_t, data_t, size),
               fixbal : fixbal_t) :<>
        [sz : pos]
        (avl_t (key_t, data_t, sz), fixbal_t) =
      if fixbal then
        balance_R__ p
      else
        (p, F)

    fun
    del {size   : pos}
        (r      : avl_t (key_t, data_t, size),
         fixbal : fixbal_t) :<!ntm>
        (* Returns a new avl_t, a new fixbal, and key and data to be
           ‘moved up the tree’. *)
        [sz : nat]
        (avl_t (key_t, data_t, sz), fixbal_t, key_t, data_t) =
      case+ r of
      | CONS (k, d, bal, left, right) =>
        begin
          case+ right of
          | CONS _ =>
            let
              val (q, fixbalq, kq, dq) = del (right, fixbal)
              val q1 = CONS (k, d, bal, left, q)
              val (q1bal, fixbal) = balance_R (q1, fixbalq)
            in
              (q1bal, fixbal, kq, dq)
            end
          | NIL => (left, T, k, d)
        end

    fun
    search {size   : nat}
           (p      : avl_t (key_t, data_t, size),
            fixbal : fixbal_t) :<!ntm>
        (* Return three values: a new avl_t, a new fixbal, and
           whether the key was found. *)
        [sz : nat]
        (avl_t (key_t, data_t, sz), fixbal_t, bool) =
      case+ p of
      | NIL => (p, F, F)
      | CONS (k, d, bal, left, right) =>
        case+ avl_t$compare<key_t> (key, k) of
        | cmp when cmp < 0 =>
          (* Recursive search down the left branch. *)
          let
            val (q, fixbal, found) = search (left, fixbal)
            val (q1, fixbal) =
              balance_L (CONS (k, d, bal, q, right), fixbal)
          in
            (q1, fixbal, found)
          end
        | cmp when cmp > 0 =>
          (* Recursive search down the right branch. *)
          let
            val (q, fixbal, found) = search (right, fixbal)
            val (q1, fixbal) =
              balance_R (CONS (k, d, bal, left, q), fixbal)
          in
            (q1, fixbal, found)
          end
        | _ =>
          if avl_t_is_empty right then
            (* Delete p, replace it with its left branch, then
               rebalance. *)
            (left, T, T)
          else if avl_t_is_empty left then
            (* Delete p, replace it with its right branch, then
               rebalance. *)
            (right, T, T)
          else
            (* Delete p, but it has both left and right branches, and
               therefore may have complicated branch structure. *)
            let
              val (q, fixbal, k1, d1) = del (left, fixbal)
              val (q1, fixbal) =
                balance_L (CONS (k1, d1, bal, q, right), fixbal)
            in
              (q1, fixbal, T)
            end
  in
    if avl_t_is_empty avl then
      (avl, F)
    else
      let
        prval _ = lemma_avl_t_param avl
        val (avl1, _, found) = $effmask_ntm search (avl, F)
      in
        (avl1, found)
      end
  end

implement {key_t} {data_t}
avl_t_pairs (avl) =
  let
    fun
    traverse {size : pos}
             {n    : nat}
             (p    : avl_t (key_t, data_t, size),
              lst  : list ((key_t, data_t), n)) :<!ntm>
        [sz : pos] list ((key_t, data_t), sz) =
      (* Reverse in-order traversal, to make an in-order list by
         consing. *)
      case+ p of
      | CONS (k, d, _, left, right) =>
        if avl_t_is_empty left then
          begin
            if avl_t_is_empty right then
              (k, d) :: lst
            else
              (k, d) :: traverse (right, lst)
          end
        else
          begin
            if avl_t_is_empty right then
              traverse (left, (k, d) :: lst)
            else
              traverse (left, (k, d) :: traverse (right, lst))
          end
  in
    case+ avl of
    | NIL => LNIL
    | CONS _ => $effmask_ntm traverse (avl, LNIL)
  end


implement {key_t} {data_t}
avl_t_keys (avl) =
  let
    fun
    traverse {size : pos}
             {n    : nat}
             (p    : avl_t (key_t, data_t, size),
              lst  : list (key_t, n)) :<!ntm>
        [sz : pos] list (key_t, sz) =
      (* Reverse in-order traversal, to make an in-order list by
         consing. *)
      case+ p of
      | CONS (k, _, _, left, right) =>
        if avl_t_is_empty left then
          begin
            if avl_t_is_empty right then
              k :: lst
            else
              k :: traverse (right, lst)
          end
        else
          begin
            if avl_t_is_empty right then
              traverse (left, k :: lst)
            else
              traverse (left, k :: traverse (right, lst))
          end
  in
    case+ avl of
    | NIL => LNIL
    | CONS _ => $effmask_ntm traverse (avl, LNIL)
  end

implement {key_t} {data_t}
avl_t_data (avl) =
  let
    fun
    traverse {size : pos}
             {n    : nat}
             (p    : avl_t (key_t, data_t, size),
              lst  : list (data_t, n)) :<!ntm>
        [sz : pos] list (data_t, sz) =
      (* Reverse in-order traversal, to make an in-order list by
         consing. *)
      case+ p of
      | CONS (_, d, _, left, right) =>
        if avl_t_is_empty left then
          begin
            if avl_t_is_empty right then
              d :: lst
            else
              d :: traverse (right, lst)
          end
        else
          begin
            if avl_t_is_empty right then
              traverse (left, d :: lst)
            else
              traverse (left, d :: traverse (right, lst))
          end
  in
    case+ avl of
    | NIL => LNIL
    | CONS _ => $effmask_ntm traverse (avl, LNIL)
  end

implement {key_t} {data_t}
list2avl_t lst =
  let
    fun
    traverse {n    : pos}
             {size : nat} .<n>.
             (lst  : list ((key_t, data_t), n),
              p    : avl_t (key_t, data_t, size)) :<>
        [sz : pos] avl_t (key_t, data_t, sz) =
      case+ lst of
      | (k, d) :: LNIL => avl_t_insert<key_t><data_t> (p, k, d)
      | (k, d) :: (_ :: _) =>
        let
          val+ _ :: tail = lst
        in
          traverse (tail, avl_t_insert<key_t><data_t> (p, k, d))
        end
  in
    case+ lst of
    | LNIL => NIL
    | (_ :: _) => traverse (lst, NIL)
  end

fun {key_t  : t@ype}
    {data_t : t@ype}
push_all_the_way_left (stack : List (avl_t (key_t, data_t)),
                       p     : avl_t (key_t, data_t)) :
    List0 (avl_t (key_t, data_t)) =
  let
    prval _ = lemma_list_param stack
  in
    case+ p of
    | NIL => stack
    | CONS (_, _, _, left, _) =>
      push_all_the_way_left (p :: stack, left)
  end

fun {key_t  : t@ype}
    {data_t : t@ype}
push_all_the_way_right (stack : List (avl_t (key_t, data_t)),
                        p     : avl_t (key_t, data_t)) :
    List0 (avl_t (key_t, data_t)) =
  let
    prval _ = lemma_list_param stack
  in
    case+ p of
    | NIL => stack
    | CONS (_, _, _, _, right) =>
      push_all_the_way_right (p :: stack, right)
  end

fun {key_t  : t@ype}
    {data_t : t@ype}
push_all_the_way (stack     : List (avl_t (key_t, data_t)),
                  p         : avl_t (key_t, data_t),
                  direction : int) :
    List0 (avl_t (key_t, data_t)) =
  if direction < 0 then
    push_all_the_way_right<key_t><data_t> (stack, p)
  else
    push_all_the_way_left<key_t><data_t> (stack, p)

fun {key_t  : t@ype}
    {data_t : t@ype}
update_generator_stack (stack     : List (avl_t (key_t, data_t)),
                        left      : avl_t (key_t, data_t),
                        right     : avl_t (key_t, data_t),
                        direction : int) :
    List0 (avl_t (key_t, data_t)) =
  let
    prval _ = lemma_list_param stack
  in
    if direction < 0 then
      begin
        if avl_t_is_empty left then
          stack
        else
          push_all_the_way_right<key_t><data_t> (stack, left)
      end
    else
      begin
        if avl_t_is_empty right then
          stack
        else
          push_all_the_way_left<key_t><data_t> (stack, right)
      end
  end

implement {key_t} {data_t}
avl_t_make_pairs_generator (avl, direction) =
  let
    typedef avl_t = avl_t (key_t, data_t)

    val stack = push_all_the_way (LNIL, avl, direction)
    val stack_ref = ref stack

    (* Cast stack_ref to its (otherwise untyped) pointer, so it can be
       enclosed within ‘generate’. *)
    val p_stack_ref = $UNSAFE.castvwtp0{ptr} stack_ref

    fun
    generate () :<cloref1> Option @(key_t, data_t) =
      let
        (* Restore the type information for stack_ref. *)
        val stack_ref =
          $UNSAFE.castvwtp0{ref (List avl_t)} p_stack_ref

        var stack : List0 avl_t = !stack_ref
        var retval : Option @(key_t, data_t)
      in
        begin
          case+ stack of
          | LNIL => retval := None ()
          | p :: tail =>
            let
              val- CONS (k, d, _, left, right) = p
            in
              retval := Some @(k, d);
              stack :=
                update_generator_stack<key_t><data_t>
                  (tail, left, right, direction)
            end
        end;
        !stack_ref := stack;
        retval
      end
  in
    generate
  end

implement {key_t} {data_t}
avl_t_make_keys_generator (avl, direction) =
  let
    typedef avl_t = avl_t (key_t, data_t)

    val stack = push_all_the_way (LNIL, avl, direction)
    val stack_ref = ref stack

    (* Cast stack_ref to its (otherwise untyped) pointer, so it can be
       enclosed within ‘generate’. *)
    val p_stack_ref = $UNSAFE.castvwtp0{ptr} stack_ref

    fun
    generate () :<cloref1> Option key_t =
      let
        (* Restore the type information for stack_ref. *)
        val stack_ref =
          $UNSAFE.castvwtp0{ref (List avl_t)} p_stack_ref

        var stack : List0 avl_t = !stack_ref
        var retval : Option key_t
      in
        begin
          case+ stack of
          | LNIL => retval := None ()
          | p :: tail =>
            let
              val- CONS (k, _, _, left, right) = p
            in
              retval := Some k;
              stack :=
                update_generator_stack<key_t><data_t>
                  (tail, left, right, direction)
            end
        end;
        !stack_ref := stack;
        retval
      end
  in
    generate
  end

implement {key_t} {data_t}
avl_t_make_data_generator (avl, direction) =
  let
    typedef avl_t = avl_t (key_t, data_t)

    val stack = push_all_the_way (LNIL, avl, direction)
    val stack_ref = ref stack

    (* Cast stack_ref to its (otherwise untyped) pointer, so it can be
       enclosed within ‘generate’. *)
    val p_stack_ref = $UNSAFE.castvwtp0{ptr} stack_ref

    fun
    generate () :<cloref1> Option data_t =
      let
        (* Restore the type information for stack_ref. *)
        val stack_ref =
          $UNSAFE.castvwtp0{ref (List avl_t)} p_stack_ref

        var stack : List0 avl_t = !stack_ref
        var retval : Option data_t
      in
        begin
          case+ stack of
          | LNIL => retval := None ()
          | p :: tail =>
            let
              val- CONS (_, d, _, left, right) = p
            in
              retval := Some d;
              stack :=
                update_generator_stack<key_t><data_t>
                  (tail, left, right, direction)
            end
        end;
        !stack_ref := stack;
        retval
      end
  in
    generate
  end

implement {key_t} {data_t}
avl_t_check_avl_condition (avl) =
  (* If any of the assertions here is triggered, there is a bug. *)
  let
    fun
    get_heights (p : avl_t (key_t, data_t)) : (int, int) =
      case+ p of
      | NIL => (0, 0)
      | CONS (k, d, bal, left, right) =>
        let
          val (height_LL, height_LR) = get_heights left
          val (height_RL, height_RR) = get_heights right
        in
          assertloc (abs (height_LL - height_LR) <= 1);
          assertloc (abs (height_RL - height_RR) <= 1);
          (height_LL + height_LR, height_RL + height_RR)
        end
  in
    if avl_t_isnot_empty avl then
      let
        val (height_L, height_R) = get_heights avl
      in
        assertloc (abs (height_L - height_R) <= 1)
      end
  end

implement {key_t} {data_t}
avl_t_pretty_print (avl) =
  let
    fun
    pad {depth : nat} .<depth>.
        (depth : int depth) : void =
      if depth <> 0 then
        begin
          print! ("  ");
          pad (pred depth)
        end

    fun
    traverse {size  : nat}
             {depth : nat}
             (p     : avl_t (key_t, data_t, size),
              depth : int depth) : void =
      if avl_t_isnot_empty p then
        let
          val+ CONS (k, d, bal, left, right) = p
        in
          traverse (left, succ depth);
          pad depth;
          avl_t_pretty_print$key_and_data<key_t><data_t> (k, d);
          println! ("\t\tdepth = ", depth, " bal = ", bal2int bal);
          traverse (right, succ depth)
        end
  in
    if avl_t_isnot_empty avl then
      let
        val+ CONS (k, d, bal, left, right) = avl
      in
        traverse (left, 1);
        avl_t_pretty_print$key_and_data<key_t><data_t> (k, d);
        println! ("\t\tdepth = 0  bal = ", bal2int bal);
        traverse (right, 1)
      end
  end

(*------------------------------------------------------------------*)

(*

  Here is a little demonstration program.

  Assuming you are using Boehm GC, compile this source file with

      patscc -O2 -DATS_MEMALLOC_GCBDW avl_trees-postiats.dats -lgc

  and run it with

      ./a.out

*)

%{^
#include <time.h>

ATSinline() atstype_uint64
get_the_time (void)
{
  return (atstype_uint64) time (NULL);
}
%}

(* An implementation of avl_t$compare for keys of type ‘int’. *)
implement
avl_t$compare<int> (u, v) =
  if u < v then
    ~1
  else if u > v then
    1
  else
    0

(* An implementation of avl_t_pretty_print$key_and_data for keys of
   type ‘int’ and values of type ‘double’. *)
implement
avl_t_pretty_print$key_and_data<int><double> (key, data) =
  print! ("(", key, ", ", data, ")")

implement
main0 () =
  let
    (* A linear congruential random number generator attributed
       to Donald Knuth. *)
    fn
    next_random (seed : &uint64) : uint64 =
      let
        val a : uint64 = $UNSAFE.cast 6364136223846793005ULL
        val c : uint64 = $UNSAFE.cast 1442695040888963407ULL
        val retval = seed
      in
        seed := (a * seed) + c;
        retval
      end

    fn {t : t@ype}
    fisher_yates_shuffle
              {n    : nat}
              (a    : &(@[t][n]),
               n    : size_t n,
               seed : &uint64) : void =
      let
        var i : [i : nat | i <= n] size_t i
      in
        for (i := i2sz 0; i < n; i := succ i)
          let
            val randnum = $UNSAFE.cast{Size_t} (next_random seed)
            val j = randnum mod n (* This is good enough for us. *)
            val xi = a[i]
            val xj = a[j]
          in
            a[i] := xj;
            a[j] := xi
          end
      end

    var seed : uint64 = $extfcall (uint64, "get_the_time")
    
    #define N 20
    var keys : @[int][N] = @[int][N] (0)

    var a : avl_t (int, double)
    var a_saved : avl_t (int, double)
    var a1 : (avl_t (int, double), bool)

    var i : [i : nat] int i

    val dflt = ~99999999.0
    val not_dflt = 123456789.0
  in
    println! ("----------------------------------------------------");
    print! ("\n");

    (* Initialize a shuffled array of keys. *)
    for (i := 0; i < N; i := succ i)
      keys[i] := succ i;
    fisher_yates_shuffle<int> {N} (keys, i2sz N, seed);

    print! ("The keys\n ");
    for (i := 0; i < N; i := succ i)
      print! (" ", keys[i]);
    print! ("\n");

    print! ("\nRunning some tests... ");

    (* Insert key-data pairs in the shuffled order, checking aspects
       of the implementation while doing so. *)
    a := avl_t_nil ();
    for (i := 0; i < N; i := succ i)
      let
        var j : [j : nat] int j
      in
        a := avl_t_insert<int> (a, keys[i], g0i2f keys[i]);
        avl_t_check_avl_condition (a);
        assertloc (avl_t_size a = succ i);
        assertloc (avl_t_is_empty a = iseqz (avl_t_size a));
        assertloc (avl_t_isnot_empty a = isneqz (avl_t_size a));
        a := avl_t_insert<int> (a, keys[i], not_dflt);
        avl_t_check_avl_condition (a);
        assertloc (avl_t_search<int><double> (a, keys[i], dflt)
                      = not_dflt);
        assertloc (avl_t_size a = succ i);
        assertloc (avl_t_is_empty a = iseqz (avl_t_size a));
        assertloc (avl_t_isnot_empty a = isneqz (avl_t_size a));
        a := avl_t_insert<int> (a, keys[i], g0i2f keys[i]);
        avl_t_check_avl_condition (a);
        assertloc (avl_t_size a = succ i);
        assertloc (avl_t_is_empty a = iseqz (avl_t_size a));
        assertloc (avl_t_isnot_empty a = isneqz (avl_t_size a));
        for (j := 0; j < N; j := succ j)
          let
            val k = keys[j]
            val has_key = avl_t_has_key<int> (a, k)
            val data_opt = avl_t_search<int><double> (a, k)
            val data_dflt = avl_t_search<int><double> (a, k, dflt)
          in
            assertloc (has_key = (j <= i));
            assertloc (option_is_some data_opt = (j <= i));
            if (j <= i) then
              let
                val- Some data = data_opt
              in
                assertloc (data = g0i2f k);
                assertloc (data_dflt = g0i2f k);
              end
            else
              let
                val- None () = data_opt
              in
                assertloc (data_dflt = dflt);
              end
          end
      end;

    (* Do it again, but using avl_t_insert_or_replace and checking its
       second return value. *)
    a1 := (avl_t_nil (), false);
    for (i := 0; i < N; i := succ i)
      let
        var j : [j : nat] int j
      in
        a1 :=
          avl_t_insert_or_replace<int> (a1.0, keys[i], g0i2f keys[i]);
        avl_t_check_avl_condition (a1.0);
        assertloc (~(a1.1));
        assertloc (avl_t_size (a1.0) = succ i);
        assertloc (avl_t_is_empty a1.0 = iseqz (avl_t_size a1.0));
        assertloc (avl_t_isnot_empty a1.0 = isneqz (avl_t_size a1.0));
        a1 := avl_t_insert_or_replace<int> (a1.0, keys[i], not_dflt);
        avl_t_check_avl_condition (a1.0);
        assertloc (avl_t_search<int><double> (a1.0, keys[i], dflt)
                      = not_dflt);
        assertloc (avl_t_size (a1.0) = succ i);
        assertloc (avl_t_is_empty a1.0 = iseqz (avl_t_size a1.0));
        assertloc (avl_t_isnot_empty a1.0 = isneqz (avl_t_size a1.0));
        a1 :=
          avl_t_insert_or_replace<int> (a1.0, keys[i], g0i2f keys[i]);
        avl_t_check_avl_condition (a1.0);
        assertloc (a1.1);
        assertloc (avl_t_size (a1.0) = succ i);
        assertloc (avl_t_is_empty a1.0 = iseqz (avl_t_size a1.0));
        assertloc (avl_t_isnot_empty a1.0 = isneqz (avl_t_size a1.0));
        for (j := 0; j < N; j := succ j)
          let
            val k = keys[j]
            val has_key = avl_t_has_key<int> (a1.0, k)
            val data_opt = avl_t_search<int><double> (a1.0, k)
            val data_dflt = avl_t_search<int><double> (a1.0, k, dflt)
          in
            assertloc (has_key = (j <= i));
            assertloc (option_is_some data_opt = (j <= i));
            if (j <= i) then
              let
                val- Some data = data_opt
              in
                assertloc (data = g0i2f k);
                assertloc (data_dflt = g0i2f k);
              end
            else
              let
                val- None () = data_opt
              in
                assertloc (data_dflt = dflt);
              end
          end
      end;
    a := a1.0;

    (* The trees are PERSISTENT, so SAVE THE CURRENT VALUE! *)
    a_saved := a;

    (* Reshuffle the keys, and test deletion, using the reshuffled
       keys. *)
    fisher_yates_shuffle<int> {N} (keys, i2sz N, seed);
    for (i := 0; i < N; i := succ i)
      let
        val ix = keys[i]
        var j : [j : nat] int j
      in
        a := avl_t_delete<int> (a, ix);
        avl_t_check_avl_condition (a);
        assertloc (avl_t_size a = N - succ i);
        assertloc (avl_t_is_empty a = iseqz (avl_t_size a));
        assertloc (avl_t_isnot_empty a = isneqz (avl_t_size a));
        a := avl_t_delete<int> (a, ix);
        avl_t_check_avl_condition (a);
        assertloc (avl_t_size a = N - succ i);
        assertloc (avl_t_is_empty a = iseqz (avl_t_size a));
        assertloc (avl_t_isnot_empty a = isneqz (avl_t_size a));
        for (j := 0; j < N; j := succ j)
          let
            val k = keys[j]
            val has_key = avl_t_has_key<int> (a, k)
            val data_opt = avl_t_search<int><double> (a, k)
            val data_dflt = avl_t_search<int><double> (a, k, dflt)
          in
            assertloc (has_key = (i < j));
            assertloc (option_is_some data_opt = (i < j));
            if (i < j) then
              let
                val- Some data = data_opt
              in
                assertloc (data = g0i2f k);
                assertloc (data_dflt = g0i2f k);
              end
            else
              let
                val- None () = data_opt
              in
                assertloc (data_dflt = dflt);
              end
          end
      end;

    (* Get back the PERSISTENT VALUE from before the deletions. *)
    a := a_saved;

    (* Reshuffle the keys, and test deletion again, this time using 
       avl_t_delete_if_found. *)
    fisher_yates_shuffle<int> {N} (keys, i2sz N, seed);
    for (i := 0; i < N; i := succ i)
      let
        val ix = keys[i]
        var j : [j : nat] int j
      in
        a1 := avl_t_delete_if_found<int> (a, ix);
        a := a1.0;
        avl_t_check_avl_condition (a);
        assertloc (a1.1);
        assertloc (avl_t_size a = N - succ i);
        assertloc (avl_t_is_empty a = iseqz (avl_t_size a));
        assertloc (avl_t_isnot_empty a = isneqz (avl_t_size a));
        a1 := avl_t_delete_if_found<int> (a, ix);
        a := a1.0;
        avl_t_check_avl_condition (a);
        assertloc (~(a1.1));
        assertloc (avl_t_size a = N - succ i);
        assertloc (avl_t_is_empty a = iseqz (avl_t_size a));
        assertloc (avl_t_isnot_empty a = isneqz (avl_t_size a));
        for (j := 0; j < N; j := succ j)
          let
            val k = keys[j]
            val has_key = avl_t_has_key<int> (a, k)
            val data_opt = avl_t_search<int><double> (a, k)
            val data_dflt = avl_t_search<int><double> (a, k, dflt)
          in
            assertloc (has_key = (i < j));
            assertloc (option_is_some data_opt = (i < j));
            if (i < j) then
              let
                val- Some data = data_opt
              in
                assertloc (data = g0i2f k);
                assertloc (data_dflt = g0i2f k);
              end
            else
              let
                val- None () = data_opt
              in
                assertloc (data_dflt = dflt);
              end
          end
      end;

    print! ("passed\n");

    (* Get back the PERSISTENT VALUE from before the deletions. *)
    a := a_saved;

    print! ("\n");
    println! ("----------------------------------------------------");
    print! ("\n");
    print! ("*** PRETTY-PRINTING OF THE TREE ***\n\n");

    avl_t_pretty_print<int><double> a;

    print! ("\n");
    println! ("----------------------------------------------------");
    print! ("\n");
    print! ("*** GENERATORS ***\n\n");

    let
      val gen = avl_t_make_pairs_generator (a, 1)
      var x : Option @(int, double)
    in
      print! ("Association pairs in order\n ");
      for (x := gen (); option_is_some (x); x := gen ())
        let
          val @(k, d) = option_unsome x
        in
          print! (" (", k : int, ", ", d : double, ")")
        end
    end;

    print! ("\n\n");

    let
      val gen = avl_t_make_pairs_generator (a, ~1)
      var x : Option @(int, double)
    in
      print! ("Association pairs in reverse order\n ");
      for (x := gen (); option_is_some (x); x := gen ())
        let
          val @(k, d) = option_unsome x
        in
          print! (" (", k : int, ", ", d : double, ")")
        end
    end;

    print! ("\n\n");

    let
      val gen = avl_t_make_keys_generator (a, 1)
      var x : Option int
    in
      print! ("Keys in order\n ");
      for (x := gen (); option_is_some (x); x := gen ())
        print! (" ", (option_unsome x) : int)
    end;

    print! ("\n\n");

    let
      val gen = avl_t_make_keys_generator (a, ~1)
      var x : Option int
    in
      print! ("Keys in reverse order\n ");
      for (x := gen (); option_is_some (x); x := gen ())
        print! (" ", (option_unsome x) : int)
    end;

    print! ("\n\n");

    let
      val gen = avl_t_make_data_generator (a, 1)
      var x : Option double
    in
      print! ("Data values in order of their keys\n ");
      for (x := gen (); option_is_some (x); x := gen ())
        print! (" ", (option_unsome x) : double)
    end;

    print! ("\n\n");

    let
      val gen = avl_t_make_data_generator (a, ~1)
      var x : Option double
    in
      print! ("Data values in reverse order of their keys\n ");
      for (x := gen (); option_is_some (x); x := gen ())
        print! (" ", (option_unsome x) : double)
    end;

    print! ("\n");

    print! ("\n");
    println! ("----------------------------------------------------");
    print! ("\n");
    print! ("*** AVL TREES TO LISTS ***\n\n");

    print! ("Association pairs in order\n  ");
    print! (avl_t_pairs<int><double> a);

    print! ("\n\n");

    print! ("Keys in order\n  ");
    print! (avl_t_keys<int> a);
    print! ("\n\n");

    print! ("Data values in order of their keys\n  ");
    print! (avl_t_data<int><double> a);
    print! ("\n");

    print! ("\n");
    println! ("----------------------------------------------------");
    print! ("\n");
    print! ("*** LISTS TO AVL TREES ***\n\n");

    let
      val lst = (3, 3.0) :: (1, 1.0) :: (4, 4.0) :: (2, 2.0) :: LNIL
      val avl = list2avl_t<int><double> lst
    in
      print! (lst : List @(int, double));
      print! ("\n\n  =>\n\n");
      avl_t_pretty_print<int><double> avl
    end;

    print! ("\n");
    println! ("----------------------------------------------------")
  end

(*------------------------------------------------------------------*)
Output:

The demonstration is randomized, so the following is just a sample output.

(You could compile with ‘-DATS_MEMALLOC_LIBC’ and leave out the ‘-lgc’. Then the heap memory used will simply be recovered only when the program ends.)

$ patscc -O2 -DATS_MEMALLOC_GCBDW avl_trees-postiats.dats -lgc
----------------------------------------------------

The keys
  13 16 3 4 5 12 7 18 17 6 11 10 1 20 15 2 9 14 19 8

Running some tests... passed

----------------------------------------------------

*** PRETTY-PRINTING OF THE TREE ***

    (1, 1.000000)		depth = 2 bal = 1
      (2, 2.000000)		depth = 3 bal = 0
  (3, 3.000000)		depth = 1 bal = 0
      (4, 4.000000)		depth = 3 bal = 0
    (5, 5.000000)		depth = 2 bal = 0
      (6, 6.000000)		depth = 3 bal = 0
(7, 7.000000)		depth = 0  bal = 1
        (8, 8.000000)		depth = 4 bal = 0
      (9, 9.000000)		depth = 3 bal = 0
        (10, 10.000000)		depth = 4 bal = 0
    (11, 11.000000)		depth = 2 bal = -1
      (12, 12.000000)		depth = 3 bal = 0
  (13, 13.000000)		depth = 1 bal = 0
        (14, 14.000000)		depth = 4 bal = 0
      (15, 15.000000)		depth = 3 bal = 0
        (16, 16.000000)		depth = 4 bal = 0
    (17, 17.000000)		depth = 2 bal = 0
        (18, 18.000000)		depth = 4 bal = 0
      (19, 19.000000)		depth = 3 bal = 0
        (20, 20.000000)		depth = 4 bal = 0

----------------------------------------------------

*** GENERATORS ***

Association pairs in order
  (1, 1.000000) (2, 2.000000) (3, 3.000000) (4, 4.000000) (5, 5.000000) (6, 6.000000) (7, 7.000000) (8, 8.000000) (9, 9.000000) (10, 10.000000) (11, 11.000000) (12, 12.000000) (13, 13.000000) (14, 14.000000) (15, 15.000000) (16, 16.000000) (17, 17.000000) (18, 18.000000) (19, 19.000000) (20, 20.000000)

Association pairs in reverse order
  (20, 20.000000) (19, 19.000000) (18, 18.000000) (17, 17.000000) (16, 16.000000) (15, 15.000000) (14, 14.000000) (13, 13.000000) (12, 12.000000) (11, 11.000000) (10, 10.000000) (9, 9.000000) (8, 8.000000) (7, 7.000000) (6, 6.000000) (5, 5.000000) (4, 4.000000) (3, 3.000000) (2, 2.000000) (1, 1.000000)

Keys in order
  1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20

Keys in reverse order
  20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1

Data values in order of their keys
  1.000000 2.000000 3.000000 4.000000 5.000000 6.000000 7.000000 8.000000 9.000000 10.000000 11.000000 12.000000 13.000000 14.000000 15.000000 16.000000 17.000000 18.000000 19.000000 20.000000

Data values in reverse order of their keys
  20.000000 19.000000 18.000000 17.000000 16.000000 15.000000 14.000000 13.000000 12.000000 11.000000 10.000000 9.000000 8.000000 7.000000 6.000000 5.000000 4.000000 3.000000 2.000000 1.000000

----------------------------------------------------

*** AVL TREES TO LISTS ***

Association pairs in order
  (1, 1.000000), (2, 2.000000), (3, 3.000000), (4, 4.000000), (5, 5.000000), (6, 6.000000), (7, 7.000000), (8, 8.000000), (9, 9.000000), (10, 10.000000), (11, 11.000000), (12, 12.000000), (13, 13.000000), (14, 14.000000), (15, 15.000000), (16, 16.000000), (17, 17.000000), (18, 18.000000), (19, 19.000000), (20, 20.000000)

Keys in order
  1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20

Data values in order of their keys
  1.000000, 2.000000, 3.000000, 4.000000, 5.000000, 6.000000, 7.000000, 8.000000, 9.000000, 10.000000, 11.000000, 12.000000, 13.000000, 14.000000, 15.000000, 16.000000, 17.000000, 18.000000, 19.000000, 20.000000

----------------------------------------------------

*** LISTS TO AVL TREES ***

(3, 3.000000), (1, 1.000000), (4, 4.000000), (2, 2.000000)

  =>

  (1, 1.000000)		depth = 1 bal = 1
    (2, 2.000000)		depth = 2 bal = 0
(3, 3.000000)		depth = 0  bal = -1
  (4, 4.000000)		depth = 1 bal = 0

----------------------------------------------------

C

See AVL tree/C

C#

See AVL_tree/C_sharp.

C++

Translation of: D
#include <algorithm>
#include <iostream>

/* AVL node */
template <class T>
class AVLnode {
public:
    T key;
    int balance;
    AVLnode *left, *right, *parent;

    AVLnode(T k, AVLnode *p) : key(k), balance(0), parent(p),
                        left(NULL), right(NULL) {}

    ~AVLnode() {
        delete left;
        delete right;
    }
};

/* AVL tree */
template <class T>
class AVLtree {
public:
    AVLtree(void);
    ~AVLtree(void);
    bool insert(T key);
    void deleteKey(const T key);
    void printBalance();

private:
    AVLnode<T> *root;

    AVLnode<T>* rotateLeft          ( AVLnode<T> *a );
    AVLnode<T>* rotateRight         ( AVLnode<T> *a );
    AVLnode<T>* rotateLeftThenRight ( AVLnode<T> *n );
    AVLnode<T>* rotateRightThenLeft ( AVLnode<T> *n );
    void rebalance                  ( AVLnode<T> *n );
    int height                      ( AVLnode<T> *n );
    void setBalance                 ( AVLnode<T> *n );
    void printBalance               ( AVLnode<T> *n );
};

/* AVL class definition */
template <class T>
void AVLtree<T>::rebalance(AVLnode<T> *n) {
    setBalance(n);

    if (n->balance == -2) {
        if (height(n->left->left) >= height(n->left->right))
            n = rotateRight(n);
        else
            n = rotateLeftThenRight(n);
    }
    else if (n->balance == 2) {
        if (height(n->right->right) >= height(n->right->left))
            n = rotateLeft(n);
        else
            n = rotateRightThenLeft(n);
    }

    if (n->parent != NULL) {
        rebalance(n->parent);
    }
    else {
        root = n;
    }
}

template <class T>
AVLnode<T>* AVLtree<T>::rotateLeft(AVLnode<T> *a) {
    AVLnode<T> *b = a->right;
    b->parent = a->parent;
    a->right = b->left;

    if (a->right != NULL)
        a->right->parent = a;

    b->left = a;
    a->parent = b;

    if (b->parent != NULL) {
        if (b->parent->right == a) {
            b->parent->right = b;
        }
        else {
            b->parent->left = b;
        }
    }

    setBalance(a);
    setBalance(b);
    return b;
}

template <class T>
AVLnode<T>* AVLtree<T>::rotateRight(AVLnode<T> *a) {
    AVLnode<T> *b = a->left;
    b->parent = a->parent;
    a->left = b->right;

    if (a->left != NULL)
        a->left->parent = a;

    b->right = a;
    a->parent = b;

    if (b->parent != NULL) {
        if (b->parent->right == a) {
            b->parent->right = b;
        }
        else {
            b->parent->left = b;
        }
    }

    setBalance(a);
    setBalance(b);
    return b;
}

template <class T>
AVLnode<T>* AVLtree<T>::rotateLeftThenRight(AVLnode<T> *n) {
    n->left = rotateLeft(n->left);
    return rotateRight(n);
}

template <class T>
AVLnode<T>* AVLtree<T>::rotateRightThenLeft(AVLnode<T> *n) {
    n->right = rotateRight(n->right);
    return rotateLeft(n);
}

template <class T>
int AVLtree<T>::height(AVLnode<T> *n) {
    if (n == NULL)
        return -1;
    return 1 + std::max(height(n->left), height(n->right));
}

template <class T>
void AVLtree<T>::setBalance(AVLnode<T> *n) {
    n->balance = height(n->right) - height(n->left);
}

template <class T>
void AVLtree<T>::printBalance(AVLnode<T> *n) {
    if (n != NULL) {
        printBalance(n->left);
        std::cout << n->balance << " ";
        printBalance(n->right);
    }
}

template <class T>
AVLtree<T>::AVLtree(void) : root(NULL) {}

template <class T>
AVLtree<T>::~AVLtree(void) {
    delete root;
}

template <class T>
bool AVLtree<T>::insert(T key) {
    if (root == NULL) {
        root = new AVLnode<T>(key, NULL);
    }
    else {
        AVLnode<T>
            *n = root,
            *parent;

        while (true) {
            if (n->key == key)
                return false;

            parent = n;

            bool goLeft = n->key > key;
            n = goLeft ? n->left : n->right;

            if (n == NULL) {
                if (goLeft) {
                    parent->left = new AVLnode<T>(key, parent);
                }
                else {
                    parent->right = new AVLnode<T>(key, parent);
                }

                rebalance(parent);
                break;
            }
        }
    }

    return true;
}

template <class T>
void AVLtree<T>::deleteKey(const T delKey) {
    if (root == NULL)
        return;

    AVLnode<T>
        *n       = root,
        *parent  = root,
        *delNode = NULL,
        *child   = root;

    while (child != NULL) {
        parent = n;
        n = child;
        child = delKey >= n->key ? n->right : n->left;
        if (delKey == n->key)
            delNode = n;
    }

    if (delNode != NULL) {
        delNode->key = n->key;

        child = n->left != NULL ? n->left : n->right;

        if (root->key == delKey) {
            root = child;
        }
        else {
            if (parent->left == n) {
                parent->left = child;
            }
            else {
                parent->right = child;
            }

            rebalance(parent);
        }
    }
}

template <class T>
void AVLtree<T>::printBalance() {
    printBalance(root);
    std::cout << std::endl;
}

int main(void)
{
    AVLtree<int> t;

    std::cout << "Inserting integer values 1 to 10" << std::endl;
    for (int i = 1; i <= 10; ++i)
        t.insert(i);

    std::cout << "Printing balance: ";
    t.printBalance();
}
Output:
Inserting integer values 1 to 10
Printing balance: 0 0 0 1 0 0 0 0 1 0 

More elaborate version

See AVL_tree/C++

C++/CLI

See AVL_tree/Managed_C++

Common Lisp

Provided is an imperative implementation of an AVL tree with a similar interface and documentation to HASH-TABLE.

(defpackage :avl-tree
  (:use :cl)
  (:export
   :avl-tree
   :make-avl-tree
   :avl-tree-count
   :avl-tree-p
   :avl-tree-key<=
   :gettree
   :remtree
   :clrtree
   :dfs-maptree
   :bfs-maptree))

(in-package :avl-tree)

(defstruct %tree
  key
  value
  (height 0 :type fixnum)
  left
  right)

(defstruct (avl-tree (:constructor %make-avl-tree))
  key<=
  tree
  (count 0 :type fixnum))

(defun make-avl-tree (key<=)
  "Create a new AVL tree using the given comparison function KEY<=
for emplacing keys into the tree."
  (%make-avl-tree :key<= key<=))

(declaim (inline
          recalc-height
          height balance
          swap-kv
          right-right-rotate
          right-left-rotate
          left-right-rotate
          left-left-rotate
          rotate))

(defun recalc-height (tree)
  "Calculate the new height of the tree from the heights of the children."
  (when tree
    (setf (%tree-height tree)
          (1+ (the fixnum (max (height (%tree-right tree))
                               (height (%tree-left tree))))))))

(declaim (ftype (function (t) fixnum) height balance))
(defun height (tree)
  (if tree (%tree-height tree) 0))

(defun balance (tree)
  (if tree
      (- (height (%tree-right tree))
         (height (%tree-left tree)))
      0))

(defmacro swap (place-a place-b)
  "Swap the values of two places."
  (let ((tmp (gensym)))
    `(let ((,tmp ,place-a))
       (setf ,place-a ,place-b)
       (setf ,place-b ,tmp))))

(defun swap-kv (tree-a tree-b)
  "Swap the keys and values of two trees."
  (swap (%tree-value tree-a) (%tree-value tree-b))
  (swap (%tree-key tree-a) (%tree-key tree-b)))

;; We should really use gensyms for the variables in here.
(defmacro slash-rotate (tree right left)
  "Rotate nodes in a slash `/` imbalance."
  `(let* ((a ,tree)
          (b (,right a))
          (c (,right b))
          (a-left (,left a))
          (b-left (,left b)))
     (setf (,right a) c)
     (setf (,left a) b)
     (setf (,left b) a-left)
     (setf (,right b) b-left)
     (swap-kv a b)
     (recalc-height b)
     (recalc-height a)))

(defmacro angle-rotate (tree right left)
  "Rotate nodes in an angle bracket `<` imbalance."
  `(let* ((a ,tree)
          (b (,right a))
          (c (,left b))
          (a-left (,left a))
          (c-left (,left c))
          (c-right (,right c)))
     (setf (,left a) c)
     (setf (,left c) a-left)
     (setf (,right c) c-left)
     (setf (,left b) c-right)
     (swap-kv a c)
     (recalc-height c)
     (recalc-height b)
     (recalc-height a)))

(defun right-right-rotate (tree)
  (slash-rotate tree %tree-right %tree-left))

(defun left-left-rotate (tree)
  (slash-rotate tree %tree-left %tree-right))

(defun right-left-rotate (tree)
  (angle-rotate tree %tree-right %tree-left))

(defun left-right-rotate (tree)
  (angle-rotate tree %tree-left %tree-right))

(defun rotate (tree)
  (declare (type %tree tree))
  "Perform a rotation on the given TREE if it is imbalanced."
  (recalc-height tree)
  (with-slots (left right) tree
    (let ((balance (balance tree)))
      (cond ((< 1 balance) ;; Right imbalanced tree
             (if (<= 0 (balance right))
                 (right-right-rotate tree)
                 (right-left-rotate tree)))
            ((> -1 balance) ;; Left imbalanced tree
             (if (<= 0 (balance left))
                 (left-right-rotate tree)
                 (left-left-rotate tree)))))))

(defun gettree (key avl-tree &optional default)
  "Finds an entry in AVL-TREE whos key is KEY and returns the
associated value and T as multiple values, or returns DEFAULT and NIL
if there was no such entry. Entries can be added using SETF."
  (with-slots (key<= tree) avl-tree
    (labels
        ((rec (tree)
           (if tree
               (with-slots ((t-key key) left right value) tree
                 (if (funcall key<= t-key key)
                     (if (funcall key<= key t-key)
                         (values value t)
                         (rec right))
                     (rec left)))
               (values default nil))))
      (rec tree))))

(defun puttree (value key avl-tree)
  ;;(declare (optimize speed))
  (declare (type avl-tree avl-tree))
  "Emplace the the VALUE with the given KEY into the AVL-TREE, or
overwrite the value if the given key already exists."
  (let ((node (make-%tree :key key :value value)))
    (with-slots (key<= tree count) avl-tree
      (cond (tree
             (labels
                 ((rec (tree)
                    (with-slots ((t-key key) left right) tree
                      (if (funcall key<= t-key key)
                          (if (funcall key<= key t-key)
                              (setf (%tree-value tree) value)
                              (cond (right (rec right))
                                    (t (setf right node)
                                       (incf count))))
                          (cond (left (rec left))
                                (t (setf left node)
                                   (incf count))))
                      (rotate tree))))
               (rec tree)))
            (t (setf tree node)
               (incf count))))
    value))

(defun (setf gettree) (value key avl-tree &optional default)
  (declare (ignore default))
  (puttree value key avl-tree))

(defun remtree (key avl-tree)
  (declare (type avl-tree avl-tree))
  "Remove the entry in AVL-TREE associated with KEY. Return T if
there was such an entry, or NIL if not."
  (with-slots (key<= tree count) avl-tree
    (labels
        ((find-left (tree)
           (with-slots ((t-key key) left right) tree
             (if left
                 (find-left left)
                 tree)))
         (rec (tree &optional parent type)
           (when tree
             (prog1
                 (with-slots ((t-key key) left right) tree
                   (if (funcall key<= t-key key)
                       (cond
                         ((funcall key<= key t-key)
                          (cond
                            ((and left right)
                             (let ((sub-left (find-left right)))
                               (swap-kv sub-left tree)
                               (rec right tree :right)))
                            (t
                             (let ((sub (or left right)))
                               (case type
                                 (:right (setf (%tree-right parent) sub))
                                 (:left (setf (%tree-left parent) sub))
                                 (nil (setf (avl-tree-tree avl-tree) sub))))
                             (decf count)))
                          t)
                         (t (rec right tree :right)))
                       (rec left tree :left)))
               (when parent (rotate parent))))))
      (rec tree))))

(defun clrtree (avl-tree)
  "This removes all the entries from AVL-TREE and returns the tree itself."
  (setf (avl-tree-tree avl-tree) nil)
  (setf (avl-tree-count avl-tree) 0)
  avl-tree)

(defun dfs-maptree (function avl-tree)
  "For each entry in AVL-TREE call the two-argument FUNCTION on
the key and value of each entry in depth-first order from left to right.
Consequences are undefined if AVL-TREE is modified during this call."
  (with-slots (key<= tree) avl-tree
    (labels
        ((rec (tree)
           (when tree
             (with-slots ((t-key key) left right key value) tree
               (rec left)
               (funcall function key value)
               (rec right)))))
      (rec tree))))

(defun bfs-maptree (function avl-tree)
  "For each entry in AVL-TREE call the two-argument FUNCTION on
the key and value of each entry in breadth-first order from left to right.
Consequences are undefined if AVL-TREE is modified during this call."
  (with-slots (key<= tree) avl-tree
    (let* ((queue (cons nil nil))
           (end queue))
      (labels ((pushend (value)
                 (when value
                   (setf (cdr end) (cons value nil))
                   (setf end (cdr end))))
               (empty-p () (eq nil (cdr queue)))
               (popfront ()
                 (prog1 (pop (cdr queue))
                   (when (empty-p) (setf end queue)))))
        (when tree
          (pushend tree)
          (loop until (empty-p)
             do (let ((current (popfront)))
                  (with-slots (key value left right) current
                    (funcall function key value)
                    (pushend left)
                    (pushend right)))))))))

(defun test ()
  (let ((tree (make-avl-tree #'<=))
        (printer (lambda (k v) (print (list k v)))))
    (loop for key in '(0 8 6 4 2 3 7 9 1 5 5)
       for value in '(a b c d e f g h i j k)
       do (setf (gettree key tree) value))
    (loop for key in '(0 1 2 3 4 10)
       do (print (multiple-value-list (gettree key tree))))
    (terpri)
    (print tree)
    (terpri)
    (dfs-maptree printer tree)
    (terpri)
    (bfs-maptree printer tree)
    (terpri)
    (loop for key in '(0 1 2 3 10 7)
       do (print (remtree key tree)))
    (terpri)
    (print tree)
    (terpri)
    (clrtree tree)
    (print tree))
  (values))

(defun profile-test ()
  (let ((tree (make-avl-tree #'<=))
        (randoms (loop repeat 1000000 collect (random 100.0))))
    (loop for key in randoms do (setf (gettree key tree) key))))

Component Pascal

Two modules are provided - one for implementing and one for using AVL trees

MODULE RosettaAVLTrees;

	(* An implementation of persistent AVL Trees *)

	TYPE
		Order = ABSTRACT RECORD END;
		Tree* = POINTER TO Node;
		Node* = ABSTRACT RECORD (Order)
			left, right: Tree;
			height: INTEGER
		END; (* Contains the left and right child nodes and the height of the node *)

		Out* = ABSTRACT RECORD END; (* Used for output by the `Draw` procedure *)

		Void = RECORD (Order) END; (* Used by the `Ordered` procedure *)

	(* The following abstract procedures must be implemented by a user of `Node` *)
	(* They must be implemented correctly for the AVL tree to work *)

	(* Compares one node with another and returns a boolean value based on which is less *)
	PROCEDURE (IN n: Order) Less- (IN m: Node): BOOLEAN, NEW, ABSTRACT;
	(* Compares one node with another and returns a boolean value based on which is more *)
	PROCEDURE (IN n: Order) More- (IN m: Node): BOOLEAN, NEW, ABSTRACT;
	(* Creates a new root node *)
	PROCEDURE (IN n: Node) Alloc- (): Tree, NEW, ABSTRACT;

	(* Returns TRUE if n is in the tree t, FALSE otherwise *)
	PROCEDURE (IN n: Node) Lookup* (t: Tree): BOOLEAN, NEW;
	BEGIN
		IF t = NIL THEN RETURN FALSE END;
		IF n.Less(t) THEN RETURN n.Lookup(t.left) END;
		IF n.More(t) THEN RETURN n.Lookup(t.right) END;
		RETURN TRUE
	END Lookup;

	(* Returns the height of the AVL tree t *)
	PROCEDURE Height (t: Tree): INTEGER;
	BEGIN
		IF t = NIL THEN RETURN 0 END;
		RETURN t.height
	END Height;

	(* Creates and returns a new Node with the given children *)
	PROCEDURE (IN n: Node) New (left, right: Tree): Tree, NEW;
		VAR t: Tree;
	BEGIN
		t := n.Alloc(); (* Create a new root node *)
		t.left := left; t.right := right; (* set the children *)
		(* set the height of the node based on its children *)
		t.height := MAX(Height(left), Height(right)) + 1;
		RETURN t
	END New;

	(* Returns the difference in height between the left and right children of a node *)
	PROCEDURE Slope (l, r: Tree): INTEGER;
	BEGIN RETURN Height(l) - Height(r) END Slope;

	(* Returns an AVL tree if it is right-heavy *)
	PROCEDURE (IN n: Node) BalL (l, r: Tree): Tree, NEW;
	BEGIN
		IF Slope(l, r) =  - 2 THEN
			IF Slope(r.left, r.right) = 1 THEN
				RETURN r.left.New(n.New(l, r.left.left),
													r.New(r.left.right, r.right))
			END;
			RETURN r.New(n.New(l, r.left), r.right)
		END;
		RETURN n.New(l, r)
	END BalL;

	(* Returns an AVL tree if it is left-heavy *)
	PROCEDURE (IN n: Node) BalR (l, r: Tree): Tree, NEW;
	BEGIN
		IF Slope(l, r) = 2 THEN
			IF Slope(l.left, l.right) = - 1 THEN
				RETURN l.right.New(l.New(l.left, l.right.left),
													 n.New(l.right.right, r))
			END;
			RETURN l.New(l.left, n.New(l.right, r))
		END;
		RETURN n.New(l, r)
	END BalR;

	(* Returns the AVL tree t with the node n *)
	PROCEDURE (IN n: Node) Insert* (t: Tree): Tree, NEW;
	BEGIN
		IF t = NIL THEN RETURN n.New(NIL, NIL) END;
		IF n.Less(t) THEN RETURN t.BalR(n.Insert(t.left), t.right) END;
		IF n.More(t) THEN RETURN t.BalL(t.left, n.Insert(t.right)) END;
		RETURN t
	END Insert;

	(* Returns the leftmost node of the non-empty tree t *)
	PROCEDURE (t: Tree) Head (): Tree, NEW;
	BEGIN
		IF t.left = NIL THEN RETURN t END;
		RETURN t.left.Head()
	END Head;

	(* Returns the rightmost node of the non-empty tree t *)
	PROCEDURE (t: Tree) Last (): Tree, NEW;
	BEGIN
		IF t.right = NIL THEN RETURN t END;
		RETURN t.right.Last()
	END Last;

	(* Returns the AVL tree t without the leftmost node *)
	PROCEDURE (IN t: Node) Tail* (): Tree, NEW;
	BEGIN
		IF t.left = NIL THEN RETURN t.right END;
		RETURN t.BalL(t.left.Tail(), t.right)
	END Tail;

	(* Returns the AVL tree t without the rightmost node *)
	PROCEDURE (IN t: Node) Init* (): Tree, NEW;
	BEGIN
		IF t.right = NIL THEN RETURN t.left END;
		RETURN t.BalR(t.left, t.right.Init())
	END Init;

	(* Returns the AVL tree t without node n *)
	PROCEDURE (IN n: Node) Delete* (t: Tree): Tree, NEW;
	BEGIN
		IF t = NIL THEN RETURN NIL END;
		IF n.Less(t) THEN RETURN t.BalL(n.Delete(t.left), t.right) END;
		IF n.More(t) THEN RETURN t.BalR(t.left, n.Delete(t.right)) END;
		IF Slope(t.left, t.right) = 1 THEN
			RETURN t.left.Last().BalL(t.left.Init(), t.right)
		END;
		IF t.right = NIL THEN RETURN t.left END;
		RETURN t.right.Head().BalR(t.left, t.right.Tail())
	END Delete;

	(* The following procedures are used for debugging *)

	PROCEDURE (IN n: Void) Less- (IN m: Node): BOOLEAN;
	BEGIN RETURN TRUE END Less;

	PROCEDURE (IN n: Void) More- (IN m: Node): BOOLEAN;
	BEGIN RETURN TRUE END More;

	(* Returns TRUE if the AVL tree t is ordered, FALSE otherwise *)
	PROCEDURE Ordered* (t: Tree): BOOLEAN;
		VAR void: Void;

		PROCEDURE Bounded (IN lo, hi: Order; t: Tree): BOOLEAN;
		BEGIN
			IF t = NIL THEN RETURN TRUE END;
			RETURN lo.Less(t) & hi.More(t) & 
						 Bounded(lo, t, t.left) & Bounded(t, hi, t.right)
		END Bounded;

	BEGIN RETURN Bounded(void, void, t) END Ordered;

	(* The following abstract procedures must be implemented by a user of `Out` *)

	(* Writes a string *)
	PROCEDURE (IN o: Out) Str- (s: ARRAY OF CHAR), NEW, ABSTRACT;
	(* Writes an integer *)
	PROCEDURE (IN o: Out) Int- (i: INTEGER), NEW, ABSTRACT;
	(* Writes a  new-line *)
	PROCEDURE (IN o: Out) Ln-, NEW, ABSTRACT;
	(* Writes a  node *)
	PROCEDURE (IN o: Out) Node- (IN n: Node), NEW, ABSTRACT;

	(* Writes a tree (rotated) *)
	PROCEDURE (IN o: Out) Draw* (t: Tree), NEW;

		PROCEDURE Bars (bars, bar: ARRAY OF CHAR);
		BEGIN
			IF LEN(bars + bar) # 0 THEN o.Str(bars + "+--") END
		END Bars;

		PROCEDURE Do (lBar, rBar, bars: ARRAY OF CHAR; t: Tree);
		BEGIN
			IF t = NIL THEN Bars(bars, lBar); o.Str("|"); o.Ln
			ELSIF (t.left = NIL) & (t.right = NIL) THEN
				Bars(bars, lBar); o.Node(t); o.Ln
			ELSE
				Do("|  ", "   ", bars + rBar, t.right);
				o.Str(bars + rBar + "|"); o.Ln;
				Bars(bars, lBar); o.Node(t);
				IF Slope(t.left, t.right) # 0 THEN
					o.Str(" ["); o.Int(Slope(t.left, t.right)); o.Str("]")
				END;
				o.Ln;
				o.Str(bars + lBar + "|"); o.Ln;
				Do("   ", "|  ", bars + lBar, t.left)
			END
		END Do;

	BEGIN
		Do("", "", "", t)
	END Draw;

END RosettaAVLTrees.

Interface extracted from implementation:

DEFINITION RosettaAVLTrees;

	TYPE
		Tree = POINTER TO Node;
		Node = ABSTRACT RECORD (Order)
			(IN n: Node) Alloc- (): Tree, NEW, ABSTRACT;
			(IN n: Node) Delete (t: Tree): Tree, NEW;
			(IN t: Node) Init (): Tree, NEW;
			(IN n: Node) Insert (t: Tree): Tree, NEW;
			(IN n: Node) Lookup (t: Tree): BOOLEAN, NEW;
			(IN t: Node) Tail (): Tree, NEW
		END;

		Out = ABSTRACT RECORD 
			(IN o: Out) Draw (t: Tree), NEW;
			(IN o: Out) Int- (i: INTEGER), NEW, ABSTRACT;
			(IN o: Out) Ln-, NEW, ABSTRACT;
			(IN o: Out) Node- (IN n: Node), NEW, ABSTRACT;
			(IN o: Out) Str- (s: ARRAY OF CHAR), NEW, ABSTRACT
		END;

	PROCEDURE Ordered (t: Tree): BOOLEAN;

END RosettaAVLTrees.

Module that uses previous module:

MODULE RosettaAVLTreesUse;

	IMPORT Set := RosettaAVLTrees, Log := StdLog;

	TYPE
		Height = RECORD (Set.Node) height: INTEGER END;
		(* Note that Set.Node already contains an integer field `height`. *)
		(* It does not cause a duplicate field error as it is hidden from this module *)

		Out = RECORD (Set.Out) END; (* Used for output by the `Draw` procedure *)

	(* The following three procedures are implemented here for use by Set.Node *)

	(* Compares one node with another and returns a boolean value based on which is less *)
	PROCEDURE (IN h: Height) Less- (IN n: Set.Node): BOOLEAN;
	BEGIN RETURN h.height < n(Height).height END Less;

	(* Compares one node with another and returns a boolean value based on which is more *)
	PROCEDURE (IN h: Height) More- (IN n: Set.Node): BOOLEAN;
	BEGIN RETURN h.height > n(Height).height END More;

	(* Creates a new root node *)
	PROCEDURE (IN h: Height) Alloc- (): Set.Tree;
		VAR r: POINTER TO Height;
	BEGIN NEW(r); r.height := h.height; RETURN r END Alloc;

	(* The following four procedures are implemented here for use by Set.Out *)

	(* Writes a string *)
	PROCEDURE (IN o: Out) Str- (s: ARRAY OF CHAR);
	BEGIN Log.String(s) END Str;

	(* Writes an integer *)
	PROCEDURE (IN o: Out) Int- (i: INTEGER);
	BEGIN Log.IntForm(i, Log.decimal, 0, ' ', Log.hideBase) END Int;

	(* Writes a  new-line *)
	PROCEDURE (IN o: Out) Ln-; BEGIN Log.Ln END Ln;

	(* Writes a  node *)
	PROCEDURE (IN o: Out) Node- (IN n: Set.Node);
	BEGIN
		Log.IntForm(n(Height).height, Log.decimal, 0, ' ', Log.hideBase)
	END Node;

	PROCEDURE Use*;
		TYPE BAD = POINTER TO Height;
		VAR h: Height; hs, save: Set.Tree; i: INTEGER; o: Out;
	BEGIN
		h.height := 10; hs := h.Insert(hs);
		FOR i := 0 TO 9 DO h.height := i; hs := h.Insert(hs) END;
		o.Draw(hs); Log.Ln; Log.Ln;
		save := hs;
		FOR i := 0 TO 9 DO h.height := i; hs := h.Delete(hs) END;
		o.Draw(hs); Log.Ln; Log.Ln;
		o.Draw(save); Log.Ln; Log.Ln;  (* Tree demonstrates persistence *)
		ASSERT(Set.Ordered(save));  (* This ASSERT succeeds *)
		save(BAD).height := 11;  (* UNSAFE STATEMENT *)
		o.Draw(save);
		ASSERT(Set.Ordered(save))  (* This ASSERT fails *)
	END Use;

END RosettaAVLTreesUse.

Execute: ^Q RosettaAVLTreesUse.Use

Output:
      +--10
      |
   +--9
   |  |
   |  +--8
   |
+--7
|  |
|  |  +--6
|  |  |
|  +--5
|     |
|     +--4
|
3 [-1]
|
|  +--2
|  |
+--1
   |
   +--0


10


      +--10
      |
   +--9
   |  |
   |  +--8
   |
+--7
|  |
|  |  +--6
|  |  |
|  +--5
|     |
|     +--4
|
3 [-1]
|
|  +--2
|  |
+--1
   |
   +--0


      +--10
      |
   +--9
   |  |
   |  +--8
   |
+--7
|  |
|  |  +--6
|  |  |
|  +--5
|     |
|     +--4
|
11 [-1]
|
|  +--2
|  |
+--1
   |
   +--0

D

Translation of: Java
import std.stdio, std.algorithm;

class AVLtree {
    private Node* root;

    private static struct Node {
        private int key, balance;
        private Node* left, right, parent;

        this(in int k, Node* p) pure nothrow @safe @nogc {
            key = k;
            parent = p;
        }
    }

    public bool insert(in int key) pure nothrow @safe {
        if (root is null)
            root = new Node(key, null);
        else {
            Node* n = root;
            Node* parent;
            while (true) {
                if (n.key == key)
                    return false;

                parent = n;

                bool goLeft = n.key > key;
                n = goLeft ? n.left : n.right;

                if (n is null) {
                    if (goLeft) {
                        parent.left = new Node(key, parent);
                    } else {
                        parent.right = new Node(key, parent);
                    }
                    rebalance(parent);
                    break;
                }
            }
        }
        return true;
    }

    public void deleteKey(in int delKey) pure nothrow @safe @nogc {
        if (root is null)
            return;
        Node* n = root;
        Node* parent = root;
        Node* delNode = null;
        Node* child = root;

        while (child !is null) {
            parent = n;
            n = child;
            child = delKey >= n.key ? n.right : n.left;
            if (delKey == n.key)
                delNode = n;
        }

        if (delNode !is null) {
            delNode.key = n.key;

            child = n.left !is null ? n.left : n.right;

            if (root.key == delKey) {
                root = child;
            } else {
                if (parent.left is n) {
                    parent.left = child;
                } else {
                    parent.right = child;
                }
                rebalance(parent);
            }
        }
    }

    private void rebalance(Node* n) pure nothrow @safe @nogc {
        setBalance(n);

        if (n.balance == -2) {
            if (height(n.left.left) >= height(n.left.right))
                n = rotateRight(n);
            else
                n = rotateLeftThenRight(n);

        } else if (n.balance == 2) {
            if (height(n.right.right) >= height(n.right.left))
                n = rotateLeft(n);
            else
                n = rotateRightThenLeft(n);
        }

        if (n.parent !is null) {
            rebalance(n.parent);
        } else {
            root = n;
        }
    }

    private Node* rotateLeft(Node* a) pure nothrow @safe @nogc {
        Node* b = a.right;
        b.parent = a.parent;

        a.right = b.left;

        if (a.right !is null)
            a.right.parent = a;

        b.left = a;
        a.parent = b;

        if (b.parent !is null) {
            if (b.parent.right is a) {
                b.parent.right = b;
            } else {
                b.parent.left = b;
            }
        }

        setBalance(a, b);

        return b;
    }

    private Node* rotateRight(Node* a) pure nothrow @safe @nogc {
        Node* b = a.left;
        b.parent = a.parent;

        a.left = b.right;

        if (a.left !is null)
            a.left.parent = a;

        b.right = a;
        a.parent = b;

        if (b.parent !is null) {
            if (b.parent.right is a) {
                b.parent.right = b;
            } else {
                b.parent.left = b;
            }
        }

        setBalance(a, b);

        return b;
    }

    private Node* rotateLeftThenRight(Node* n) pure nothrow @safe @nogc {
        n.left = rotateLeft(n.left);
        return rotateRight(n);
    }

    private Node* rotateRightThenLeft(Node* n) pure nothrow @safe @nogc {
        n.right = rotateRight(n.right);
        return rotateLeft(n);
    }

    private int height(in Node* n) const pure nothrow @safe @nogc {
        if (n is null)
            return -1;
        return 1 + max(height(n.left), height(n.right));
    }

    private void setBalance(Node*[] nodes...) pure nothrow @safe @nogc {
        foreach (n; nodes)
            n.balance = height(n.right) - height(n.left);
    }

    public void printBalance() const @safe {
        printBalance(root);
    }

    private void printBalance(in Node* n) const @safe {
        if (n !is null) {
            printBalance(n.left);
            write(n.balance, ' ');
            printBalance(n.right);
        }
    }
}

void main() @safe {
    auto tree = new AVLtree();

    writeln("Inserting values 1 to 10");
    foreach (immutable i; 1 .. 11)
        tree.insert(i);

    write("Printing balance: ");
    tree.printBalance;
}
Output:
Inserting values 1 to 10
Printing balance: 0 0 0 1 0 0 0 0 1 0 

Emacs Lisp

Translation of: Java
(defvar avl-all-nodes (make-vector 100 nil))
(defvar avl-root-node nil "root node")

(defun avl-create-node (key parent)
  (copy-tree `((:key . ,key) (:balance . nil) (:height . nil)
	       (:left . nil) (:right . nil) (:parent . ,parent))))

(defun avl-node (pos)
  (if (or (null pos) (> pos (1- (length avl-all-nodes))))
      nil
    (aref avl-all-nodes pos)))

(defun avl-node-prop (noderef &rest props)
  (if (null noderef)
      nil
    (progn
      ;;(when (integerp noderef) (setq node (avl-node node)))
      (let ((val noderef))
        (dolist (prop props)
          (if (null (avl-node val))
	      (setq val nil)
	    (progn
	      (setq val (alist-get prop (avl-node val))))))
        val)
      )
    )
  )


(defun avl-set-prop (node &rest props-and-value)
  (when (integerp node) (setq node (avl-node node)))
  (when (< (length props-and-value) 2)
    (error "Both property name and value must be given."))
  (let (noderef (props (seq-take props-and-value (1- (length props-and-value))))
                (value (seq-elt props-and-value (1- (length props-and-value)))))
    (when (> (length props) 0)
      (dolist (prop (seq-take props (1- (length props))))
	(if (null node)
	    (progn (setq noderef nil) (setq node nil))
	  (progn
	    (setq noderef (alist-get prop node))
	    (setq node (avl-node noderef))))))
    
    (if (or (null (last props)) (null node))
	nil
      (setcdr (assoc (car (last props)) node) value))))


(defun avl-height (noderef)
  (or (avl-node-prop noderef :height) -1))

(defun avl-reheight (noderef)
  (if (null noderef)
      nil
    (avl-set-prop noderef :height
                  (1+ (max (avl-height (avl-node-prop noderef :left))
		           (avl-height (avl-node-prop noderef :right)))))))

(defun avl-setbalance (noderef)
  ;;(when (integerp node) (setq node (avl-node node)))
  (avl-reheight noderef)
  (avl-set-prop noderef :balance
		(- (avl-height (avl-node-prop noderef :right))
		   (avl-height (avl-node-prop noderef :left)))))

(defun avl-add-node (key parent)
  (let (result (idx 0))
    (cl-loop for idx from 0 to (1- (seq-length avl-all-nodes))
             while (null result) do
             (when (null (aref avl-all-nodes idx))
	       (aset avl-all-nodes idx (avl-create-node key parent))
	       (setq result idx)))
    result))

(defun avl-insert (key)
  (if (null avl-root-node)
      (progn (setq avl-root-node (avl-add-node key nil)) avl-root-node)
    (progn
      (let ((n avl-root-node) (end-loop nil) parent go-left result)
	(while (not end-loop)
	  (if (equal key (avl-node-prop n :key))
	      (setq end-loop 't)
	    (progn
	      (setq parent n)
	      (setq go-left (> (avl-node-prop n :key) key))
	      (setq n (if go-left
                          (avl-node-prop n :left)
                        (avl-node-prop n :right)))
	      
	      (when (null n)
                (setq result (avl-add-node key parent))
		(if go-left
		    (progn
		      (avl-set-prop parent :left result))
		  (progn
		    (avl-set-prop parent :right result)))
		(avl-rebalance parent) ;;rebalance
		(setq end-loop 't)))))
	result))))


(defun avl-rotate-left (noderef)
  (when (not (integerp noderef)) (error "parameter must be an integer"))
  (let ((a noderef) b)
    (setq b (avl-node-prop a :right))
    (avl-set-prop b :parent (avl-node-prop a :parent))

    (avl-set-prop a :right (avl-node-prop b :left))

    (when (avl-node-prop a :right) (avl-set-prop a :right :parent a))

    (avl-set-prop b :left a)
    (avl-set-prop a :parent b)

    (when (not (null (avl-node-prop b :parent)))
      (if (equal (avl-node-prop b :parent :right) a)
          (avl-set-prop b :parent :right b)
        (avl-set-prop b :parent :left b)))

    (avl-setbalance a)
    (avl-setbalance b)
    b))



(defun avl-rotate-right (node-idx)
  (when (not (integerp node-idx)) (error "parameter must be an integer"))
  (let ((a node-idx) b)
    (setq b (avl-node-prop a :left))
    (avl-set-prop b :parent (avl-node-prop a :parent))

    (avl-set-prop a :left (avl-node-prop b :right))

    (when (avl-node-prop a :right) (avl-set-prop a :right :parent a))

    (avl-set-prop b :left a)
    (avl-set-prop a :parent b)

    (when (not (null (avl-node-prop b :parent)))
      (if (equal (avl-node-prop b :parent :right) a)
          (avl-set-prop b :parent :right b)
        (avl-set-prop b :parent :left b)))

    (avl-setbalance a)
    (avl-setbalance b)
    b))

(defun avl-rotate-left-then-right (noderef)
  (avl-set-prop noderef :left (avl-rotate-left (avl-node-prop noderef :left)))
  (avl-rotate-right noderef))

(defun avl-rotate-right-then-left (noderef)
  (avl-set-prop noderef :right (avl-rotate-left (avl-node-prop noderef :right)))
  (avl-rotate-left noderef))

(defun avl-rebalance (noderef)
  (avl-setbalance noderef)
  (cond
   ((equal -2 (avl-node-prop noderef :balance))
    (if (>= (avl-height (avl-node-prop noderef :left :left))
	    (avl-height (avl-node-prop noderef :left :right)))
	(setq noderef (avl-rotate-right noderef))
      (setq noderef (avl-rotate-left-then-right noderef)))
    )
   ((equal 2 (avl-node-prop noderef :balance))
    (if (>= (avl-height (avl-node-prop noderef :right :right))
	    (avl-height (avl-node-prop noderef :right :left)))
	(setq noderef (avl-rotate-left noderef))
      (setq noderef (avl-rotate-right-then-left noderef)))))
  
  (if (not (null (avl-node-prop noderef :parent)))
      (avl-rebalance (avl-node-prop noderef :parent))
    (setq avl-root-node noderef)))


(defun avl-delete (noderef)
  (when noderef
    (when (and (null (avl-node-prop noderef :left))
               (null (avl-node-prop noderef :right)))
      (if (null (avl-node-prop noderef :parent))
          (setq avl-root-node nil)
        (let ((parent (avl-node-prop noderef :parent)))
          (if (equal noderef (avl-node-prop parent :left))
              (avl-set-prop parent :left nil)
            (avl-set-prop parent :right nil))
          (avl-rebalance parent))))

    (if (not (null (avl-node-prop noderef :left)))
        (let ((child (avl-node-prop noderef :left)))
          (while (not (null (avl-node-prop child :right)))
            (setq child (avl-node-prop child :right)))
          (avl-set-prop noderef :key (avl-node-prop child :key))
          (avl-delete child))
      (let ((child (avl-node-prop noderef :right)))
        (while (not (null (avl-node-prop child :left)))
          (setq child (avl-node-prop child :left)))
        (avl-set-prop noderef :key (avl-node-prop child :key))
        (avl-delete child)))))

;; Main procedure
(let ((cnt 10) balances)
  (fillarray avl-all-nodes nil)
  (setq avl-root-node nil)

  (dotimes (val cnt)
    (avl-insert (1+ val)))

  (setq balances (seq-map (lambda (x) (or (avl-node-prop x :balance) 0))
			  (number-sequence 0 (1- cnt))))

  (message "Inserting values 1 to %d" cnt)
  (message "Printing balance: %s" (string-join (seq-map (lambda (x) (format "%S" x)) balances) " ")))
Output:
Inserting values 1 to 10
Printing balance: 0 0 0 1 0 1 0 0 0 0

Fortran

Works with: Fortran version 2008
Works with: Fortran version 2018

See also ATS and Scheme, where persistent (‘immutable’) versions of this algorithm are implemented.

The following AVL tree implementation is for keys and data of any type, mixed freely. This is made possible by Fortran 2008’s unlimited polymorphism. The demonstration is for INTEGER keys and mixtures of REAL and CHARACTER data.

Supported operations include insertion of a key-data pair, deletion, tree size computed by traversal, output of the full contents as an ordered linked list, printing a representation of the tree, checking that the AVL condition is satisfied. There are actually some slightly more general mechanisms available, in terms of which the foregoing operations are written.

module avl_trees
  !
  ! 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.
  !

  implicit none
  private

  ! The type for an AVL tree.
  public :: avl_tree_t

  ! The type for a pair of pointers to key and data within the tree.
  ! (Be careful with these!)
  public :: avl_pointer_pair_t

  ! Insertion, replacement, modification, etc.
  public :: avl_insert_or_modify

  ! Insert or replace.
  public :: avl_insert

  ! Is the key in the tree?
  public :: avl_contains

  ! Retrieve data from a tree.
  public :: avl_retrieve

  ! Delete data from a tree. This is a generic function.
  public :: avl_delete

  ! Implementations of avl_delete.
  public :: avl_delete_with_found
  public :: avl_delete_without_found

  ! How many nodes are there in the tree?
  public :: avl_size

  ! Return a list of avl_pointer_pair_t for the elements in the
  ! tree. The list will be in order.
  public :: avl_pointer_pairs

  ! Print a representation of the tree to an output unit.
  public :: avl_write

  ! Check the AVL condition (that the heights of the two branches from
  ! a node should differ by zero or one). ERROR STOP if the condition
  ! is not met.
  public :: avl_check

  ! Procedure types.
  public :: avl_less_than_t
  public :: avl_insertion_t
  public :: avl_key_data_writer_t

  type :: avl_node_t
     class(*), allocatable :: key, data
     type(avl_node_t), pointer :: left
     type(avl_node_t), pointer :: right
     integer :: bal             ! bal == -1, 0, 1
  end type avl_node_t

  type :: avl_tree_t
     type(avl_node_t), pointer :: p => null ()
   contains
     final :: avl_tree_t_final
  end type avl_tree_t

  type :: avl_pointer_pair_t
     class(*), pointer :: p_key, p_data
     class(avl_pointer_pair_t), pointer :: next => null ()
   contains
     final :: avl_pointer_pair_t_final
  end type avl_pointer_pair_t

  interface avl_delete
     module procedure avl_delete_with_found
     module procedure avl_delete_without_found
  end interface avl_delete

  interface
     function avl_less_than_t (key1, key2) result (key1_lt_key2)
       !
       ! The ordering predicate (‘<’).
       !
       ! Two keys a,b are considered equivalent if neither a<b nor
       ! b<a.
       !
       class(*), intent(in) :: key1, key2
       logical key1_lt_key2
     end function avl_less_than_t

     subroutine avl_insertion_t (key, data, p_is_new, p)
       !
       ! Insertion or modification of a found node.
       !
       import avl_node_t
       class(*), intent(in) :: key, data
       logical, intent(in) :: p_is_new
       type(avl_node_t), pointer, intent(inout) :: p
     end subroutine avl_insertion_t

     subroutine avl_key_data_writer_t (unit, key, data)
       !
       ! Printing the key and data of a node.
       !
       integer, intent(in) :: unit
       class(*), intent(in) :: key, data
     end subroutine avl_key_data_writer_t
  end interface

contains

  subroutine avl_tree_t_final (tree)
    type(avl_tree_t), intent(inout) :: tree

    type(avl_node_t), pointer :: p

    p => tree%p
    call free_the_nodes (p)

  contains

    recursive subroutine free_the_nodes (p)
      type(avl_node_t), pointer, intent(inout) :: p

      if (associated (p)) then
         call free_the_nodes (p%left)
         call free_the_nodes (p%right)
         deallocate (p)
      end if
    end subroutine free_the_nodes

  end subroutine avl_tree_t_final

  recursive subroutine avl_pointer_pair_t_final (node)
    type(avl_pointer_pair_t), intent(inout) :: node

    if (associated (node%next)) deallocate (node%next)
  end subroutine avl_pointer_pair_t_final

  function avl_contains (less_than, key, tree) result (found)
    procedure(avl_less_than_t) :: less_than
    class(*), intent(in) :: key
    class(avl_tree_t), intent(in) :: tree
    logical :: found

    found = avl_contains_recursion (less_than, key, tree%p)
  end function avl_contains

  recursive function avl_contains_recursion (less_than, key, p) result (found)
    procedure(avl_less_than_t) :: less_than
    class(*), intent(in) :: key
    type(avl_node_t), pointer, intent(in) :: p
    logical :: found

    if (.not. associated (p)) then
       found = .false.
    else if (less_than (key, p%key)) then
       found = avl_contains_recursion (less_than, key, p%left)
    else if (less_than (p%key, key)) then
       found = avl_contains_recursion (less_than, key, p%right)
    else
       found = .true.
    end if
  end function avl_contains_recursion

  subroutine avl_retrieve (less_than, key, tree, found, data)
    procedure(avl_less_than_t) :: less_than
    class(*), intent(in) :: key
    class(avl_tree_t), intent(in) :: tree
    logical, intent(out) :: found
    class(*), allocatable, intent(inout) :: data

    call avl_retrieve_recursion (less_than, key, tree%p, found, data)
  end subroutine avl_retrieve

  recursive subroutine avl_retrieve_recursion (less_than, key, p, found, data)
    procedure(avl_less_than_t) :: less_than
    class(*), intent(in) :: key
    type(avl_node_t), pointer, intent(in) :: p
    logical, intent(out) :: found
    class(*), allocatable, intent(inout) :: data

    if (.not. associated (p)) then
       found = .false.
    else if (less_than (key, p%key)) then
       call avl_retrieve_recursion (less_than, key, p%left, found, data)
    else if (less_than (p%key, key)) then
       call avl_retrieve_recursion (less_than, key, p%right, found, data)
    else
       found = .true.
       data = p%data
    end if
  end subroutine avl_retrieve_recursion

  subroutine avl_insert (less_than, key, data, tree)
    procedure(avl_less_than_t) :: less_than
    class(*), intent(in) :: key, data
    class(avl_tree_t), intent(inout) :: tree

    call avl_insert_or_modify (less_than, insert_or_replace, key, data, tree)
  end subroutine avl_insert

  subroutine insert_or_replace (key, data, p_is_new, p)
    class(*), intent(in) :: key, data
    logical, intent(in) :: p_is_new
    type(avl_node_t), pointer, intent(inout) :: p

    p%data = data
  end subroutine insert_or_replace

  subroutine avl_insert_or_modify (less_than, insertion, key, data, tree)
    procedure(avl_less_than_t) :: less_than
    procedure(avl_insertion_t) :: insertion ! Or modification in place.
    class(*), intent(in) :: key, data
    class(avl_tree_t), intent(inout) :: tree

    logical :: fix_balance

    fix_balance = .false.
    call insertion_search (less_than, insertion, key, data, tree%p, fix_balance)
  end subroutine avl_insert_or_modify

  recursive subroutine insertion_search (less_than, insertion, key, data, p, fix_balance)
    procedure(avl_less_than_t) :: less_than
    procedure(avl_insertion_t) :: insertion
    class(*), intent(in) :: key, data
    type(avl_node_t), pointer, intent(inout) :: p
    logical, intent(inout) :: fix_balance

    type(avl_node_t), pointer :: p1, p2

    if (.not. associated (p)) then
       ! The key was not found. Make a new node.
       allocate (p)
       p%key = key
       p%left => null ()
       p%right => null ()
       p%bal = 0
       call insertion (key, data, .true., p)
       fix_balance = .true.
    else if (less_than (key, p%key)) then
       ! Continue searching.
       call insertion_search (less_than, insertion, key, data, p%left, fix_balance)
       if (fix_balance) then
          ! A new node has been inserted on the left side.
          select case (p%bal)
          case (1)
             p%bal = 0
             fix_balance = .false.
          case (0)
             p%bal = -1
          case (-1)
             ! Rebalance.
             p1 => p%left
             select case (p1%bal)
             case (-1)
                ! A single LL rotation.
                p%left => p1%right
                p1%right => p
                p%bal = 0
                p => p1
                p%bal = 0
                fix_balance = .false.
             case (0, 1)
                ! A double LR rotation.
                p2 => p1%right
                p1%right => p2%left
                p2%left => p1
                p%left => p2%right
                p2%right => p
                p%bal = -(min (p2%bal, 0))
                p1%bal = -(max (p2%bal, 0))
                p => p2
                p%bal = 0
                fix_balance = .false.
             case default
                error stop
             end select
          case default
             error stop
          end select
       end if
    else if (less_than (p%key, key)) then
       call insertion_search (less_than, insertion, key, data, p%right, fix_balance)
       if (fix_balance) then
          ! A new node has been inserted on the right side.
          select case (p%bal)
          case (-1)
             p%bal = 0
             fix_balance = .false.
          case (0)
             p%bal = 1
          case (1)
             ! Rebalance.
             p1 => p%right
             select case (p1%bal)
             case (1)
                ! A single RR rotation.
                p%right => p1%left
                p1%left => p
                p%bal = 0
                p => p1
                p%bal = 0
                fix_balance = .false.
             case (-1, 0)
                ! A double RL rotation.
                p2 => p1%left
                p1%left => p2%right
                p2%right => p1
                p%right => p2%left
                p2%left => p
                p%bal = -(max (p2%bal, 0))
                p1%bal = -(min (p2%bal, 0))
                p => p2
                p%bal = 0
                fix_balance = .false.
             case default
                error stop
             end select
          case default
             error stop
          end select
       end if
    else
       ! The key was found. The pointer p points to an existing node.
       call insertion (key, data, .false., p)
    end if
  end subroutine insertion_search

  subroutine avl_delete_with_found (less_than, key, tree, found)
    procedure(avl_less_than_t) :: less_than
    class(*), intent(in) :: key
    class(avl_tree_t), intent(inout) :: tree
    logical, intent(out) :: found

    logical :: fix_balance

    fix_balance = .false.
    call deletion_search (less_than, key, tree%p, fix_balance, found)
  end subroutine avl_delete_with_found

  subroutine avl_delete_without_found (less_than, key, tree)
    procedure(avl_less_than_t) :: less_than
    class(*), intent(in) :: key
    class(avl_tree_t), intent(inout) :: tree

    logical :: found

    call avl_delete_with_found (less_than, key, tree, found)
  end subroutine avl_delete_without_found

  recursive subroutine deletion_search (less_than, key, p, fix_balance, found)
    procedure(avl_less_than_t) :: less_than
    class(*), intent(in) :: key
    type(avl_node_t), pointer, intent(inout) :: p
    logical, intent(inout) :: fix_balance
    logical, intent(out) :: found

    type(avl_node_t), pointer :: q

    if (.not. associated (p)) then
       ! The key is not in the tree.
       found = .false.
    else if (less_than (key, p%key)) then
       call deletion_search (less_than, key, p%left, fix_balance, found)
       if (fix_balance) call balance_for_shrunken_left (p, fix_balance)
    else if (less_than (p%key, key)) then
       call deletion_search (less_than, key, p%right, fix_balance, found)
       if (fix_balance) call balance_for_shrunken_right (p, fix_balance)
    else
       q => p
       if (.not. associated (q%right)) then
          p => q%left
          fix_balance = .true.
       else if (.not. associated (q%left)) then
          p => q%right
          fix_balance = .true.
       else
          call del (q%left, q, fix_balance)
          if (fix_balance) call balance_for_shrunken_left (p, fix_balance)
       end if
       deallocate (q)
       found = .true.
    end if
  end subroutine deletion_search

  recursive subroutine del (r, q, fix_balance)
    type(avl_node_t), pointer, intent(inout) :: r, q
    logical, intent(inout) :: fix_balance

    if (associated (r%right)) then
       call del (r%right, q, fix_balance)
       if (fix_balance) call balance_for_shrunken_right (r, fix_balance)
    else
       q%key = r%key
       q%data = r%data
       q => r
       r => r%left
       fix_balance = .true.
    end if
  end subroutine del

  subroutine balance_for_shrunken_left (p, fix_balance)
    type(avl_node_t), pointer, intent(inout) :: p
    logical, intent(inout) :: fix_balance

    ! The left side has lost a node.

    type(avl_node_t), pointer :: p1, p2

    if (.not. fix_balance) error stop

    select case (p%bal)
    case (-1)
       p%bal = 0
    case (0)
       p%bal = 1
       fix_balance = .false.
    case (1)
       ! Rebalance.
       p1 => p%right
       select case (p1%bal)
       case (0)
          ! A single RR rotation.
          p%right => p1%left
          p1%left => p
          p%bal = 1
          p1%bal = -1
          p => p1
          fix_balance = .false.
       case (1)
          ! A single RR rotation.
          p%right => p1%left
          p1%left => p
          p%bal = 0
          p1%bal = 0
          p => p1
          fix_balance = .true.
       case (-1)
          ! A double RL rotation.
          p2 => p1%left
          p1%left => p2%right
          p2%right => p1
          p%right => p2%left
          p2%left => p
          p%bal = -(max (p2%bal, 0))
          p1%bal = -(min (p2%bal, 0))
          p => p2
          p2%bal = 0
       case default
          error stop
       end select
    case default
       error stop
    end select
  end subroutine balance_for_shrunken_left

  subroutine balance_for_shrunken_right (p, fix_balance)
    type(avl_node_t), pointer, intent(inout) :: p
    logical, intent(inout) :: fix_balance

    ! The right side has lost a node.

    type(avl_node_t), pointer :: p1, p2

    if (.not. fix_balance) error stop

    select case (p%bal)
    case (1)
       p%bal = 0
    case (0)
       p%bal = -1
       fix_balance = .false.
    case (-1)
       ! Rebalance.
       p1 => p%left
       select case (p1%bal)
       case (0)
          ! A single LL rotation.
          p%left => p1%right
          p1%right => p
          p1%bal = 1
          p%bal = -1
          p => p1
          fix_balance = .false.
       case (-1)
          ! A single LL rotation.
          p%left => p1%right
          p1%right => p
          p1%bal = 0
          p%bal = 0
          p => p1
          fix_balance = .true.
       case (1)
          ! A double LR rotation.
          p2 => p1%right
          p1%right => p2%left
          p2%left => p1
          p%left => p2%right
          p2%right => p
          p%bal = -(min (p2%bal, 0))
          p1%bal = -(max (p2%bal, 0))
          p => p2
          p2%bal = 0
       case default
          error stop
       end select
    case default
       error stop
    end select
  end subroutine balance_for_shrunken_right

  function avl_size (tree) result (size)
    class(avl_tree_t), intent(in) :: tree
    integer :: size

    size = traverse (tree%p)

  contains

    recursive function traverse (p) result (size)
      type(avl_node_t), pointer, intent(in) :: p
      integer :: size

      if (associated (p)) then
         ! The order of traversal is arbitrary.
         size = 1 + traverse (p%left) + traverse (p%right)
      else
         size = 0
      end if
    end function traverse

  end function avl_size

  function avl_pointer_pairs (tree) result (lst)
    class(avl_tree_t), intent(in) :: tree
    type(avl_pointer_pair_t), pointer :: lst

    ! Reverse in-order traversal of the tree, to produce a CONS-list
    ! of pointers to the contents.

    lst => null ()
    if (associated (tree%p)) lst => traverse (tree%p, lst)

  contains

    recursive function traverse (p, lst1) result (lst2)
      type(avl_node_t), pointer, intent(in) :: p
      type(avl_pointer_pair_t), pointer, intent(in) :: lst1
      type(avl_pointer_pair_t), pointer :: lst2

      type(avl_pointer_pair_t), pointer :: new_entry

      lst2 => lst1
      if (associated (p%right)) lst2 => traverse (p%right, lst2)
      allocate (new_entry)
      new_entry%p_key => p%key
      new_entry%p_data => p%data
      new_entry%next => lst2
      lst2 => new_entry
      if (associated (p%left)) lst2 => traverse (p%left, lst2)
    end function traverse

  end function avl_pointer_pairs

  subroutine avl_write (write_key_data, unit, tree)
    procedure(avl_key_data_writer_t) :: write_key_data
    integer, intent(in) :: unit
    class(avl_tree_t), intent(in) :: tree

    character(len = *), parameter :: tab = achar (9)

    type(avl_node_t), pointer :: p

    p => tree%p
    if (.not. associated (p)) then
       continue
    else
       call traverse (p%left, 1, .true.)
       call write_key_data (unit, p%key, p%data)
       write (unit, '(2A, "depth = ", I0, "  bal = ", I0)') tab, tab, 0, p%bal
       call traverse (p%right, 1, .false.)
    end if

  contains

    recursive subroutine traverse (p, depth, left)
      type(avl_node_t), pointer, intent(in) :: p
      integer, value :: depth
      logical, value :: left

      if (.not. associated (p)) then
         continue
      else
         call traverse (p%left, depth + 1, .true.)
         call pad (depth, left)
         call write_key_data (unit, p%key, p%data)
         write (unit, '(2A, "depth = ", I0, "  bal = ", I0)') tab, tab, depth, p%bal
         call traverse (p%right, depth + 1, .false.)
      end if
    end subroutine traverse

    subroutine pad (depth, left)
      integer, value :: depth
      logical, value :: left

      integer :: i

      do i = 1, depth
         write (unit, '(2X)', advance = 'no')
      end do
    end subroutine pad

  end subroutine avl_write

  subroutine avl_check (tree)
    use, intrinsic :: iso_fortran_env, only: error_unit
    class(avl_tree_t), intent(in) :: tree

    type(avl_node_t), pointer :: p
    integer :: height_L, height_R

    p => tree%p
    call get_heights (p, height_L, height_R)
    call check_heights (height_L, height_R)

  contains

    recursive subroutine get_heights (p, height_L, height_R)
      type(avl_node_t), pointer, intent(in) :: p
      integer, intent(out) :: height_L, height_R

      integer :: height_LL, height_LR
      integer :: height_RL, height_RR

      height_L = 0
      height_R = 0
      if (associated (p)) then
         call get_heights (p%left, height_LL, height_LR)
         call check_heights (height_LL, height_LR)
         height_L = height_LL + height_LR
         call get_heights (p%right, height_RL, height_RR)
         call check_heights (height_RL, height_RR)
         height_R = height_RL + height_RR
      end if
    end subroutine get_heights

    subroutine check_heights (height_L, height_R)
      integer, value :: height_L, height_R

      if (2 <= abs (height_L - height_R)) then
         write (error_unit, '("*** AVL condition violated ***")')
         error stop
      end if
    end subroutine check_heights

  end subroutine avl_check

end module avl_trees

program avl_trees_demo
  use, intrinsic :: iso_fortran_env, only: output_unit
  use, non_intrinsic :: avl_trees

  implicit none

  integer, parameter :: keys_count = 20

  type(avl_tree_t) :: tree
  logical :: found
  class(*), allocatable :: retval
  integer :: the_keys(1:keys_count)
  integer :: i, j

  do i = 1, keys_count
     the_keys(i) = i
  end do
  call fisher_yates_shuffle (the_keys, keys_count)

  call avl_check (tree)
  do i = 1, keys_count
     call avl_insert (lt, the_keys(i), real (the_keys(i)), tree)
     call avl_check (tree)
     if (avl_size (tree) /= i) error stop
     do j = 1, keys_count
        if (avl_contains (lt, the_keys(j), tree) .neqv. (j <= i)) error stop
     end do
     do j = 1, keys_count
        call avl_retrieve (lt, the_keys(j), tree, found, retval)
        if (found .neqv. (j <= i)) error stop
        if (found) then
           ! This crazy way to write ‘/=’ is to quell those tiresome
           ! warnings about using ‘==’ or ‘/=’ with floating point
           ! numbers. Floating point numbers can represent integers
           ! *exactly*.
           if (0 < abs (real_cast (retval) - real (the_keys(j)))) error stop
        end if
        if (found) then
           block
             character(len = 1), parameter :: ch = '*'
             !
             ! Try replacing the data with a character and then
             ! restoring the number.
             !
             call avl_insert (lt, the_keys(j), ch, tree)
             call avl_retrieve (lt, the_keys(j), tree, found, retval)
             if (.not. found) error stop
             if (char_cast (retval) /= ch) error stop
             call avl_insert (lt, the_keys(j), real (the_keys(j)), tree)
             call avl_retrieve (lt, the_keys(j), tree, found, retval)
             if (.not. found) error stop
             if (0 < abs (real_cast (retval) - real (the_keys(j)))) error stop
           end block
        end if
     end do
  end do

  write (output_unit, '(70("-"))')
  call avl_write (int_real_writer, output_unit, tree)
  write (output_unit, '(70("-"))')
  call print_contents (output_unit, tree)
  write (output_unit, '(70("-"))')

  call fisher_yates_shuffle (the_keys, keys_count)
  do i = 1, keys_count
     call avl_delete (lt, the_keys(i), tree)
     call avl_check (tree)
     if (avl_size (tree) /= keys_count - i) error stop
     ! Try deleting a second time.
     call avl_delete (lt, the_keys(i), tree)
     call avl_check (tree)
     if (avl_size (tree) /= keys_count - i) error stop
     do j = 1, keys_count
        if (avl_contains (lt, the_keys(j), tree) .neqv. (i < j)) error stop
     end do
     do j = 1, keys_count
        call avl_retrieve (lt, the_keys(j), tree, found, retval)
        if (found .neqv. (i < j)) error stop
        if (found) then
           if (0 < abs (real_cast (retval) - real (the_keys(j)))) error stop
        end if
     end do
  end do

contains

  subroutine fisher_yates_shuffle (keys, n)
    integer, intent(inout) :: keys(*)
    integer, intent(in) :: n

    integer :: i, j
    real :: randnum
    integer :: tmp

    do i = 1, n - 1
       call random_number (randnum)
       j = i + floor (randnum * (n - i + 1))
       tmp = keys(i)
       keys(i) = keys(j)
       keys(j) = tmp
    end do
  end subroutine fisher_yates_shuffle

  function int_cast (u) result (v)
    class(*), intent(in) :: u
    integer :: v

    select type (u)
    type is (integer)
       v = u
    class default
       ! This case is not handled.
       error stop
    end select
  end function int_cast

  function real_cast (u) result (v)
    class(*), intent(in) :: u
    real :: v

    select type (u)
    type is (real)
       v = u
    class default
       ! This case is not handled.
       error stop
    end select
  end function real_cast

  function char_cast (u) result (v)
    class(*), intent(in) :: u
    character(len = 1) :: v

    select type (u)
    type is (character(*))
       v = u
    class default
       ! This case is not handled.
       error stop
    end select
  end function char_cast

  function lt (u, v) result (u_lt_v)
    class(*), intent(in) :: u, v
    logical :: u_lt_v

    select type (u)
    type is (integer)
       select type (v)
       type is (integer)
          u_lt_v = (u < v)
       class default
          ! This case is not handled.
          error stop
       end select
    class default
       ! This case is not handled.
       error stop
    end select
  end function lt

  subroutine int_real_writer (unit, key, data)
    integer, intent(in) :: unit
    class(*), intent(in) :: key, data

    write (unit, '("(", I0, ", ", F0.1, ")")', advance = 'no') &
         & int_cast(key), real_cast(data)
  end subroutine int_real_writer

  subroutine print_contents (unit, tree)
    integer, intent(in) :: unit
    class(avl_tree_t), intent(in) :: tree

    type(avl_pointer_pair_t), pointer :: ppairs, pp

    write (unit, '("tree size = ", I0)') avl_size (tree)
    ppairs => avl_pointer_pairs (tree)
    pp => ppairs
    do while (associated (pp))
       write (unit, '("(", I0, ", ", F0.1, ")")') &
            & int_cast (pp%p_key), real_cast (pp%p_data)
       pp => pp%next
    end do
    if (associated (ppairs)) deallocate (ppairs)
  end subroutine print_contents

end program avl_trees_demo
Output:

The demonstration is randomized, so this is just one example of a run.

$ gfortran -std=f2018 -O2 -g -fcheck=all -Wall -Wextra -Wno-unused-dummy-argument avl_trees-fortran.f90 && ./a.out
----------------------------------------------------------------------
      (1, 1.0)          depth = 3  bal = 1
        (2, 2.0)                depth = 4  bal = 0
    (3, 3.0)            depth = 2  bal = -1
      (4, 4.0)          depth = 3  bal = 0
  (5, 5.0)              depth = 1  bal = 0
      (6, 6.0)          depth = 3  bal = 1
        (7, 7.0)                depth = 4  bal = 0
    (8, 8.0)            depth = 2  bal = 0
        (9, 9.0)                depth = 4  bal = 0
      (10, 10.0)                depth = 3  bal = 0
        (11, 11.0)              depth = 4  bal = 0
(12, 12.0)              depth = 0  bal = 0
      (13, 13.0)                depth = 3  bal = 1
        (14, 14.0)              depth = 4  bal = 0
    (15, 15.0)          depth = 2  bal = -1
      (16, 16.0)                depth = 3  bal = 0
  (17, 17.0)            depth = 1  bal = -1
      (18, 18.0)                depth = 3  bal = 0
    (19, 19.0)          depth = 2  bal = 0
      (20, 20.0)                depth = 3  bal = 0
----------------------------------------------------------------------
tree size = 20
(1, 1.0)
(2, 2.0)
(3, 3.0)
(4, 4.0)
(5, 5.0)
(6, 6.0)
(7, 7.0)
(8, 8.0)
(9, 9.0)
(10, 10.0)
(11, 11.0)
(12, 12.0)
(13, 13.0)
(14, 14.0)
(15, 15.0)
(16, 16.0)
(17, 17.0)
(18, 18.0)
(19, 19.0)
(20, 20.0)
----------------------------------------------------------------------

Generic

The Generic Language is a database compiler. The code is compiled into database and then executed out of database.


space system
{

enum state
{
    header 
    balanced
    left_high
    right_high
}
 
enum direction
{
  from_left
  from_right
}
 
class node
{
    left
    right
    parent
    balance
    data

    node()
    {
       left = this
       right = this
       balance = state.header
       parent = null
       data = null
    }

    node(root d)
    {
      left = null
      right = null
      parent = root
      balance = state.balanced
      data = d  
    }
 
    is_header
    {
        get
        {
            return balance == state.header
        }
    }

    next
    {
        get
        {
            if is_header return left
 
            if !right.null()
            {
                n = right
                while !n.left.null() n = n.left
                return n
             }
             else
             {
                  y = parent
                  if y.is_header return y
 
                  n = this
                  while n == y.right
                  {
                       n = y
                       y = y.parent
                       if y.is_header break
                   }
                   return y
              }
          }
     }


   previous
   {
       get
       {   
            if is_header return right
 
            if !left.null()
            {
               n = left
               while !n.right.null() n = right
               return n
            }
            else
            {
                y = parent
                if y.is_header return y

                n = this
                while n == y.left
                {
                    n = y
                    y = y.parent
                    if y.is_header break
                 }
                 return y
             }
        }
    }

    rotate_left()
    {
        _right = right
        _parent = parent
         parent = _right
         _right.parent = _parent
        if !_right.left.null() _right.left.parent = this
        right = _right.left
        _right.left = this
        this = _right
    }
 
    rotate_right()
    {
        _left = left
        _parent = parent
        parent = _left
        _left.parent =  _parent
        if !_left.right.null() _left.right.parent = this
        left = _left.right
        _left.right = this
        this = _left
    }
 
    balance_left()
    {
        select left.balance
        {
            left_high
            {
                balance = state.balanced
                left.balance = state.balanced
                rotate_right()
            }
 
            right_high
            {
                subright = left.right
 
                select subright.balance
                {
                    balanced
                    {
                        balance = state.balanced
                        left.balance = state.balanced
                    }
 
                    right_high
                    {
                        balance = state.balanced
                        left.balance = state.left_high
                    }
 
                    left_high
                    {
                        balance = state.right_high
                        lehpt.balance = state.balanced
                    }
                }
                subright.balance = state.balanced
                left.rotate_left()
                rotate_right()
            }
 
            balanced
            {
                balance = state.left_high
                left.balance = state.right_high
                rotate_right()
            }
        }   
    }
 
    balance_right()
    {
        select right.balance
        {
            right_high
            { 
                balance = state.balanced
                right.balance = state.balanced
                rotate_left()

            }
 
           left_high
           {
               subleft = right.left
 
               select subleft.balance
               {
                   balanced
                   {
                       balance = state.balanced
                       right.balance = state.balanced
                   }
 
                   left_high
                   {
                       balance = state.balanced
                       right.balance = state.right_high
                   }
 
                   right_high
                   {
                       balance = state.left_high
                       right.balance = state.balanced
                   }
               }
               subleft.balance = state.balanced
               right.rotate_right()
               rotate_left()
           }
 
           balanced
           {
               balance = state.right_high
               right.balance = state.left_high
               rotate_left()
           }
        }
    }
 
    balance_tree(from)
    {
        taller = true
 
        while taller
        {
            p = parent 
        
            next_from = direction.from_left
            if this != parent.left next_from = direction.from_right
 
            if from == direction.from_left
                select balance
                {
                    left_high
                    {
                        if parent.is_header
                            parent.parent.balance_left()
                        else
                        {
                            if parent.left == this
                                parent.left.balance_left()
                            else
                                parent.right.balance_left()
                            taller = false
                        }
                    }
 
                    balanced
                    {
                        balance = state.left_high
                        taller = true
                    }
 
                    right_high
                    {
                        balance = state.balanced
                        taller = false
                    }
            }
            else
               select balance
               {
                   left_high
                   {
                       balance = state.balanced
                       taller = false
                   }    
 
                   balanced
                   {
                       balance = state.right_high
                       taller = true
                    }
 
                   right_high
                   {
                        if parent.is_header
                            parent.parent.balance_right()
                        else
                        {
                            if parent.left == this
                                parent.left.balance_right()
                            else
                                parent.right.balance_right()
                        }
                        taller = false
                     }
                 }
 
             if taller
             {
           
                 if p.is_header
                   taller = false
                 else
                 {
                     this = p
                     from = next_from
                 }
             }
         }
    }
 
    balance_tree_remove(from)
    {
         shorter = true
 
         while shorter
         {

            next_from = direction.from_left
 
           if this != parent.left next_from = direction.from_right
 
            if from == direction.from_left
                select balance
                {
                    left_high
                    {
                        balance = state.balanced
                        shorter = true
                    }
 
 
                    balanced
                    {
                        balance = state.right_high
                        shorter = false
                    }
 
                    right_high
                    {
                        if right.balance == state.right_high
                            shorter = false
                        else
                            shorter = true
 
                        if parent.is_header
                            parent.parent.balance_right()
                        else
                        {
                            if parent.left == this
                                parent.left.balance_right()
                            else
                                parent.right.balance_right()
                       }    
                   }
             }
             else
                select balance
                {
                    right_high
                    {
                        balance = state.balanced
                        shorter = true
                    }
 
 
                    balanced
                    {
                       balance = state.left_high
                       shorter = false
                    }
 
 
                    left_high
                    {
                        if left.balance == state.balanced
                            shorter = false
                        else
                            shorter = true
 
                        if parent.is_header
                            parent.parent.balance_left()
                        else
                        {
                            if parent.is_header
                                parent.left.balance_left()
                            else
                                parent.right.balance_left()
                        }
                   }
            }
 
            if shorter
            {
              if parent.is_header
                  shorter = false
               else
               {
                  this = parent
                  from = next_from
               }
           }
        }
    }

    count
    {
        get
        {
            result = +a

            if !null()
            {
               cleft = +a
               if !left.null() cleft = left.count

               cright = +a
               if !right.null() cright = right.count
  
               result = result + cleft + cright + +b
            }

            return result
       }
    }

    depth
    {
        get
        {
            result = +a

            if !null()
            {
               cleft = +a
               if !left.null() cleft = left.depth

               cright = +a
               if !right.null() cright = right.depth

               if cleft > cright
                  result = cleft + +b
               else
                  result = cright + +b
            }

            return result
       }
    }
}

    class default_comparer
    {
      default_comparer() {}

      compare_to(a b)
      {
        if a < b return -1
        if b < a return 1
        return 0
      }
    }

    class set
    {
        header
        iterator
        comparer

        set()
        {
           header = node()
           iterator = null
           comparer = default_comparer()
        }

        set(c_set)
        {
           header = node()
           iterator = null
           comparer = c_set
        }


        left_most
        {
           get
           {
               return header.left
           }
           set
           {
               header.left = value
           }
        }

        right_most
        {
           get
           {
               return header.right
           }
           set
           {
               header.right = value
           }
        }

       root
       {
           get
           {
                return header.parent
           }
           set
           {
                header.parent = value
           }
        }

        empty
        {
            get
            {
                return header.parent.null()
            }
         }

        operator<<(data)
        {
            if header.parent.null()
            {
                root = node(header data)
                left_most = root
                right_most = root
            }
            else
            {
                node = root
 
                repeat
                {
                    result = comparer.compare_to(data node.data)
                    if result < 0
                    {
                        if !node.left.null()
                            node = node.left
                        else
                        {
                            new_node = node(node data)
                            node.left = new_node
                            if left_most == node left_most = new_node
                            node.balance_tree(direction.from_left)
                            break
                        }
                   }
                   else if result > 0
                   {
                       if !node.right.null()
                           node = node.right
                       else
                       {
                           new_node = node(node data)
                           node.right = new_node
                           if right_most == node right_most = new_node
                           node.balance_tree(direction.from_right)
                           break
                        }
                    }
                    else // item already exists
                        throw "entry " + (string)data + " already exists"
               }
           }
           return this
       }

        update(data)
        {
            if empty
            {
                root = node(header data)
                left_most = root
                right_most = root
            }
            else
            {
                node = root
 
                repeat
                {
                    result = comparer.compare_to(data node.data)
                    if result < 0
                    {
                        if !node.left.null()
                            node = node.left
                        else
                        { 
                            new_node = node(node data)
                            node.left = new_node
                            if left_most == node left_most = new_node
                            node.balance_tree(direction.from_left)
                            break
                        }
                   }
                   else if result > 0
                   {  
                        if !node.right.null()
                            node = node.right
                        else
                        {
                            new_node = node(node data)
                            node.right = new_node
                            if right_most == node right_most = new_node
                            node.balance_tree(direction.from_right)
                            break
                        }
                   }
                   else // item already exists
                   {
                        node.data = data
                        break
                   }
               }
           }
       }

        operator>>(data)
        {
             node = root

             repeat
             {
                  if node.null()
                  {
                       throw "entry " + (string)data + " not found"
                  }

                  result = comparer.compare_to(data node.data)

                  if result < 0
                       node = node.left
                  else if result > 0
                       node = node.right
                  else // item found
                  {
                      if !node.left.null() && !node.right.null()
                      {
                         replace = node.left
                         while !replace.right.null() replace = replace.right
                         temp = node.data
                         node.data = replace.data
                         replace.data = temp
                         node = replace
                      }

                      from = direction.from_left
                      if node != node.parent.left from = direction.from_right
 
                      if left_most == node
                      {
                          next = node
                          next = next.next
                       
                          if header == next
                          {
                              left_most = header
                              right_most = header
                          }
                          else
                              left_most = next
                      }
 
                      if right_most == node
                      {
                          previous = node
                          previous = previous.previous
                    
                          if header == previous
                          {
                              left_most = header
                              right_most = header
                          }
                          else
                               right_most = previous
                      }

                      if node.left.null()
                      {
                           if node.parent == header
                               root = node.right
                           else
                           {
                               if node.parent.left == node
                                   node.parent.left = node.right
                               else
                                   node.parent.right = node.right
                           }

                           if !node.right.null()
                               node.right.parent = node.parent
                      }
                      else
                      {
                          if node.parent == header
                               root = node.left
                           else
                           {
                               if node.parent.left == node
                                   node.parent.left = node.left
                               else
                                   node.parent.right = node.left
                            }

                           if !node.left.null()
                                node.left.parent = node.parent
 
                      }
                      node.parent.balance_tree_remove(from)
                      break
                 }
             }
             return this
        }

        remove(data)
        {
             node = root

             repeat
             {
                  if node.null()
                  {
                       throw "entry " + (string)data + " not found"
                  }

                  result = comparer.compare_to(data node.data)

                  if result < 0
                       node = node.left
                  else if result > 0
                       node = node.right
                  else // item found
                  {
                      if !node.left.null() && !node.right.null()
                      {
                         replace = node.left
                         while !replace.right.null() replace = replace.right
                         temp = node.data
                         node.data = replace.data
                         replace.data = temp
                         node = replace
                      }

                      from = direction.from_left
                      if node != node.parent.left from = direction.from_right
 
                      if left_most == node
                      {
                          next = node
                          next = next.next
                       
                          if header == next
                          {
                              left_most = header
                              right_most = header
                          }
                          else
                              left_most = next
                      }
 
                      if right_most == node
                      {
                          previous = node
                          previous = previous.previous
                    
                          if header == previous
                          {
                              left_most = header
                              right_most = header
                          }
                          else
                               right_most = previous
                      }

                      if node.left.null()
                      {
                           if node.parent == header
                               root = node.right
                           else
                           {
                               if node.parent.left == node
                                   node.parent.left = node.right
                               else
                                   node.parent.right = node.right
                           }

                           if !node.right.null()
                               node.right.parent = node.parent
                      }
                      else
                      {
                          if node.parent == header
                               root = node.left
                           else
                           {
                               if node.parent.left == node
                                   node.parent.left = node.left
                               else
                                   node.parent.right = node.left
                            }

                           if !node.left.null()
                                node.left.parent = node.parent
 
                      }
                      node.parent.balance_tree_remove(from)
                      break
                 }
             }
             return this
        }

        remove2(data)
        {
             node = root

             repeat
             {
                  if node.null()
                  {
                       return null
                  }

                  result = comparer.compare_to(data node.data)

                  if result < 0
                       node = node.left
                  else if result > 0
                       node = node.right
                  else // item found
                  {
                      if !node.left.null() && !node.right.null()
                      {
                         replace = node.left
                         while !replace.right.null() replace = replace.right
                         temp = node.data
                         node.data = replace.data
                         replace.data = temp
                         node = replace
                      }

                      from = direction.from_left
                      if node != node.parent.left from = direction.from_right
 
                      if left_most == node
                      {
                          next = node
                          next = next.next
                       
                          if header == next
                          {
                              left_most = header
                              right_most = header
                          }
                          else
                              left_most = next
                      }
 
                      if right_most == node
                      {
                          previous = node
                          previous = previous.previous
                    
                          if header == previous
                          {
                              left_most = header
                              right_most = header
                          }
                          else
                               right_most = previous
                      }

                      if node.left.null()
                      {
                           if node.parent == header
                               root = node.right
                           else
                           {
                               if node.parent.left == node
                                   node.parent.left = node.right
                               else
                                   node.parent.right = node.right
                           }

                           if !node.right.null()
                               node.right.parent = node.parent
                      }
                      else
                      {
                          if node.parent == header
                               root = node.left
                           else
                           {
                               if node.parent.left == node
                                   node.parent.left = node.left
                               else
                                   node.parent.right = node.left
                            }

                           if !node.left.null()
                                node.left.parent = node.parent
 
                      }
                      node.parent.balance_tree_remove(from)
                      break
                 }
             }
        }


       operator[data]
       {
           get
           {
               if empty
               {
                   return false
               }
               else
               {
                   node = root
 
                   repeat
                   {
                       result = comparer.compare_to(data node.data)

                       if result < 0
                       {
                           if !node.left.null()
                               node = node.left
                           else
                               return false
                       }
                       else if result > 0
                       {
                           if !node.right.null()
                               node = node.right
                           else
                               return false
                       }
                       else // item exists
                           return true
                   }
               }
           }
       }

       get(data)
       {
           if empty throw "empty collection"

           node = root
 
           repeat
           {
               result = comparer.compare_to(data node.data)
               if result < 0
               {
                  if !node.left.null()
                     node = node.left
                  else
                     throw "item: " + (string)data + " not found in collection"
               }
               else if result > 0
               {
                   if !node.right.null()
                       node = node.right
                    else
                      throw "item: " + (string)data + " not found in collection"
               }
               else // item exists
                   return node.data
            }
        }

      last
       {
           get
           {
               if empty
                  throw "empty set"
               else
                  return header.right.data
           }
       }

        iterate()
        {
            if iterator.null()
            {
               iterator = left_most
               if iterator == header
                   return iterator(false none())
               else
                   return iterator(true iterator.data) 
            }
            else
            {
               iterator = iterator.next
  
               if iterator == header
                   return  iterator(false none())
               else
                   return iterator(true iterator.data)
            }
        }

        count
        {
           get
           {
               return root.count
           }
        }

 
        depth
        {
           get
           {
               return root.depth
           }
        }

        operator==(compare)
        {
         if this < compare return false
         if compare < this return false
         return true
        }

        operator!=(compare)
        {
         if this < compare return true
         if compare < this return true
         return false
        }

        operator<(c)
        {
         first1 = begin
         last1 = end
         first2 = c.begin
         last2 = c.end

         while first1 != last1 && first2 != last2
         {
            result = comparer.compare_to(first1.data first2.data)
            if result >= 0
            {
                first1 = first1.next
                first2 = first2.next
            }
            else return true
         }
         a = count
         b = c.count
         return a < b
      }

      begin { get { return header.left } }

      end { get { return header } }

      operator string()
      {
          out = "{"
          first1 = begin
          last1 = end
          while first1 != last1 
          {
              out = out + (string)first1.data
              first1 = first1.next
              if first1 != last1 out = out + ","
          }
          out = out + "}"
          return out
      }

       operator|(b)
       {
           r = new set()

           first1 = begin
           last1 = end
           first2 = b.begin
           last2 = b.end

            while first1 != last1 && first2 != last2
            {
                result = comparer.compare_to(first1.data first2.data)
 
                if result < 0
                {
                    r << first1.data
                    first1 = first1.next
                }

                else if result > 0
                {
                    r << first2.data
                    first2 = first2.next
                }

                else
                {
                    r << first1.data
                    first1 = first1.next
                    first2 = first2.next
                }
            }
 
            while first1 != last1
            {
                r << first1.data
                first1 = first1.next
            }
            while first2 != last2
            {
                r << first2.data
                first2 = first2.next
            }
            return r
       }

       operator&(b)
       {
           r = new set()

           first1 = begin
           last1 = end
           first2 = b.begin
           last2 = b.end

            while first1 != last1 && first2 != last2
            {
                result = comparer.compare_to(first1.data first2.data)

                if result < 0
                {
                   first1 = first1.next
                }

                else if result > 0
                {
                   first2 = first2.next
                }

                else
                {
                   r << first1.data
                   first1 = first1.next
                   first2 = first2.next
                }
            }
 
            return r
       }

       operator^(b)
       {
           r = new set()

           first1 = begin
           last1 = end
           first2 = b.begin
           last2 = b.end

            while first1 != last1 && first2 != last2
            {
                result = comparer.compare_to(first1.data first2.data)

                if result < 0
                {
                   r << first1.data
                   first1 = first1.next
                }

                else if result > 0
                {
                   r << first2.data
                   first2 = first2.next
                }

                else
                {
                   first1 = first1.next
                   first2 = first2.next
                }
            }
 
            while first1 != last1
            {
                r << first1.data
                first1 = first1.next
            }
            while first2 != last2
            {
                r << first2.data
                first2 = first2.next
            }
            return r
       }

       operator-(b)
       {
           r = new set()

           first1 = begin
           last1 = end
           first2 = b.begin
           last2 = b.end

            while first1 != last1 && first2 != last2
            {
                result = comparer.compare_to(first1.data first2.data)

                if result < 0
                {
                   r << first1.data
                   first1 = first1.next
                }

                else if result > 0
                {
                   r << first2.data
                   first1 = first1.next
                   first2 = first2.next
                }

                else
                {
                   first1 = first1.next
                   first2 = first2.next
                }
            }
 
            while first1 != last1
            {
                r << first1.data
                first1 = first1.next
            }
            return r
       }
    }

class tree
{
  s

  tree()
  {
      s = set()
  }

  operator<<(e)
  {
       s << e
       return this
  }

  operator[key]
  {
      get
      {
           if empty
               throw "entry not found exception"
           else
           {
               node = s.root
 
               repeat
               {
                   if key < node.data
                   {
                       if !node.left.null()
                           node = node.left
                       else
                           throw "entry not found exception"
                   }
                   else
                   {
                       if key == node.data
                           return node.data
                       else
                       {
                           if !node.right.null()
                               node = node.right
                           else
                               throw "entry not found exception"
                       }
                   }
               }
          }
     }   
  }

  operator>>(e)
  {
       entry = this[e]
       s >> entry
  }

  remove(key)
  {
      s >> key_value(key)
  }


  iterate()
  {
      return s.iterate()
   }

   count
   {
      get
      {
         return s.count
      }
   }

   empty
   {
       get
       {
           return s.empty
       }
   }


   last
   {
       get
       {
           if empty
              throw "empty tree"
           else
              return s.last
       }
   }

    operator string()
    {
       return (string)s
     }
}

class dictionary
{
  s

    dictionary()
    {
        s = set()
    }

    operator<<(key_value)
    {
       s << key_value
       return this
    }

    add(key value)
    {
       s << key_value(key value)
    }

    operator[key]
    {
       set
       {
           try { s >> key_value(key) } catch {}
           s << key_value(key value)
       }
       get
       {
          r = s.get(key_value(key))
          return r.value
       }
    }

    operator>>(key)
    {
        s >> key_value(key)
        return this
    }

    iterate()
    {
        return s.iterate()
    }

    count
    {
        get
        {
            return s.count
        }  
    }

    operator string()
    {
        return (string)s
    }
}

class key_value
{
  key
  value

  key_value(key_set)
  {
     key = key_set
     value = nul
  }

  key_value(key_set  value_set)
  {
     key = key_set
     value = value_set
  }

  operator<(kv)
  {
      return key < kv.key
  }

  operator string()
  {
    if value.nul()
       return "(" + (string)key + " null)"
    else
       return "(" + (string)key + " " + (string)value  + ")"
  }
}

class array
{
  s        // this is a set of key/value pairs.
  iterator // this field holds an iterator for the array.

  array()   // no parameters required phor array construction.
  {
   s = set()   // create a set of key/value pairs.
   iterator = null // the iterator is initially set to null.
  }

  begin { get { return s.header.left } }   // property: used to commence manual iteration.

  end { get { return s.header } } // property: used to define the end item of iteration.

  operator<(a) // less than operator is called by the avl tree algorithms
  {             // this operator implies phor instance that you could potentially have sets of arrays.

    if keys < a.keys  // compare the key sets first.
       return true
    else if a.keys < keys
       return false
    else               // the key sets are equal  therephore compare array elements.
    {
     first1 = begin
     last1 = end
     first2 = a.begin
     last2 = a.end

     while first1 != last1 && first2 != last2
     {
       if first1.data.value < first2.data.value
        return true
       else
       {
         if first2.data.value < first1.data.value
          return false
         else
         {
            first1 = first1.next
            first2 = first2.next
         }
       }
     }

     return false
    }
  }

    operator==(compare) // equals and not equals derive from operator<
    {
     if this < compare return false
     if compare < this return false
     return true
    }

    operator!=(compare)
    {
     if this < compare return true
     if compare < this return true
     return false
    }

  operator<<(e) // this operator adds an element to the end of the array.
  {
     try
     {
         this[s.last.key + +b] = e
     }
     catch
     {
         this[+a] = e
     }
     return this
  }


  operator[key] // this is the array indexer.
  {
       set
       {
           try { s >> key_value(key) } catch {}
           s << key_value(integer(key) value)
       }
       get
       {
          result = s.get(key_value(key))
          return result.value
       }
  }

  operator>>(key) // this operator removes an element from the array.
  {
   s >> key_value(key)
   return this
  }


  iterate() // and this is how to iterate on the array.
  {
      if iterator.null()
      {
         iterator = s.left_most
         if iterator == s.header
             return iterator(false none())
         else
             return iterator(true iterator.data.value)
      }
      else
      {
         iterator = iterator.next
  
         if iterator == s.header
         {
             iterator = null
             return iterator(false none())
         }
         else
             return iterator(true iterator.data.value)
      }
   }

   count // this property returns a count of elements in the array.
   {
      get
      {
         return s.count
      }
   }

   empty // is the array empty? (Property of course).
   {
       get
       {
           return s.empty
       }
   }


   last // returns the value of the last element in the array.
   {
       get
       {
           if empty
                 throw "empty array"
           else
               return s.last.value
       }
   }

   📟 string() // converts the array to a string
    {
       out = "{"

       iterator = s.left_most
       while iterator != s.header
       {
           _value = iterator.data.value
           out = out + (string)_value
           if iterator != s.right_most
              out = out + ","
           iterator = iterator.next
       }
       out = out + "}"
       return out
    }

   keys // return the set of keys of the array (a set of integers).
   {
      get
      {
          k = set()
          for e s k << e.key     
          return k
      }
   }

   sort // unloads the set into a value and reloads in sorted order.
   {
       get
       {
           sort_bag = bag()
           for e s sort_bag << e.value
           a = new array()
           for g sort_bag a << g
           return a
        }
   }

}

// and here is a test program

using system
space sampleB
{
  sampleB()
  {
    try
    {
       🌳 = { "A" "B" "C" }                     // create a tree

       🌳 << "D" << "E"

       🎛️ << "Found: " << 🌳["B"] << "\n"
 
       for inst 🌳 🎛️ << inst << "\n"

       🎛️ << 🌳 << "\n"

       💰 = bag() { 1 1 2 3 }                  // create a bag

       🎛️ << 💰 << "\n"

       🪣 = ["D" "C" "B" "A"]                   // create an array

       🎛️ << 🪣 << "\n"

       🎛️ << 🪣.sort << "\n"

       🪣[4] = "E"

       🎛️ << 🪣 << "\n"

       📘 = <[0 "hello"] [1 "world"]>         // create a dictionary

       🎛️ << 📘 << "\n"

       📘[2] = "goodbye"

       🎛️ << 📘 << "\n"
    }    
    catch
    {
      🎛️ << exception << "\n"
    } 
  
  }

}

// The output of the program is shown below.

Found: B
A
B
C
D
E
{A,B,C,D,E}
{1,1,2,3}
{D,C,B,A}
{A,B,C,D}
{D,C,B,A,E}
{(0 hello),(1 world)}
{(0 hello),(1 world),(2 goodbye)}

Go

A package:

package avl

// AVL tree adapted from Julienne Walker's presentation at
// http://eternallyconfuzzled.com/tuts/datastructures/jsw_tut_avl.aspx.
// This port uses similar indentifier names.

// The Key interface must be supported by data stored in the AVL tree.
type Key interface {
    Less(Key) bool
    Eq(Key) bool
}

// Node is a node in an AVL tree.
type Node struct {
    Data    Key      // anything comparable with Less and Eq.
    Balance int      // balance factor
    Link    [2]*Node // children, indexed by "direction", 0 or 1.
}

// A little readability function for returning the opposite of a direction,
// where a direction is 0 or 1.  Go inlines this.
// Where JW writes !dir, this code has opp(dir).
func opp(dir int) int {
    return 1 - dir
}

// single rotation
func single(root *Node, dir int) *Node {
    save := root.Link[opp(dir)]
    root.Link[opp(dir)] = save.Link[dir]
    save.Link[dir] = root
    return save
}

// double rotation
func double(root *Node, dir int) *Node {
    save := root.Link[opp(dir)].Link[dir]

    root.Link[opp(dir)].Link[dir] = save.Link[opp(dir)]
    save.Link[opp(dir)] = root.Link[opp(dir)]
    root.Link[opp(dir)] = save

    save = root.Link[opp(dir)]
    root.Link[opp(dir)] = save.Link[dir]
    save.Link[dir] = root
    return save
}

// adjust valance factors after double rotation
func adjustBalance(root *Node, dir, bal int) {
    n := root.Link[dir]
    nn := n.Link[opp(dir)]
    switch nn.Balance {
    case 0:
        root.Balance = 0
        n.Balance = 0
    case bal:
        root.Balance = -bal
        n.Balance = 0
    default:
        root.Balance = 0
        n.Balance = bal
    }
    nn.Balance = 0
}

func insertBalance(root *Node, dir int) *Node {
    n := root.Link[dir]
    bal := 2*dir - 1
    if n.Balance == bal {
        root.Balance = 0
        n.Balance = 0
        return single(root, opp(dir))
    }
    adjustBalance(root, dir, bal)
    return double(root, opp(dir))
}

func insertR(root *Node, data Key) (*Node, bool) {
    if root == nil {
        return &Node{Data: data}, false
    }
    dir := 0
    if root.Data.Less(data) {
        dir = 1
    }
    var done bool
    root.Link[dir], done = insertR(root.Link[dir], data)
    if done {
        return root, true
    }
    root.Balance += 2*dir - 1
    switch root.Balance {
    case 0:
        return root, true
    case 1, -1:
        return root, false
    }
    return insertBalance(root, dir), true
}

// Insert a node into the AVL tree.
// Data is inserted even if other data with the same key already exists.
func Insert(tree **Node, data Key) {
    *tree, _ = insertR(*tree, data)
}

func removeBalance(root *Node, dir int) (*Node, bool) {
    n := root.Link[opp(dir)]
    bal := 2*dir - 1
    switch n.Balance {
    case -bal:
        root.Balance = 0
        n.Balance = 0
        return single(root, dir), false
    case bal:
        adjustBalance(root, opp(dir), -bal)
        return double(root, dir), false
    }
    root.Balance = -bal
    n.Balance = bal
    return single(root, dir), true
}

func removeR(root *Node, data Key) (*Node, bool) {
    if root == nil {
        return nil, false
    }
    if root.Data.Eq(data) {
        switch {
        case root.Link[0] == nil:
            return root.Link[1], false
        case root.Link[1] == nil:
            return root.Link[0], false
        }
        heir := root.Link[0]
        for heir.Link[1] != nil {
            heir = heir.Link[1]
        }
        root.Data = heir.Data
        data = heir.Data
    }
    dir := 0
    if root.Data.Less(data) {
        dir = 1
    }
    var done bool
    root.Link[dir], done = removeR(root.Link[dir], data)
    if done {
        return root, true
    }
    root.Balance += 1 - 2*dir
    switch root.Balance {
    case 1, -1:
        return root, true
    case 0:
        return root, false
    }
    return removeBalance(root, dir)
}

// Remove a single item from an AVL tree.
// If key does not exist, function has no effect.
func Remove(tree **Node, data Key) {
    *tree, _ = removeR(*tree, data)
}

A demonstration program:

package main

import (
    "encoding/json"
    "fmt"
    "log"

    "avl"
)

type intKey int

// satisfy avl.Key
func (k intKey) Less(k2 avl.Key) bool { return k < k2.(intKey) }
func (k intKey) Eq(k2 avl.Key) bool   { return k == k2.(intKey) }

// use json for cheap tree visualization
func dump(tree *avl.Node) {
    b, err := json.MarshalIndent(tree, "", "   ")
    if err != nil {
        log.Fatal(err)
    }
    fmt.Println(string(b))
}

func main() {
    var tree *avl.Node
    fmt.Println("Empty tree:")
    dump(tree)

    fmt.Println("\nInsert test:")
    avl.Insert(&tree, intKey(3))
    avl.Insert(&tree, intKey(1))
    avl.Insert(&tree, intKey(4))
    avl.Insert(&tree, intKey(1))
    avl.Insert(&tree, intKey(5))
    dump(tree)

    fmt.Println("\nRemove test:")
    avl.Remove(&tree, intKey(3))
    avl.Remove(&tree, intKey(1))
    dump(tree)
}
Output:
Empty tree:
null

Insert test:
{
   "Data": 3,
   "Balance": 0,
   "Link": [
      {
         "Data": 1,
         "Balance": -1,
         "Link": [
            {
               "Data": 1,
               "Balance": 0,
               "Link": [
                  null,
                  null
               ]
            },
            null
         ]
      },
      {
         "Data": 4,
         "Balance": 1,
         "Link": [
            null,
            {
               "Data": 5,
               "Balance": 0,
               "Link": [
                  null,
                  null
               ]
            }
         ]
      }
   ]
}

Remove test:
{
   "Data": 4,
   "Balance": 0,
   "Link": [
      {
         "Data": 1,
         "Balance": 0,
         "Link": [
            null,
            null
         ]
      },
      {
         "Data": 5,
         "Balance": 0,
         "Link": [
            null,
            null
         ]
      }
   ]
}

Haskell

Based on solution of homework #4 from course http://www.seas.upenn.edu/~cis194/spring13/lectures.html.

data Tree a
  = Leaf
  | Node
      Int
      (Tree a)
      a
      (Tree a)
  deriving (Show, Eq)
 
foldTree :: Ord a => [a] -> Tree a
foldTree = foldr insert Leaf
 
height :: Tree a -> Int
height Leaf = -1
height (Node h _ _ _) = h
 
depth :: Tree a -> Tree a -> Int
depth a b = succ (max (height a) (height b))
 
insert :: Ord a => a -> Tree a -> Tree a
insert v Leaf = Node 1 Leaf v Leaf
insert v t@(Node n left v_ right)
  | v_ < v = rotate $ Node n left v_ (insert v right)
  | v_ > v = rotate $ Node n (insert v left) v_ right
  | otherwise = t
 
max_ :: Ord a => Tree a -> Maybe a
max_ Leaf = Nothing
max_ (Node _ _ v right) =
  case right of
    Leaf -> Just v
    _ -> max_ right
 
delete :: Ord a => a -> Tree a -> Tree a
delete _ Leaf = Leaf
delete x (Node h left v right)
  | x == v =
    maybe left (rotate . (Node h left <*> (`delete` right))) (max_ right)
  | x > v = rotate $ Node h left v (delete x right)
  | x < v = rotate $ Node h (delete x left) v right
 
rotate :: Tree a -> Tree a
rotate Leaf = Leaf
rotate (Node h (Node lh ll lv lr) v r)
  -- Left Left.
  | lh - height r > 1 && height ll - height lr > 0 =
    Node lh ll lv (Node (depth r lr) lr v r)
rotate (Node h l v (Node rh rl rv rr))
  -- Right Right.
  | rh - height l > 1 && height rr - height rl > 0 =
    Node rh (Node (depth l rl) l v rl) rv rr
rotate (Node h (Node lh ll lv (Node rh rl rv rr)) v r)
  -- Left Right.
  | lh - height r > 1 =
    Node h (Node (rh + 1) (Node (lh - 1) ll lv rl) rv rr) v r
rotate (Node h l v (Node rh (Node lh ll lv lr) rv rr))
  -- Right Left.
  | rh - height l > 1 =
    Node h l v (Node (lh + 1) ll lv (Node (rh - 1) lr rv rr))
rotate (Node h l v r) =
  -- Re-weighting.
  let (l_, r_) = (rotate l, rotate r)
   in Node (depth l_ r_) l_ v r_
 
draw :: Show a => Tree a -> String
draw t = '\n' : draw_ t 0 <> "\n"
  where
    draw_ Leaf _ = []
    draw_ (Node h l v r) d = draw_ r (d + 1) <> node <> draw_ l (d + 1)
      where
        node = padding d <> show (v, h) <> "\n"
        padding n = replicate (n * 4) ' '
 
main :: IO ()
main = putStr $ draw $ foldTree [1 .. 31]
Output:
                (31,0)
            (30,1)
                (29,0)
        (28,2)
                (27,0)
            (26,1)
                (25,0)
    (24,3)
                (23,0)
            (22,1)
                (21,0)
        (20,2)
                (19,0)
            (18,1)
                (17,0)
(16,4)
                (15,0)
            (14,1)
                (13,0)
        (12,2)
                (11,0)
            (10,1)
                (9,0)
    (8,3)
                (7,0)
            (6,1)
                (5,0)
        (4,2)
                (3,0)
            (2,1)
                (1,0)

J

Caution: AVL trees are not cache friendly. Linear search is significantly faster (roughly six times faster for a list of 1e8 numbers on current machines and arbitrary data), and using small cached copies of recent updates allows time for updates to be inserted into a fresh copy of the larger list (on a different thread, or failover machine -- search the current "hot copy" before searching the larger "cold copy"). Use structure of arrays for best performance with that approach. (Typical avl implementation also uses memory equivalent to several copies of a flat list.)

Implementation:

insert=: {{
  X=.1 {::2{.x,x  NB. middle element of x (don't fail on empty x)
  Y=.1 {::2{.y,y  NB. middle element of y (don't fail on empty y)
  select.#y
    case.0 do.x   NB. y is an empty node
    case.1 do.    NB. y is a leaf node
      select.*Y-X
        case._1 do.a:,y;<x
        case. 0 do.y
        case. 1 do.x;y;a:
      end.
    case.3 do.   NB. y is a parent node
      select.*Y-X
        case._1 do.balance (}:y),<x insert 2{::y
        case. 0 do.y
        case. 1 do.balance (x insert 0{::y);}.y
      end.
  end.
}}

delete=: {{
  select.#y
    case.0 do.y
    case.1 do.y-.x
    case.3 do.
      select.*(1{::y)-x
        case._1 do.balance (}:y),<x delete 2{::y
        case. 0 do.balance (0{::y) insert 2{::y
        case. 1 do.balance (x delete 0{::y);}.y
      end.
    end.
}}

lookup=: {{
  select.#y
    case.0 do.y
    case.1 do.if.x=y do.y else.'' end.
    case.3 do.
      select.*(1{::y)-x
        case._1 do.x lookup 2{::y
        case. 0 do.y
        case. 1 do.x lookup 0{::y
      end.
  end.
}}

clean=: {{
  's0 x s2'=. #every y
  if.*/0=s0,s2 do. 1{:: y NB. degenerate to leaf
  else. y end.
}}

balance=: {{
  if. 2>#y do. y return.end. NB. leaf or empty
  's0 x s2'=. ,#every y
  if. */0=s0,s2 do. 1{:: y return.end. NB. degenerate to leaf
  'l0 x l2'=. L.every y
  if. 2>|l2-l0 do. y return.end. NB. adequately balanced
  if. l2>l0 do.
    'l20 x l22'=. L.every 2{::y
    if. l22 >: l20 do. rotLeft y
    else. rotRightLeft y end.
  else.
    'l00 x l02'=. L.every 0{::y
    if. l00 >: l02 do. rotRight y
    else. rotLeftRight y end.
  end. 
}}

rotLeft=: {{
  't0 t1 t2'=. y
  't20 t21 t22'=. t2
  (clean t0;t1;<t20);t21;<t22
}}

rotRight=: {{
  't0 t1 t2'=. y
  't00 t01 t02'=. t0
  t00;t01;<clean t02;t1;<t2
}}

rotRightLeft=: {{
  't0 t1 t2'=. y
  rotLeft t0;t1;<rotRight t2
}}

rotLeftRight=: {{
  't0 t1 t2'=. y
  rotRight (rotLeft t0);t1;<t2
}}

Tree is right argument, leaf value is left argument. An empty tree has no elements, leaves have 1 element, non-empty non-leaf nodes have three elements.

Some examples:

   insert/i.20
┌────────────────────────────┬─┬─────────────────────────────────────────────────┐
│┌─────────────────┬─┬──────┐│8│┌─────────────────────┬──┬──────────────────────┐│
││┌──────┬─┬──────┐│5│┌┬─┬─┐││ ││┌───────┬──┬────────┐│14│┌────────┬──┬────────┐││
│││┌─┬─┬┐│2│┌┬─┬─┐││ │││6│7│││ │││┌┬─┬──┐│11│┌┬──┬──┐││  ││┌┬──┬──┐│17│┌┬──┬──┐│││
││││0│1│││ │││3│4│││ │└┴─┴─┘││ │││││9│10││  │││12│13│││  ││││15│16││  │││18│19││││
│││└─┴─┴┘│ │└┴─┴─┘││ │      ││ │││└┴─┴──┘│  │└┴──┴──┘││  ││└┴──┴──┘│  │└┴──┴──┘│││
││└──────┴─┴──────┘│ │      ││ ││└───────┴──┴────────┘│  │└────────┴──┴────────┘││
│└─────────────────┴─┴──────┘│ │└─────────────────────┴──┴──────────────────────┘│
└────────────────────────────┴─┴─────────────────────────────────────────────────┘
   2 delete insert/i.20
┌───────────────────────┬─┬─────────────────────────────────────────────────┐
│┌────────────┬─┬──────┐│8│┌─────────────────────┬──┬──────────────────────┐│
││┌──────┬─┬─┐│5│┌┬─┬─┐││ ││┌───────┬──┬────────┐│14│┌────────┬──┬────────┐││
│││┌─┬─┬┐│3│4││ │││6│7│││ │││┌┬─┬──┐│11│┌┬──┬──┐││  ││┌┬──┬──┐│17│┌┬──┬──┐│││
││││0│1│││ │ ││ │└┴─┴─┘││ │││││9│10││  │││12│13│││  ││││15│16││  │││18│19││││
│││└─┴─┴┘│ │ ││ │      ││ │││└┴─┴──┘│  │└┴──┴──┘││  ││└┴──┴──┘│  │└┴──┴──┘│││
││└──────┴─┴─┘│ │      ││ ││└───────┴──┴────────┘│  │└────────┴──┴────────┘││
│└────────────┴─┴──────┘│ │└─────────────────────┴──┴──────────────────────┘│
└───────────────────────┴─┴─────────────────────────────────────────────────┘
   5 lookup 2 delete insert/i.20
┌────────────┬─┬──────┐
│┌──────┬─┬─┐│5│┌┬─┬─┐│
││┌─┬─┬┐│3│4││ │││6│7││
│││0│1│││ │ ││ │└┴─┴─┘│
││└─┴─┴┘│ │ ││ │      │
│└──────┴─┴─┘│ │      │
└────────────┴─┴──────┘

Java

This code has been cobbled together from various online examples. It's not easy to find a clear and complete explanation of AVL trees. Textbooks tend to concentrate on red-black trees because of their better efficiency. (AVL trees need to make 2 passes through the tree when inserting and deleting: one down to find the node to operate upon and one up to rebalance the tree.)

public class AVLtree {

    private Node root;

    private static class Node {
        private int key;
        private int balance;
        private int height;
        private Node left;
        private Node right;
        private Node parent;

        Node(int key, Node parent) {
            this.key = key;
            this.parent = parent;
        }
    }

    public boolean insert(int key) {
        if (root == null) {
            root = new Node(key, null);
            return true;
        }

        Node n = root;
        while (true) {
            if (n.key == key)
                return false;

            Node parent = n;

            boolean goLeft = n.key > key;
            n = goLeft ? n.left : n.right;

            if (n == null) {
                if (goLeft) {
                    parent.left = new Node(key, parent);
                } else {
                    parent.right = new Node(key, parent);
                }
                rebalance(parent);
                break;
            }
        }
        return true;
    }

    private void delete(Node node) {
        if (node.left == null && node.right == null) {
            if (node.parent == null) {
                root = null;
            } else {
                Node parent = node.parent;
                if (parent.left == node) {
                    parent.left = null;
                } else {
                    parent.right = null;
                }
                rebalance(parent);
            }
            return;
        }

        if (node.left != null) {
            Node child = node.left;
            while (child.right != null) child = child.right;
            node.key = child.key;
            delete(child);
        } else {
            Node child = node.right;
            while (child.left != null) child = child.left;
            node.key = child.key;
            delete(child);
        }
    }

    public void delete(int delKey) {
        if (root == null)
            return;

        Node child = root;
        while (child != null) {
            Node node = child;
            child = delKey >= node.key ? node.right : node.left;
            if (delKey == node.key) {
                delete(node);
                return;
            }
        }
    }

    private void rebalance(Node n) {
        setBalance(n);

        if (n.balance == -2) {
            if (height(n.left.left) >= height(n.left.right))
                n = rotateRight(n);
            else
                n = rotateLeftThenRight(n);

        } else if (n.balance == 2) {
            if (height(n.right.right) >= height(n.right.left))
                n = rotateLeft(n);
            else
                n = rotateRightThenLeft(n);
        }

        if (n.parent != null) {
            rebalance(n.parent);
        } else {
            root = n;
        }
    }

    private Node rotateLeft(Node a) {

        Node b = a.right;
        b.parent = a.parent;

        a.right = b.left;

        if (a.right != null)
            a.right.parent = a;

        b.left = a;
        a.parent = b;

        if (b.parent != null) {
            if (b.parent.right == a) {
                b.parent.right = b;
            } else {
                b.parent.left = b;
            }
        }

        setBalance(a, b);

        return b;
    }

    private Node rotateRight(Node a) {

        Node b = a.left;
        b.parent = a.parent;

        a.left = b.right;

        if (a.left != null)
            a.left.parent = a;

        b.right = a;
        a.parent = b;

        if (b.parent != null) {
            if (b.parent.right == a) {
                b.parent.right = b;
            } else {
                b.parent.left = b;
            }
        }

        setBalance(a, b);

        return b;
    }

    private Node rotateLeftThenRight(Node n) {
        n.left = rotateLeft(n.left);
        return rotateRight(n);
    }

    private Node rotateRightThenLeft(Node n) {
        n.right = rotateRight(n.right);
        return rotateLeft(n);
    }

    private int height(Node n) {
        if (n == null)
            return -1;
        return n.height;
    }

    private void setBalance(Node... nodes) {
        for (Node n : nodes) {
            reheight(n);
            n.balance = height(n.right) - height(n.left);
        }
    }

    public void printBalance() {
        printBalance(root);
    }

    private void printBalance(Node n) {
        if (n != null) {
            printBalance(n.left);
            System.out.printf("%s ", n.balance);
            printBalance(n.right);
        }
    }

    private void reheight(Node node) {
        if (node != null) {
            node.height = 1 + Math.max(height(node.left), height(node.right));
        }
    }

    public static void main(String[] args) {
        AVLtree tree = new AVLtree();

        System.out.println("Inserting values 1 to 10");
        for (int i = 1; i < 10; i++)
            tree.insert(i);

        System.out.print("Printing balance: ");
        tree.printBalance();
    }
}
Inserting values 1 to 10
Printing balance: 0 0 0 1 0 1 0 0 0

More elaborate version

See AVL_tree/Java

JavaScript

function tree(less, val, more) {
  return {
    depth: 1+Math.max(less.depth, more.depth),
    less: less,
    val: val,
    more: more,
  };
}

function node(val) {
  return tree({depth: 0}, val, {depth: 0});
}

function insert(x,y) {
  if (0 == y.depth) return x;
  if (0 == x.depth) return y;
  if (1 == x.depth && 1 == y.depth) {
    switch (Math.sign(y.val)-x.val) {
      case -1: return tree(y, x.val, {depth: 0});
      case 0: return y;
      case 1: return tree(x, y.val, {depth: 0});
    }
  }
  switch (Math.sign(y.val-x.val)) {
    case -1: return balance(insert(x.less, y), x.val, x.more);
    case 0: return balance(insert(x.less, y.less), x.val, insert(x.more, y.more));
    case 1: return balance(x.less. x.val, insert(x.more, y));
  }
}

function balance(less,val,more) {
  if (2 > Math.abs(less.depth-more.depth))
    return tree(less,val,more);
  if (more.depth > less.depth) {
    if (more.more.depth >= more.less.depth) {
      // 'more' was heavy
      return moreHeavy(less, val, more);
    } else {
      return moreHeavy(less,val,lessHeavy(more.less, more.val, more.more));
    }
  } else {
    if(less.less.depth >= less.more.depth) {
      return lessHeavy(less, val, more);
    } else {
      return lessHeavy(moreHeavy(less.less, less.val, less.more), val, more);
    }
  }
}

function moreHeavy(less,val,more) {
  return tree(tree(less,val,more.less), more.val, more.more)
}

function lessHeavy(less,val,more) {
  return tree(less.less, less.val, tree(less.more, val, more));
}

function remove(val, y) {
  switch (y.depth) {
    case 0: return y;
    case 1:
      if (val == y.val) {
        return y.less;
      } else {
        return y;
      }
    default:
      switch (Math.sign(y.val - val)) {
        case -1: return balance(y.less, y.val, remove(val, y.more));
        case  0: return insert(y.less, y.more);
        case  1: return balance(remove(val, y.less), y.val, y.more)
      }
  }
}

function lookup(val, y) {
  switch (y.depth) {
    case 0: return y;
    case 1: if (val == y.val) {
      return y;
    } else {
      return {depth: 0};
    }
    default: 
      switch (Math.sign(y.val-val)) {
        case -1: return lookup(val, y.more);
        case  0: return y;
        case  1: return lookup(val, y.less);
      }
  }
}

Some examples:

function dumptree(t) {
  switch (t.depth) {
    case 0: return '';
    case 1: return t.val;
    default: return '('+dumptree(t.less)+','+t.val+','+dumptree(t.more)+')';
  }
}
function example() {
  let t= node(0);
  for (let j= 1; j<20; j++) {
    t= insert(node(j), t);
  }
  console.log(dumptree(t));
  t= remove(2, t);
  console.log(dumptree(t));
  console.log(dumptree(lookup(5, t)));
  console.log(dumptree(remove(5, t)));
}

example();
Output:
(((((0,1,2),3,(4,5,)),6,((7,8,),9,)),10,(((11,12,),13,),14,)),15,(((16,17,),18,),19,))
(((((0,1,),3,(4,5,)),6,((7,8,),9,)),10,(((11,12,),13,),14,)),15,(((16,17,),18,),19,))
(4,5,)
(((((0,1,),3,4),6,((7,8,),9,)),10,(((11,12,),13,),14,)),15,(((16,17,),18,),19,))

Julia

Translation of: Sidef
module AVLTrees

import Base.print
export AVLNode, AVLTree, insert, deletekey, deletevalue, findnodebykey, findnodebyvalue, allnodes

@enum Direction LEFT RIGHT
avlhash(x) = Int32(hash(x) & 0xfffffff)
const MIDHASH = Int32(div(0xfffffff, 2))

mutable struct AVLNode{T}
    value::T
    key::Int32
    balance::Int32
    left::Union{AVLNode, Nothing}
    right::Union{AVLNode, Nothing}
    parent::Union{AVLNode, Nothing}
end
AVLNode(v::T, b, l, r, p) where T <: Real = AVLNode(v, avlhash(v), Int32(b), l, r, p)
AVLNode(v::T, h, b::Int64, l, r, p) where T <: Real = AVLNode(v, h, Int32(b), l, r, p)
AVLNode(v::T) where T <: Real = AVLNode(v, avlhash(v), Int32(0), nothing, nothing, nothing)

AVLTree(typ::Type) = AVLNode(typ(0), MIDHASH, Int32(0), nothing, nothing, nothing)
const MaybeAVL = Union{AVLNode, Nothing}

height(node::MaybeAVL) = (node == nothing) ? 0 : 1 + max(height(node.right), height(node.left))

function insert(node, value)
    if node == nothing
        node = AVLNode(value)
        return true
    end
    key, n, parent::MaybeAVL = avlhash(value), node, nothing
    while true
        if n.key == key
            return false
        end
        parent = n
        ngreater = n.key > key
        n = ngreater ? n.left : n.right
        if n == nothing
            if ngreater
                parent.left = AVLNode(value, key, 0, nothing, nothing, parent)
            else
                parent.right = AVLNode(value, key, 0, nothing, nothing, parent)
            end
            rebalance(parent)
            break
        end
    end
    return true
end

function deletekey(node, delkey)
    node == nothing && return nothing
    n, parent = MaybeAVL(node), MaybeAVL(node)
    delnode, child = MaybeAVL(nothing), MaybeAVL(node)
    while child != nothing
        parent, n = n, child
        child = delkey >= n.key ? n.right : n.left
        if delkey == n.key
            delnode = n
        end
    end
    if delnode != nothing
        delnode.key = n.key
        delnode.value = n.value
        child = (n.left != nothing) ? n.left : n.right
        if node.key == delkey
            root = child
        else
            if parent.left == n
                parent.left = child
            else
                parent.right = child
            end
            rebalance(parent)
        end
    end
end

deletevalue(node, val) = deletekey(node, avlhash(val))

function rebalance(node::MaybeAVL)
    node == nothing && return nothing
    setbalance(node)
    if node.balance < -1
        if height(node.left.left) >= height(node.left.right)
            node = rotate(node, RIGHT)
        else
            node = rotatetwice(node, LEFT, RIGHT)
        end
    elseif node.balance > 1
        if node.right != nothing && height(node.right.right) >= height(node.right.left)
            node = rotate(node, LEFT)
        else
            node = rotatetwice(node, RIGHT, LEFT)
        end
    end
    if node != nothing && node.parent != nothing
        rebalance(node.parent)
    end
end

function rotate(a, direction)
    (a == nothing || a.parent == nothing) && return nothing
    b = direction == LEFT ? a.right : a.left
    b == nothing && return
    b.parent = a.parent
    if direction == LEFT
        a.right = b.left
    else
        a.left  = b.right
    end
    if a.right != nothing
        a.right.parent = a
    end
    if direction == LEFT
        b.left = a
    else
        b.right = a
    end
    a.parent = b
    if b.parent != nothing
        if b.parent.right == a
            b.parent.right = b
        else
            b.parent.left = b
        end
    end
    setbalance([a, b])
    return b
end

function rotatetwice(n, dir1, dir2)
    n.left = rotate(n.left, dir1)
    rotate(n, dir2)
end

setbalance(n::AVLNode) = begin n.balance = height(n.right) - height(n.left) end
setbalance(n::Nothing) = 0
setbalance(nodes::Vector) = for n in nodes setbalance(n) end

function findnodebykey(node, key)
    result::MaybeAVL = node == nothing ? nothing : node.key == key ? node : 
        node.left != nothing && (n = findbykey(n, key) != nothing) ? n :
        node.right != nothing ? findbykey(node.right, key) : nothing
    return result
end
findnodebyvalue(node, val) = findnodebykey(node, avlhash(v))

function allnodes(node)
    result = AVLNode[]
    if node != nothing
        append!(result, allnodes(node.left))
        if node.key != MIDHASH
            push!(result, node)
        end
        append!(result, node.right)
    end
    return result
end

function Base.print(io::IO, n::MaybeAVL)
    if n != nothing
        n.left != nothing && print(io, n.left)
        print(io, n.key == MIDHASH ? "<ROOT> " : "<$(n.key):$(n.value):$(n.balance)> ")
        n.right != nothing && print(io, n.right)
    end
end

end # module

using .AVLTrees

const tree = AVLTree(Int)

println("Inserting 10 values.")
foreach(x -> insert(tree, x), rand(collect(1:80), 10))
println("Printing tree after insertion: ")
println(tree)
Output:
Inserting 10 values.
Printing tree after insertion:
<35627180:79:1> <51983710:44:0> <55727576:19:0> <95692146:13:0> <119148308:42:0> <131027959:27:0> <ROOT> <144455609:36:0> <172953853:41:1> <203559702:58:1> <217724037:80:0>

Kotlin

Translation of: Java
class AvlTree {
    private var root: Node? = null

    private class Node(var key: Int, var parent: Node?) {
        var balance: Int = 0
        var left : Node? = null
        var right: Node? = null
    }

    fun insert(key: Int): Boolean {
        if (root == null)
            root = Node(key, null)
        else {
            var n: Node? = root
            var parent: Node
            while (true) {
                if (n!!.key == key) return false
                parent = n
                val goLeft = n.key > key
                n = if (goLeft) n.left else n.right
                if (n == null) {
                    if (goLeft)
                        parent.left  = Node(key, parent)
                    else
                        parent.right = Node(key, parent)
                    rebalance(parent)
                    break
                }
            }
        }
        return true
    }

    fun delete(delKey: Int) {
        if (root == null) return
        var n:       Node? = root
        var parent:  Node? = root
        var delNode: Node? = null
        var child:   Node? = root
        while (child != null) {
            parent = n
            n = child
            child = if (delKey >= n.key) n.right else n.left
            if (delKey == n.key) delNode = n
        }
        if (delNode != null) {
            delNode.key = n!!.key
            child = if (n.left != null) n.left else n.right
            if (0 == root!!.key.compareTo(delKey)) {
                root = child

                if (null != root) {
                    root!!.parent = null
                }

            } else {
                if (parent!!.left == n)
                    parent.left = child
                else
                    parent.right = child

                if (null != child) {
                    child.parent = parent
                }

                rebalance(parent)
            }
    }

    private fun rebalance(n: Node) {
        setBalance(n)
        var nn = n
        if (nn.balance == -2)
            if (height(nn.left!!.left) >= height(nn.left!!.right))
                nn = rotateRight(nn)
            else
                nn = rotateLeftThenRight(nn)
        else if (nn.balance == 2)
            if (height(nn.right!!.right) >= height(nn.right!!.left))
                nn = rotateLeft(nn)
            else
                nn = rotateRightThenLeft(nn)
        if (nn.parent != null) rebalance(nn.parent!!)
        else root = nn
    }

    private fun rotateLeft(a: Node): Node {
        val b: Node? = a.right
        b!!.parent = a.parent
        a.right = b.left
        if (a.right != null) a.right!!.parent = a
        b.left = a
        a.parent = b
        if (b.parent != null) {
            if (b.parent!!.right == a)
                b.parent!!.right = b
            else
                b.parent!!.left = b
        }
        setBalance(a, b)
        return b
    }

    private fun rotateRight(a: Node): Node {
        val b: Node? = a.left
        b!!.parent = a.parent
        a.left = b.right
        if (a.left != null) a.left!!.parent = a
        b.right = a
        a.parent = b
        if (b.parent != null) {
            if (b.parent!!.right == a)
                b.parent!!.right = b
            else
                b.parent!!.left = b
        }
        setBalance(a, b)
        return b
    }

    private fun rotateLeftThenRight(n: Node): Node {
        n.left = rotateLeft(n.left!!)
        return rotateRight(n)
    }

    private fun rotateRightThenLeft(n: Node): Node {
        n.right = rotateRight(n.right!!)
        return rotateLeft(n)
    }

    private fun height(n: Node?): Int {
        if (n == null) return -1
        return 1 + Math.max(height(n.left), height(n.right))
    }

    private fun setBalance(vararg nodes: Node) {
        for (n in nodes) n.balance = height(n.right) - height(n.left)
    }

    fun printKey() {
        printKey(root)
        println()
    }

    private fun printKey(n: Node?) {
        if (n != null) {
            printKey(n.left)
            print("${n.key} ")
            printKey(n.right)
        }
    }

    fun printBalance() {
        printBalance(root)
        println()
    }

    private fun printBalance(n: Node?) {
        if (n != null) {
            printBalance(n.left)
            print("${n.balance} ")
            printBalance(n.right)
        }
    }
}

fun main(args: Array<String>) {
    val tree = AvlTree()
    println("Inserting values 1 to 10")
    for (i in 1..10) tree.insert(i)
    print("Printing key     : ")
    tree.printKey()
    print("Printing balance : ")
    tree.printBalance()
}
Output:
Inserting values 1 to 10
Printing key     : 1 2 3 4 5 6 7 8 9 10
Printing balance : 0 0 0 1 0 0 0 0 1 0

Logtalk

The Logtalk library comes with an AVL implementation of its dictionaryp protocol, whose definition begins thusly:

:- object(avltree,
	implements(dictionaryp),
	extends(term)).

% ... lots of elision ...

:- end_object.
Output:

This makes the use of an AVL tree in Logtalk dirt simple. First we load the dictionaries library.

?- logtalk_load(dictionaries(loader)).
% ... messages elided ...
true.

We can make a new, empty AVL tree.

?- avltree::new(Dictionary).
Dictionary = t.

Using Logtalk's broadcast notation to avoid having to repeatedly type avltree:: in front of every operation we can insert some keys, update one, and look up values. Note that since variables in Logtalk, as in most declarative languages, cannot be altered, we actually have several dictionaries (D0 through D4) representing the initial empty state, various intermediate states, as well as the final state.

4 ?- avltree::(
        new(D0),
        insert(D0, a, 1, D1),
        insert(D1, b, 2, D2),
        insert(D2, c, 3, D3),
        update(D3, a, 7, D4),
        lookup(a, Va, D4),
        lookup(c, Vc, D4)).
D0 = t,
D1 = t(a, 1, -, t, t),
D2 = t(a, 1, >, t, t(b, 2, -, t, t)),
D3 = t(b, 2, -, t(a, 1, -, t, t), t(c, 3, -, t, t)),
D4 = t(b, 2, -, t(a, 7, -, t, t), t(c, 3, -, t, t)),
Va = 7,
Vc = 3.

To save some rote typing, the as_dictionary/2 method lets a list of Key-Value pairs be used to initialize a dictionary instead:

?- avltree::(
        as_dictionary([a-1, b-2, c-3, a-7], D), 
        lookup(a, Va, D), 
        lookup(c, Vc, D)).
D = t(b, 2, <, t(a, 7, <, t(a, 1, -, t, t), t), t(c, 3, -, t, t)),
Va = 7,
Vc = 3.

Lua

AVL={balance=0}
AVL.__mt={__index = AVL}


function AVL:new(list)
  local o={}  
  setmetatable(o, AVL.__mt)
  for _,v in ipairs(list or {}) do
    o=o:insert(v)
  end
  return o
end
  
function AVL:rebalance()
  local rotated=false
  if self.balance>1 then
    if self.right.balance<0 then
      self.right, self.right.left.right, self.right.left = self.right.left, self.right, self.right.left.right
      self.right.right.balance=self.right.balance>-1 and 0 or 1
      self.right.balance=self.right.balance>0 and 2 or 1
    end
    self, self.right.left, self.right = self.right, self, self.right.left
    self.left.balance=1-self.balance
    self.balance=self.balance==0 and -1 or 0
    rotated=true
  elseif self.balance<-1 then
    if self.left.balance>0 then
      self.left, self.left.right.left, self.left.right = self.left.right, self.left, self.left.right.left
      self.left.left.balance=self.left.balance<1 and 0 or -1
      self.left.balance=self.left.balance<0 and -2 or -1
    end
    self, self.left.right, self.left = self.left, self, self.left.right
    self.right.balance=-1-self.balance
    self.balance=self.balance==0 and 1 or 0
    rotated=true
  end
  return self,rotated
end

function AVL:insert(v)
  if not self.value then 
    self.value=v
    self.balance=0
    return self,1
  end
  local grow
  if v==self.value then
    return self,0
  elseif v<self.value then
    if not self.left then self.left=self:new() end
    self.left,grow=self.left:insert(v)
    self.balance=self.balance-grow
  else
    if not self.right then self.right=self:new() end
    self.right,grow=self.right:insert(v)
    self.balance=self.balance+grow
  end
  self,rotated=self:rebalance()
  return self, (rotated or self.balance==0) and 0 or grow 
end

function AVL:delete_move(dir,other,mul)
  if self[dir] then
    local sb2,v
    self[dir], sb2, v=self[dir]:delete_move(dir,other,mul)
    self.balance=self.balance+sb2*mul
    self,sb2=self:rebalance()
    return self,(sb2 or self.balance==0) and -1 or 0,v
  else
    return self[other],-1,self.value
  end
end

function AVL:delete(v,isSubtree)
  local grow=0
  if v==self.value then
    local v
    if self.balance>0 then
      self.right,grow,v=self.right:delete_move("left","right",-1)
    elseif self.left then
      self.left,grow,v=self.left:delete_move("right","left",1)
      grow=-grow
    else
      return not isSubtree and AVL:new(),-1
    end
    self.value=v
    self.balance=self.balance+grow
  elseif v<self.value and self.left then
    self.left,grow=self.left:delete(v,true)
    self.balance=self.balance-grow
  elseif v>self.value and self.right then
    self.right,grow=self.right:delete(v,true)
    self.balance=self.balance+grow
  else
    return self,0
  end
  self,rotated=self:rebalance()
  return self, grow~=0 and (rotated or self.balance==0) and -1 or 0
end

-- output functions

function AVL:toList(list)
  if not self.value then return {} end
  list=list or {}
  if self.left then self.left:toList(list) end
  list[#list+1]=self.value
  if self.right then self.right:toList(list) end
  return list
end

function AVL:dump(depth)
  if not self.value then return end
  depth=depth or 0
  if self.right then self.right:dump(depth+1) end
  print(string.rep("    ",depth)..self.value.." ("..self.balance..")")
  if self.left then self.left:dump(depth+1) end
end

-- test

local test=AVL:new{1,10,5,15,20,3,5,14,7,13,2,8,3,4,5,10,9,8,7}

test:dump()
print("\ninsert 17:")
test=test:insert(17)
test:dump()
print("\ndelete 10:")
test=test:delete(10)
test:dump()
print("\nlist:")
print(unpack(test:toList()))
Output:
            20 (0)
        15 (1)
    14 (1)
        13 (0)
10 (-1)
            9 (0)
        8 (0)
            7 (0)
    5 (-1)
                4 (0)
            3 (1)
        2 (1)
            1 (0)

insert 17:
            20 (0)
        17 (0)
            15 (0)
    14 (1)
        13 (0)
10 (-1)
            9 (0)
        8 (0)
            7 (0)
    5 (-1)
                4 (0)
            3 (1)
        2 (1)
            1 (0)

delete 10:
            20 (0)
        17 (0)
            15 (0)
    14 (1)
        13 (0)
9 (-1)
        8 (-1)
            7 (0)
    5 (-1)
                4 (0)
            3 (1)
        2 (1)
            1 (0)

list:
1       2       3       4       5       7       8       9       13      14      15      17      20

Nim

Translation of: Go

We use generics for tree and node definitions. Data stored in the tree must be comparable i.e. their type must allow comparison for equality and for inequality (less than comparison). In order to ensure that, we use the notion of concept proposed by Nim.

#[ AVL tree adapted from Julienne Walker's presentation at
   http://eternallyconfuzzled.com/tuts/datastructures/jsw_tut_avl.aspx.

   Uses bounded recursive versions for insertion and deletion.
]#

type

  # Objects strored in the tree must be comparable.
  Comparable = concept x, y
    (x == y) is bool
    (x < y) is bool

  # Direction used to select a child.
  Direction = enum Left, Right

  # Description of the tree node.
  Node[T: Comparable] = ref object
    data: T                             # Payload.
    balance: range[-2..2]               # Balance factor (bounded).
    links: array[Direction, Node[T]]    # Children.

  # Description of a tree.
  AvlTree[T: Comparable] = object
    root: Node[T]


#---------------------------------------------------------------------------------------------------

func opp(dir: Direction): Direction {.inline.} =
  ## Return the opposite of a direction.
  Direction(1 - ord(dir))

#---------------------------------------------------------------------------------------------------

func single(root: Node; dir: Direction): Node =
  ## Single rotation.

  result = root.links[opp(dir)]
  root.links[opp(dir)] = result.links[dir]
  result.links[dir] = root

#---------------------------------------------------------------------------------------------------

func double(root: Node; dir: Direction): Node =
  ## Double rotation.

  let save = root.links[opp(dir)].links[dir]

  root.links[opp(dir)].links[dir] = save.links[opp(dir)]
  save.links[opp(dir)] = root.links[opp(dir)]
  root.links[opp(dir)] = save

  result = root.links[opp(dir)]
  root.links[opp(dir)] = result.links[dir]
  result.links[dir] = root

#---------------------------------------------------------------------------------------------------

func adjustBalance(root: Node; dir: Direction; balance: int) =
  ## Adjust balance factors after double rotation.

  let node1 = root.links[dir]
  let node2 = node1.links[opp(dir)]

  if node2.balance == 0:
    root.balance = 0
    node1.balance = 0

  elif node2.balance == balance:
    root.balance = -balance
    node1.balance = 0

  else:
    root.balance = 0
    node1.balance = balance

  node2.balance = 0

#---------------------------------------------------------------------------------------------------

func insertBalance(root: Node; dir: Direction): Node =
  ## Rebalancing after an insertion.

  let node = root.links[dir]
  let balance = 2 * ord(dir) - 1

  if node.balance == balance:
    root.balance = 0
    node.balance = 0
    result = root.single(opp(dir))

  else:
    root.adjustBalance(dir, balance)
    result = root.double(opp(dir))

#---------------------------------------------------------------------------------------------------

func insertR(root: Node; data: root.T): tuple[node: Node, done: bool] =
  ## Insert data (recursive way).

  if root.isNil:
    return (Node(data: data), false)

  let dir = if root.data < data: Right else: Left
  var done: bool
  (root.links[dir], done) = root.links[dir].insertR(data)
  if done:
    return (root, true)

  inc root.balance, 2 * ord(dir) - 1
  result = case root.balance
           of 0: (root, true)
           of -1, 1: (root, false)
           else: (root.insertBalance(dir), true)

#---------------------------------------------------------------------------------------------------

func removeBalance(root: Node; dir: Direction): tuple[node: Node, done: bool] =
  ## Rebalancing after a deletion.

  let node = root.links[opp(dir)]
  let balance = 2 * ord(dir) - 1
  if node.balance == -balance:
    root.balance = 0
    node.balance = 0
    result = (root.single(dir), false)
  elif node.balance == balance:
    root.adjustBalance(opp(dir), -balance)
    result = (root.double(dir), false)
  else:
    root.balance = -balance
    node.balance = balance
    result = (root.single(dir), true)

#---------------------------------------------------------------------------------------------------

func removeR(root: Node; data: root.T): tuple[node: Node, done: bool] =
  ## Remove data (recursive way).

  if root.isNil:
    return (nil, false)

  var data = data
  if root.data == data:
    if root.links[Left].isNil:
      return (root.links[Right], false)
    if root.links[Right].isNil:
      return (root.links[Left], false)
    var heir = root.links[Left]
    while not heir.links[Right].isNil:
      heir = heir.links[Right]
    root.data = heir.data
    data = heir.data

  let dir = if root.data < data: Right else: Left
  var done: bool
  (root.links[dir], done) = root.links[dir].removeR(data)
  if done:
    return (root, true)
  dec root.balance, 2 * ord(dir) - 1
  result = case root.balance
           of -1, 1: (root, true)
           of 0: (root, false)
           else: root.removeBalance(dir)

#---------------------------------------------------------------------------------------------------

func insert(tree: var AvlTree; data: tree.T) =
  ## Insert data in an AVL tree.
  tree.root = tree.root.insertR(data).node

#---------------------------------------------------------------------------------------------------

func remove(tree: var AvlTree; data: tree.T) =
  ## Remove data from an AVL tree.
  tree.root = tree.root.removeR(data).node

#———————————————————————————————————————————————————————————————————————————————————————————————————

import json

var tree: AvlTree[int]
echo pretty(%tree)

echo "Insert test:"
tree.insert(3)
tree.insert(1)
tree.insert(4)
tree.insert(1)
tree.insert(5)
echo pretty(%tree)

echo ""
echo "Remove test:"
tree.remove(3)
tree.remove(1)
echo pretty(%tree)
Output:
Insert test:
{
  "root": {
    "data": 3,
    "balance": 0,
    "links": [
      {
        "data": 1,
        "balance": -1,
        "links": [
          {
            "data": 1,
            "balance": 0,
            "links": [
              null,
              null
            ]
          },
          null
        ]
      },
      {
        "data": 4,
        "balance": 1,
        "links": [
          null,
          {
            "data": 5,
            "balance": 0,
            "links": [
              null,
              null
            ]
          }
        ]
      }
    ]
  }
}

Remove test:
{
  "root": {
    "data": 4,
    "balance": 0,
    "links": [
      {
        "data": 1,
        "balance": 0,
        "links": [
          null,
          null
        ]
      },
      {
        "data": 5,
        "balance": 0,
        "links": [
          null,
          null
        ]
      }
    ]
  }
}

Objeck

Translation of: Java
class AVLNode {
  @key : Int;
  @balance : Int;
  @height : Int;
  @left : AVLNode;
  @right : AVLNode;
  @above : AVLNode;
  
  New(key : Int, above : AVLNode) {
    @key := key;
    @above := above;
  }

  method : public : GetKey() ~ Int {
    return @key;
  }

  method : public : GetLeft() ~ AVLNode {
    return @left;
  }

  method : public : GetRight() ~ AVLNode {
    return @right;
  }

  method : public : GetAbove() ~ AVLNode {
    return @above;
  }

  method : public : GetBalance() ~ Int {
    return @balance;
  }

  method : public : GetHeight() ~ Int {
    return @height;
  }

  method : public : SetBalance(balance : Int) ~ Nil {
    @balance := balance;
  }

  method : public : SetHeight(height : Int) ~ Nil {
    @height := height;
  }

  method : public : SetAbove(above : AVLNode) ~ Nil {
    @above := above;
  }

  method : public : SetLeft(left : AVLNode) ~ Nil {
    @left := left;
  }

  method : public : SetRight(right : AVLNode) ~ Nil {
    @right := right;
  }

  method : public : SetKey(key : Int) ~ Nil {
    @key := key;
  }
}

class AVLTree {
  @root : AVLNode;

  New() {}

  method : public : Insert(key : Int) ~ Bool {
    if(@root = Nil) {
      @root := AVLNode->New( key, Nil);
      return true;
    };
 
    n := @root;
    while(true) {
      if(n->GetKey() = key) {
        return false;
      };
      
      parent := n;
      goLeft := n->GetKey() > key;
      n := goLeft ? n->GetLeft() : n->GetRight();
 
      if(n = Nil) {
        if(goLeft) {
          parent->SetLeft(AVLNode->New( key, parent));
        } else {
          parent->SetRight(AVLNode->New( key, parent));
        };
        Rebalance(parent);
        break;
      };
    };

    return true;
  }

  method : Delete(node : AVLNode) ~ Nil {
    if (node->GetLeft() = Nil & node->GetRight() = Nil) {
      if (node ->GetAbove() = Nil) {
        @root := Nil;
      } else {
        parent := node ->GetAbove();
        if (parent->GetLeft() = node) {
          parent->SetLeft(Nil);
        } else {
          parent->SetRight(Nil);
        };
        Rebalance(parent);
      };
      return;
    };
 
    if (node->GetLeft() <> Nil) {
      child := node->GetLeft();
      while (child->GetRight() <> Nil) {
        child := child->GetRight();
      };
      node->SetKey(child->GetKey());
      Delete(child);
    } else {
      child := node->GetRight();
      while (child->GetLeft() <> Nil) {
        child := child->GetLeft();
      };
      node->SetKey(child->GetKey());
      Delete(child);
    };
  }

  method : public : Delete(delKey : Int) ~ Nil {
    if (@root = Nil) {
      return;
    };
 
    child := @root;
    while (child <> Nil) {
      node := child;
      child := delKey >= node->GetKey() ? node->GetRight() : node->GetLeft();
      if (delKey = node->GetKey()) {
        Delete(node);
        return;
      };
    };
  }

  method : Rebalance(n : AVLNode) ~ Nil {
    SetBalance(n);
 
    if (n->GetBalance() = -2) {
      if (Height(n->GetLeft()->GetLeft()) >= Height(n->GetLeft()->GetRight())) {
        n := RotateRight(n);
      }
      else {
        n := RotateLeftThenRight(n);
      };
     
    } else if (n->GetBalance() = 2) {
      if(Height(n->GetRight()->GetRight()) >= Height(n->GetRight()->GetLeft())) {
        n := RotateLeft(n);
      }
      else {
        n := RotateRightThenLeft(n);
      };
    };
 
    if(n->GetAbove() <> Nil) {
      Rebalance(n->GetAbove());
    } else {
      @root := n;
    };
  }

  method : RotateLeft(a : AVLNode) ~ AVLNode {
    b := a->GetRight();
    b->SetAbove(a->GetAbove());
 
    a->SetRight(b->GetLeft());
 
    if(a->GetRight() <> Nil) {
      a->GetRight()->SetAbove(a);
    };
    
    b->SetLeft(a);
    a->SetAbove(b);
    
    if (b->GetAbove() <> Nil) {
      if (b->GetAbove()->GetRight() = a) {
        b->GetAbove()->SetRight(b);
      } else {
        b->GetAbove()->SetLeft(b);
      };
    };
 
    SetBalance(a);
    SetBalance(b);
 
    return b;
  }
  
  method : RotateRight(a : AVLNode) ~ AVLNode {
    b := a->GetLeft();
    b->SetAbove(a->GetAbove());
 
    a->SetLeft(b->GetRight());
    
    if (a->GetLeft() <> Nil) {
      a->GetLeft()->SetAbove(a);
    };
    
    b->SetRight(a);
    a->SetAbove(b);
 
    if (b->GetAbove() <> Nil) {
      if (b->GetAbove()->GetRight() = a) {
        b->GetAbove()->SetRight(b);
      } else {
        b->GetAbove()->SetLeft(b);
      };
    };
    
    SetBalance(a);
    SetBalance(b);

    return b;
  }

  method : RotateLeftThenRight(n : AVLNode) ~ AVLNode {
    n->SetLeft(RotateLeft(n->GetLeft()));
    return RotateRight(n);
  }
 
  method : RotateRightThenLeft(n : AVLNode) ~ AVLNode {
    n->SetRight(RotateRight(n->GetRight()));
    return RotateLeft(n);
  }

  method : SetBalance(n : AVLNode) ~ Nil {
    Reheight(n);
    n->SetBalance(Height(n->GetRight()) - Height(n->GetLeft()));
  }

  method : Reheight(node : AVLNode) ~ Nil {
    if(node <> Nil) {
      node->SetHeight(1 + Int->Max(Height(node->GetLeft()), Height(node->GetRight())));
    };
  }

  method : Height(n : AVLNode) ~ Int {
    if(n = Nil) {
      return -1;
    };

    return n->GetHeight();
  }

  method : public : PrintBalance() ~ Nil {
    PrintBalance(@root);
  }
 
  method : PrintBalance(n : AVLNode) ~ Nil {
    if (n <> Nil) {
      PrintBalance(n->GetLeft());
      balance := n->GetBalance();
      "{$balance} "->Print();
      PrintBalance(n->GetRight());
    };
  }
}

class Test {
  function : Main(args : String[]) ~ Nil {
    tree := AVLTree->New();
 
    "Inserting values 1 to 10"->PrintLine();
    for(i := 1; i < 10; i+=1;) {
      tree->Insert(i);
    };
 
    "Printing balance: "->Print();
    tree->PrintBalance();
  }
}
Output:
Inserting values 1 to 10
Printing balance: 0 0 0 1 0 1 0 0 0

Objective-C

Translation of: Java
This example is incomplete. It is missing an @interface for AVLTree and also missing any @interface or @implementation for AVLTreeNode. Please ensure that it meets all task requirements and remove this message.
@implementation AVLTree

-(BOOL)insertWithKey:(NSInteger)key {
    
    if (self.root == nil) {
        self.root = [[AVLTreeNode alloc]initWithKey:key andParent:nil];
    } else {
        
        AVLTreeNode *n = self.root;
        AVLTreeNode *parent;
        
        while (true) {
            
            if (n.key == key) {
                return false;
            }
            
            parent = n;
            
            BOOL goLeft = n.key > key;
            n = goLeft ? n.left : n.right;
            
            if (n == nil) {
                
                if (goLeft) {
                    parent.left = [[AVLTreeNode alloc]initWithKey:key andParent:parent];
                } else {
                    parent.right = [[AVLTreeNode alloc]initWithKey:key andParent:parent];
                }
                [self rebalanceStartingAtNode:parent];
                break;
            }
        }
    }
    
    return true;
}

-(void)rebalanceStartingAtNode:(AVLTreeNode*)n {
    
    [self setBalance:@[n]];
    
    if (n.balance == -2) {
        if ([self height:(n.left.left)] >= [self height:n.left.right]) {
            n = [self rotateRight:n];
        } else {
            n = [self rotateLeftThenRight:n];
        }
    } else if (n.balance == 2) {
        if ([self height:n.right.right] >= [self height:n.right.left]) {
            n = [self rotateLeft:n];
        } else {
            n = [self rotateRightThenLeft:n];
        }
    }
    
    if (n.parent != nil) {
        [self rebalanceStartingAtNode:n.parent];
    } else {
        self.root = n;
    }
}


-(AVLTreeNode*)rotateRight:(AVLTreeNode*)a {
    
    AVLTreeNode *b = a.left;
    b.parent = a.parent;
    
    a.left = b.right;
    
    if (a.left != nil) {
        a.left.parent = a;
    }
    
    b.right = a;
    a.parent = b;
    
    if (b.parent != nil) {
        if (b.parent.right == a) {
            b.parent.right = b;
        } else {
            b.parent.left = b;
        }
    }
    
    [self setBalance:@[a,b]];
    return b;
    
}

-(AVLTreeNode*)rotateLeftThenRight:(AVLTreeNode*)n {
    
    n.left = [self rotateLeft:n.left];
    return [self rotateRight:n];
    
}

-(AVLTreeNode*)rotateRightThenLeft:(AVLTreeNode*)n {
    
    n.right = [self rotateRight:n.right];
    return [self rotateLeft:n];
}

-(AVLTreeNode*)rotateLeft:(AVLTreeNode*)a {
    
    //set a's right node as b
    AVLTreeNode* b = a.right;
    //set b's parent as a's parent (which could be nil)
    b.parent = a.parent;
    //in case b had a left child transfer it to a
    a.right = b.left;
    
    // after changing a's reference to the right child, make sure the parent is set too
    if (a.right != nil) {
        a.right.parent = a;
    }
    
    // switch a over to the left to be b's left child
    b.left = a;
    a.parent = b;
    
    if (b.parent != nil) {
        if (b.parent.right == a) {
            b.parent.right = b;
        } else {
            b.parent.right = b;
        }
    }
    
    [self setBalance:@[a,b]];
    
    return b;
    
}



-(void) setBalance:(NSArray*)nodesArray {
    
    for (AVLTreeNode* n in nodesArray) {
        
        n.balance = [self height:n.right] - [self height:n.left];
    }
    
}

-(int)height:(AVLTreeNode*)n {
    
    if (n == nil) {
        return -1;
    }
    
    return 1 + MAX([self height:n.left], [self height:n.right]);
}

-(void)printKey:(AVLTreeNode*)n {
    if (n != nil) {
        [self printKey:n.left];
        NSLog(@"%ld", n.key);
        [self printKey:n.right];
    }
}

-(void)printBalance:(AVLTreeNode*)n {
    if (n != nil) {
        [self printBalance:n.left];
        NSLog(@"%ld", n.balance);
        [self printBalance:n.right];
    }
}
@end
-- test 

int main(int argc, const char * argv[]) {
    @autoreleasepool {

        AVLTree *tree = [AVLTree new];
        NSLog(@"inserting values 1 to 6");
        [tree insertWithKey:1];
        [tree insertWithKey:2];
        [tree insertWithKey:3];
        [tree insertWithKey:4];
        [tree insertWithKey:5];
        [tree insertWithKey:6];
        
        NSLog(@"printing balance: ");
        [tree printBalance:tree.root];
        
        NSLog(@"printing key: ");
        [tree printKey:tree.root];
    }
    return 0;
}
Output:
inserting values 1 to 6
printing balance:
0
0
0
0
1
0

printing key:
1
2
3
4
5
6

Phix

Translated from the C version at http://www.geeksforgeeks.org/avl-tree-set-2-deletion
The standard distribution includes demo\rosetta\AVL_tree.exw, which contains a slightly longer but perhaps more readable version, with a command line equivalent of https://www.cs.usfca.edu/~galles/visualization/AVLtree.html as well as a simple tree structure display routine and additional verification code (both modelled on the C version found on this page)

with javascript_semantics
enum KEY = 0,
     LEFT,
     HEIGHT,    -- (NB +/-1 gives LEFT or RIGHT)
     RIGHT
 
sequence tree = {}
integer freelist = 0
 
function newNode(object key)
integer node
    if freelist=0 then
        node = length(tree)+1
        tree &= {key,NULL,1,NULL}
    else
        node = freelist
        freelist = tree[freelist]
        tree[node+KEY..node+RIGHT] = {key,NULL,1,NULL}
    end if
    return node
end function
 
function height(integer node)
    return iff(node=NULL?0:tree[node+HEIGHT])
end function
 
procedure setHeight(integer node)
    tree[node+HEIGHT] = max(height(tree[node+LEFT]), height(tree[node+RIGHT]))+1
end procedure
 
function rotate(integer node, integer direction)
integer idirection = LEFT+RIGHT-direction
integer pivot = tree[node+idirection]
    {tree[pivot+direction],tree[node+idirection]} = {node,tree[pivot+direction]}
    setHeight(node)
    setHeight(pivot)
    return pivot
end function
 
function getBalance(integer N)
    return iff(N==NULL ? 0 : height(tree[N+LEFT])-height(tree[N+RIGHT]))
end function
 
function insertNode(integer node, object key)
    if node==NULL then
        return newNode(key)
    end if
    integer c = compare(key,tree[node+KEY])
    if c!=0 then
        integer direction = HEIGHT+c    -- LEFT or RIGHT
-- note this crashes under p2js... (easy to fix, not so easy to find)
--      tree[node+direction] = insertNode(tree[node+direction], key)
        atom tnd = insertNode(tree[node+direction], key)
        tree[node+direction] = tnd
        setHeight(node)
        integer balance = trunc(getBalance(node)/2) -- +/-1 (or 0)
        if balance then
            direction = HEIGHT-balance  -- LEFT or RIGHT
            c = compare(key,tree[tree[node+direction]+KEY])
            if c=balance then
                tree[node+direction] = rotate(tree[node+direction],direction)
            end if
            if c!=0 then
                node = rotate(node,LEFT+RIGHT-direction)
            end if
        end if
    end if
    return node
end function
 
function minValueNode(integer node)
    while 1 do
        integer next = tree[node+LEFT]
        if next=NULL then exit end if
        node = next
    end while
    return node
end function
 
function deleteNode(integer root, object key)
integer c
    if root=NULL then return root end if
    c = compare(key,tree[root+KEY])
    if c=-1 then
        tree[root+LEFT] = deleteNode(tree[root+LEFT], key)
    elsif c=+1 then
        tree[root+RIGHT] = deleteNode(tree[root+RIGHT], key)
    elsif tree[root+LEFT]==NULL
       or tree[root+RIGHT]==NULL then
        integer temp = iff(tree[root+LEFT] ? tree[root+LEFT] : tree[root+RIGHT])
        if temp==NULL then  -- No child case
            {temp,root} = {root,NULL}
        else                -- One child case
            tree[root+KEY..root+RIGHT] = tree[temp+KEY..temp+RIGHT]
        end if
        tree[temp+KEY] = freelist
        freelist = temp
    else                    -- Two child case
        integer temp = minValueNode(tree[root+RIGHT])
        tree[root+KEY] = tree[temp+KEY]
        tree[root+RIGHT] = deleteNode(tree[root+RIGHT], tree[temp+KEY])
    end if
    if root=NULL then return root end if
    setHeight(root)
    integer balance = trunc(getBalance(root)/2)
    if balance then
        integer direction = HEIGHT-balance
        c = compare(getBalance(tree[root+direction]),0)
        if c=-balance then
            tree[root+direction] = rotate(tree[root+direction],direction)
        end if
        root = rotate(root,LEFT+RIGHT-direction)
    end if
    return root
end function
 
procedure inOrder(integer node)
    if node!=NULL then
        inOrder(tree[node+LEFT])
        printf(1, "%d ", tree[node+KEY])
        inOrder(tree[node+RIGHT])
    end if
end procedure
 
integer root = NULL
sequence test = shuffle(tagset(50003))
for i=1 to length(test) do
    root = insertNode(root,test[i])
end for
test = shuffle(tagset(50000))
for i=1 to length(test) do
    root = deleteNode(root,test[i])
end for
inOrder(root)
Output:
50001 50002 50003

Picat

Translation of: Haskell

The function delete is missing.

main =>
    T = nil,
    foreach (X in 1..10)
        T := insert(X,T)
    end,
    output(T,0).

insert(X, nil) = {1,nil,X,nil}.
insert(X, T@{H,L,V,R}) = Res =>
    if X < V then
        Res = rotate({H, insert(X,L) ,V,R})
    elseif X > V then
        Res = rotate({H,L,V, insert(X,R)})
    else
        Res = T
    end.
 
rotate(nil) = nil.
rotate({H, {LH,LL,LV,LR}, V, R}) = Res,
    LH - height(R) > 1,
    height(LL) - height(LR) > 0
=>      % Left Left.
    Res = {LH,LL,LV, {depth(R,LR), LR,V,R}}.
rotate({H,L,V, {RH,RL,RV,RR}}) = Res,
    RH - height(L) > 1,
    height(RR) - height(RL) > 0
=>      % Right Right.
    Res = {RH, {depth(L,RL),L,V,RL}, RV,RR}.
rotate({H, {LH,LL,LV, {RH,RL,RV,RR}, V,R}}) = Res,
    LH - height(R) > 1
=>      % Left Right.
    Res = {H, {RH + 1, {LH - 1, LL, LV, RL}, RV, RR}, V, R}.
rotate({H,L,V, {RH, {LH,LL,LV,LR},RV,RR}}) = Res,
    RH - height(L) > 1
=>      % Right Left.
    Res = {H,L,V, {LH+1, LL, LV, {RH-1, LR, RV, RR}}}.
rotate({H,L,V,R}) = Res =>   % Re-weighting.
    L1 = rotate(L),
    R1 = rotate(R),
    Res = {depth(L1,R1), L1,V,R1}.
 
height(nil) = -1.
height({H,_,_,_}) = H.
 
depth(A,B) = max(height(A), height(B)) + 1.
 
output(nil,Indent) => printf("%*w\n",Indent,nil).
output({_,L,V,R},Indent) =>
    output(L,Indent+6),
    printf("%*w\n",Indent,V),
    output(R,Indent+6).
Output:
               nil
           1
               nil
     2
               nil
           3
               nil
4
                     nil
                 5
                     nil
           6
                     nil
                 7
                     nil
     8
               nil
           9
                     nil
                10
                     nil

Python

This is the source code of Pure Calculus in Python. The code includes:

  • an ordered_set class
  • an unordered_set class
  • an array class
  • a dictionary class
  • a bag class
  • a map class

The dictionary and array classes includes an AVL bag sort method - which is novel.

# Module: calculus.py

import enum

class entry_not_found(Exception):
   """Raised when an entry is not found in a collection"""
   pass

class entry_already_exists(Exception):
   """Raised when an entry already exists in a collection"""
   pass

class state(enum.Enum):
   header = 0
   left_high = 1
   right_high = 2
   balanced = 3

class direction(enum.Enum):
   from_left = 0
   from_right = 1

from abc import ABC, abstractmethod

class comparer(ABC):

    @abstractmethod
    def compare(self,t):
        pass

class node(comparer):
 
    def __init__(self):
        self.parent = None
        self.left = self
        self.right = self
        self.balance = state.header

    def compare(self,t):
        if self.key < t:
             return -1
        elif t < self.key:
             return 1
        else:
             return 0

    def is_header(self):
        return self.balance == state.header

    def length(self):
        if self != None:
           if self.left != None:
              left = self.left.length()
           else:
              left = 0
           if self.right != None:   
              right = self.right.length()
           else:
              right = 0
              
           return left + right + 1
        else:
           return 0
    
    def rotate_left(self):
         _parent = self.parent
         x = self.right
         self.parent = x
         x.parent = _parent
         if x.left is not None:
             x.left.parent = self
         self.right = x.left
         x.left = self
         return x
    
 
    def rotate_right(self):
        _parent = self.parent
        x = self.left
        self.parent = x
        x.parent = _parent;
        if x.right is not None:
            x.right.parent = self
        self.left = x.right
        x.right = self
        return x

    def balance_left(self):
       
       _left = self.left

       if _left is None:
          return self;
       
       if _left.balance == state.left_high:
                self.balance = state.balanced
                _left.balance = state.balanced
                self = self.rotate_right()
       elif _left.balance == state.right_high: 
                subright = _left.right
                if subright.balance == state.balanced:
                        self.balance = state.balanced
                        _left.balance = state.balanced
                elif subright.balance == state.right_high:
                        self.balance = state.balanced
                        _left.balance = state.left_high
                elif subright.balance == left_high:
                        root.balance = state.right_high
                        _left.balance = state.balanced
                subright.balance = state.balanced
                _left = _left.rotate_left()
                self.left = _left
                self = self.rotate_right()
       elif _left.balance == state.balanced:
               self.balance = state.left_high
               _left.balance = state.right_high
               self = self.rotate_right()
       return self;
   
    def balance_right(self):

       _right = self.right

       if _right is None:
          return self;
       
       if _right.balance == state.right_high:
                self.balance = state.balanced
                _right.balance = state.balanced
                self = self.rotate_left()
       elif _right.balance == state.left_high:
                subleft = _right.left;
                if subleft.balance == state.balanced:
                        self.balance = state.balanced
                        _right.balance = state.balanced
                elif subleft.balance == state.left_high:
                        self.balance = state.balanced
                        _right.balance = state.right_high
                elif subleft.balance == state.right_high:
                        self.balance = state.left_high
                        _right.balance = state.balanced
                subleft.balance = state.balanced
                _right = _right.rotate_right()
                self.right = _right
                self = self.rotate_left()
       elif _right.balance == state.balanced:
                self.balance = state.right_high
                _right.balance = state.left_high
                self = self.rotate_left()
       return self


    def balance_tree(self, direct):
        taller = True
        while taller:
            _parent = self.parent;
            if _parent.left == self:
                next_from =  direction.from_left
            else:
                next_from = direction.from_right;

            if direct == direction.from_left:
                if self.balance == state.left_high:
                        if _parent.is_header():
                            _parent.parent = _parent.parent.balance_left()
                        elif _parent.left == self:
                            _parent.left = _parent.left.balance_left()
                        else:
                            _parent.right = _parent.right.balance_left()
                        taller = False
 
                elif self.balance == state.balanced:
                        self.balance = state.left_high
                        taller = True
      
                elif self.balance == state.right_high:
                        self.balance = state.balanced
                        taller = False
            else:
              if self.balance == state.left_high:
                        self.balance = state.balanced
                        taller = False
  
              elif self.balance ==  state.balanced:
                        self.balance = state.right_high
                        taller = True
  
              elif self.balance ==  state.right_high:
                        if _parent.is_header():
                            _parent.parent = _parent.parent.balance_right()
                        elif _parent.left == self:
                            _parent.left = _parent.left.balance_right()
                        else:
                            _parent.right = _parent.right.balance_right()
                        taller = False
  
            if taller:
                if _parent.is_header():
                    taller = False
                else:
                    self = _parent
                    direct = next_from

    def balance_tree_remove(self, _from):
      
        if self.is_header():
            return;

        shorter = True;

        while shorter:
            _parent = self.parent;
            if _parent.left == self:
                next_from = direction.from_left
            else:
                next_from = direction.from_right

            if _from == direction.from_left:
                if self.balance == state.left_high:
                        shorter = True
 
                elif self.balance == state.balanced:
                        self.balance = state.right_high;
                        shorter = False
  
                elif self.balance == state.right_high:
                        if self.right is not None:
                            if self.right.balance == state.balanced:
                                shorter = False
                            else:
                                shorter = True
                        else:
                            shorter = False;

                        if _parent.is_header():
                            _parent.parent = _parent.parent.balance_right()
                        elif _parent.left == self:
                            _parent.left = _parent.left.balance_right();
                        else:
                            _parent.right = _parent.right.balance_right()
            
            else:
                if self.balance == state.right_high:
                        self.balance = state.balanced
                        shorter = True
  
                elif self.balance == state.balanced:
                        self.balance = state.left_high
                        shorter = False
                 
                elif self.balance == state.left_high:

                        if self.left is not None:
                            if self.left.balance == state.balanced:
                                shorter = False
                            else:
                                shorter = True
                        else:
                           short = False;

                        if _parent.is_header():
                            _parent.parent = _parent.parent.balance_left();
                        elif _parent.left == self:
                            _parent.left = _parent.left.balance_left();
                        else:
                            _parent.right = _parent.right.balance_left();
 
            if shorter:
               if _parent.is_header():
                    shorter = False
               else: 
                    _from = next_from
                    self = _parent

    def previous(self):
        if self.is_header():
            return self.right

        if self.left is not None:
            y = self.left
            while y.right is not None:
                y = y.right
            return y
         
        else: 
            y = self.parent;
            if y.is_header():
                return y

            x = self
            while x == y.left:
                x = y
                y = y.parent

            return y
        
    def next(self):
        if self.is_header():
            return self.left

        if self.right is not None:
            y = self.right
            while y.left is not None:
                y = y.left
            return y;
         
        else:
            y = self.parent
            if y.is_header():
                return y

            x = self;         
            while x == y.right:
                x = y
                y = y.parent;
                
            return y

    def swap_nodes(a, b):
       
        if b == a.left:
            if b.left is not None:
                b.left.parent = a

            if b.right is not None:
                b.right.parent = a

            if a.right is not None:
                a.right.parent = b

            if not a.parent.is_header():
                if a.parent.left == a:
                    a.parent.left = b
                else:
                    a.parent.right = b;
            else:
                a.parent.parent = b

            b.parent = a.parent
            a.parent = b

            a.left = b.left
            b.left = a

            temp = a.right
            a.right = b.right
            b.right = temp
        elif b == a.right:
            if b.right is not None:
                b.right.parent = a
                
            if b.left is not None:
               b.left.parent = a

            if a.left is not None:
               a.left.parent = b

            if not a.parent.is_header(): 
                if a.parent.left == a:
                    a.parent.left = b
                else:
                    a.parent.right = b
            else:
               a.parent.parent = b

            b.parent = a.parent
            a.parent = b

            a.right = b.right
            b.right = a

            temp = a.left
            a.left = b.left
            b.left = temp
        elif a == b.left:
            if a.left is not None:
                a.left.parent = b
                
            if a.right is not None:
                a.right.parent = b

            if b.right is not None:
                b.right.parent = a

            if not parent.is_header(): 
                if b.parent.left == b:
                    b.parent.left = a
                else:
                    b.parent.right = a
            else:
                b.parent.parent = a

            a.parent = b.parent
            b.parent = a

            b.left = a.left
            a.left = b

            temp = a.right
            a.right = b.right
            b.right = temp
        elif a == b.right:
            if a.right is not None:
                a.right.parent = b
            if a.left is not None:
               a.left.parent = b

            if b.left is not None:
               b.left.parent = a

            if not b.parent.is_header():
                if b.parent.left == b:
                    b.parent.left = a
                else:
                    b.parent.right = a
            else:
                b.parent.parent = a

            a.parent = b.parent
            b.parent = a

            b.right = a.right
            a.right = b

            temp = a.left
            a.left = b.left
            b.left = temp
        else:
            if a.parent == b.parent:
                temp = a.parent.left
                a.parent.left = a.parent.right
                a.parent.right = temp
            else:
                if not a.parent.is_header():
                    if a.parent.left == a:
                        a.parent.left = b
                    else:
                        a.parent.right = b
                else:
                    a.parent.parent = b

                if not b.parent.is_header():
                    if b.parent.left == b:
                        b.parent.left = a
                    else:
                        b.parent.right = a
                else:
                    b.parent.parent = a
            
            if b.left is not None:
                b.left.parent = a
                
            if b.right is not None:
                b.right.parent = a

            if a.left is not None:
                a.left.parent = b
                
            if a.right is not None:
                a.right.parent = b

            temp1 = a.left
            a.left = b.left
            b.left = temp1

            temp2 = a.right
            a.right = b.right
            b.right = temp2

            temp3 = a.parent
            a.parent = b.parent
            b.parent = temp3
        
        balance = a.balance
        a.balance = b.balance
        b.balance = balance
    
class parent_node(node):

    def __init__(self, parent):
        self.parent = parent
        self.left = None
        self.right = None
        self.balance = state.balanced

class set_node(node):

    def __init__(self, parent, key):
        self.parent = parent
        self.left = None
        self.right = None
        self.balance = state.balanced
        self.key = key

class ordered_set:
    
    def __init__(self):
        self.header = node()

    def __iter__(self):
        self.node = self.header
        return self
    
    def __next__(self):
        self.node = self.node.next()
        if self.node.is_header():
            raise StopIteration
        return self.node.key

    def __delitem__(self, key):
          self.remove(key)

    def __lt__(self, other):
        first1 = self.header.left
        last1 = self.header
        first2 = other.header.left
        last2 = other.header

        while (first1 != last1) and (first2 != last2):
           l =  first1.key < first2.key
           if not l: 
              first1 = first1.next();
              first2 = first2.next();
           else:
              return True;
  
        a = self.__len__()
        b = other.__len__()
        return a < b

    def __hash__(self):
        h = 0
        for i in self:
            h = h + i.__hash__()
        return h    

    def __eq__(self, other):
       if self < other:
          return False
       if other < self:
          return False
       return True
     
    def __ne__(self, other):
       if self < other:
          return True
       if other < self:
          return True
       return False

    def __len__(self):
        return self.header.parent.length()

    def __getitem__(self, key):
          return self.contains(key)

    def __str__(self):
       l = self.header.right
       s = "{"
       i = self.header.left
       h = self.header
       while i != h:
           s = s + i.key.__str__()
           if i != l:
               s = s + ","
           i = i.next()

       s = s + "}"
       return s

    def __or__(self, other):
       r = ordered_set()
       
       first1 = self.header.left
       last1 = self.header
       first2 = other.header.left
       last2 = other.header
       
       while first1 != last1 and first2 != last2:
          les = first1.key < first2.key
          graater = first2.key < first1.key

          if les:
             r.add(first1.key)
             first1 = first1.next()
          elif graater:
             r.add(first2.key)
             first2 = first2.next()
          else:
             r.add(first1.key)
             first1 = first1.next()
             first2 = first2.next()
             
       while first1 != last1:
          r.add(first1.key)
          first1 = first1.next()
                        
       while first2 != last2:
          r.add(first2.key)
          first2 = first2.next()

       return r

    def __and__(self, other):
       r = ordered_set()
       
       first1 = self.header.left
       last1 = self.header
       first2 = other.header.left
       last2 = other.header
       
       while first1 != last1 and first2 != last2:
          les = first1.key < first2.key
          graater = first2.key < first1.key

          if les:
             first1 = first1.next()
          elif graater:
             first2 = first2.next()
          else:
             r.add(first1.key)
             first1 = first1.next()
             first2 = first2.next()
  
       return r

    def __xor__(self, other):
       r = ordered_set()
       
       first1 = self.header.left
       last1 = self.header
       first2 = other.header.left
       last2 = other.header
       
       while first1 != last1 and first2 != last2:
          les = first1.key < first2.key
          graater = first2.key < first1.key

          if les:
             r.add(first1.key)
             first1 = first1.next()
          elif graater:
             r.add(first2.key)
             first2 = first2.next()
          else:
             first1 = first1.next()
             first2 = first2.next()
             
       while first1 != last1:
          r.add(first1.key)
          first1 = first1.next()
                        
       while first2 != last2:
          r.add(first2.key)
          first2 = first2.next()

       return r


    def __sub__(self, other):
       r = ordered_set()
       
       first1 = self.header.left
       last1 = self.header
       first2 = other.header.left
       last2 = other.header
       
       while first1 != last1 and first2 != last2:
          les = first1.key < first2.key
          graater = first2.key < first1.key

          if les:
             r.add(first1.key)
             first1 = first1.next()
          elif graater:
             r.add(first2.key)
             first2 = first2.next()
          else:
             first1 = first1.next()
             first2 = first2.next()
             
       while first1 != last1:
          r.add(first1.key)
          first1 = first1.next()

       return r
 
    def __lshift__(self, data):
       self.add(data)
       return self

    def __rshift__(self, data):
       self.remove(data)
       return self

    def is_subset(self, other):
       first1 = self.header.left
       last1 = self.header
       first2 = other.header.left
       last2 = other.header

       is_subet = True

       while first1 != last1 and first2 != last2:
          if first1.key < first2.key:
              is_subset = False
              break
          elif first2.key < first1.key:
             first2 = first2.next()
          else:
             first1 = first1.next()
             first2 = first2.next()
 
          if is_subet:
             if first1 != last1:
                is_subet = False
 
       return is_subet

    def is_superset(self,other):
       return other.is_subset(self)
  
    def add(self, data):
            if self.header.parent is None:
                self.header.parent = set_node(self.header,data)
                self.header.left = self.header.parent
                self.header.right = self.header.parent
            else:
                
                root = self.header.parent

                while True:
                    c = root.compare(data)
                    if c >= 0:
                        if root.left is not None:
                            root = root.left
                        else:
                            new_node = set_node(root,data)
                            root.left = new_node
                            
                            if self.header.left == root:
                                 self.header.left = new_node
                            root.balance_tree(direction.from_left)
                            return
                        
                    else:
                        if root.right is not None:
                            root = root.right
                        else:
                            new_node = set_node(root, data)
                            root.right = new_node
                            if self.header.right == root:
                                  self.header.right = new_node
                            root.balance_tree(direction.from_right)
                            return
                    
    def remove(self,data):
        root = self.header.parent;

        while True:
            if root is None:
                raise entry_not_found("Entry not found in collection")
                
            c  = root.compare(data)

            if c < 0:
               root = root.left;

            elif c > 0:
               root = root.right;

            else:
                 
                 if root.left is not None:
                     if root.right is not None: 
                         replace = root.left
                         while replace.right is not None:
                             replace = replace.right
                         root.swap_nodes(replace)
                         
                 _parent = root.parent

                 if _parent.left == root:
                     _from = direction.from_left
                 else:
                     _from = direction.from_right

                 if self.header.left == root:
                                
                     n = root.next();
                 
                     if n.is_header():
                         self.header.left = self.header
                         self.header.right = self.header
                     else:
                        self.header.left = n
                 elif self.header.right == root: 

                     p = root.previous();

                     if p.is_header():
                          self.header.left = self.header
                          self.header.right = self.header
                     else:
                          self.header.right = p

                 if root.left is None:
                     if _parent == self.header:
                         self.header.parent = root.right
                     elif _parent.left == root:
                         _parent.left = root.right
                     else:
                         _parent.right = root.right

                     if root.right is not None:
                          root.right.parent = _parent
                            
                 else:
                     if _parent == self.header:
                          self.header.parent = root.left
                     elif _parent.left == root:
                         _parent.left = root.left
                     else:
                         _parent.right = root.left

                     if root.left is not None:
                         root.left.parent = _parent;


                 _parent.balance_tree_remove(_from)
                 return   

    def contains(self,data):
        root = self.header.parent;

        while True:
            if root == None:
                return False

            c  = root.compare(data);

            if c > 0:
               root = root.left;

            elif c < 0:
               root = root.right;

            else:
           
                 return True  

   
    def find(self,data):
        root = self.header.parent;

        while True:
            if root == None:
                raise entry_not_found("An entry is not found in a collection")

            c  = root.compare(data);

            if c > 0:
               root = root.left;

            elif c < 0:
               root = root.right;

            else:
           
                 return root.key;  
            
class key_value(comparer):

    def __init__(self, key, value):
        self.key = key
        self.value = value

    def compare(self,kv):
        if self.key < kv.key:
             return -1
        elif kv.key < self.key:
             return 1
        else:
             return 0

    def __lt__(self, other):
        return self.key < other.key

    def __str__(self):
        return '(' + self.key.__str__() + ',' + self.value.__str__() + ')'

    def __eq__(self, other):
       return self.key == other.key

    def __hash__(self):
        return hash(self.key)
 

class dictionary:

    def __init__(self):
        self.set = ordered_set()
        return None

    def __lt__(self, other):
       if self.keys() < other.keys():
          return true

       if other.keys() < self.keys():
          return false
         
       first1 = self.set.header.left
       last1 = self.set.header
       first2 = other.set.header.left
       last2 = other.set.header

       while (first1 != last1) and (first2 != last2):
          l =  first1.key.value < first2.key.value
          if not l: 
             first1 = first1.next();
             first2 = first2.next();
          else:
             return True;
  
       a = self.__len__()
       b = other.__len__()
       return a < b


    def add(self, key, value):
       try:
           self.set.remove(key_value(key,None))
       except entry_not_found:
            pass  
       self.set.add(key_value(key,value))
       return

    def remove(self, key):
       self.set.remove(key_value(key,None))
       return

    def clear(self):
       self.set.header = node()

    def sort(self):
    
      sort_bag = bag()
      for e in self:
        sort_bag.add(e.value)
      keys_set = self.keys()
      self.clear()
      i = sort_bag.__iter__()
      i = sort_bag.__next__()
      try:
        for e in keys_set:
          self.add(e,i)
          i = sort_bag.__next__()
      except:
         return        

    def keys(self):
         keys_set = ordered_set()
         for e in self:
             keys_set.add(e.key)
         return keys_set  
   
    def __len__(self):
        return self.set.header.parent.length()

    def __str__(self):
       l = self.set.header.right;
       s = "{"
       i = self.set.header.left;
       h = self.set.header;
       while i != h:
           s = s + "("
           s = s + i.key.key.__str__()
           s = s + ","
           s = s + i.key.value.__str__()
           s = s + ")"
           if i != l:
               s = s + ","
           i = i.next()

       s = s + "}"
       return s;

    def __iter__(self):
       
        self.set.node = self.set.header
        return self
    
    def __next__(self):
        self.set.node = self.set.node.next()
        if self.set.node.is_header():
            raise StopIteration
        return key_value(self.set.node.key.key,self.set.node.key.value)

    def __getitem__(self, key):
          kv = self.set.find(key_value(key,None))
          return kv.value

    def __setitem__(self, key, value):
          self.add(key,value)
          return

    def __delitem__(self, key):
          self.set.remove(key_value(key,None))


class array:

    def __init__(self):
        self.dictionary = dictionary()
        return None
      
    def __len__(self):
        return self.dictionary.__len__()

    def push(self, value):
       k = self.dictionary.set.header.right
       if k == self.dictionary.set.header:
           self.dictionary.add(0,value)
       else:
           self.dictionary.add(k.key.key+1,value)
       return

    def pop(self):
       if self.dictionary.set.header.parent != None:
          data = self.dictionary.set.header.right.key.value
          self.remove(self.dictionary.set.header.right.key.key)
          return data

    def add(self, key, value):
       try:
          self.dictionary.remove(key)
       except entry_not_found:
          pass
       self.dictionary.add(key,value)          
       return

    def remove(self, key):
       self.dictionary.remove(key)
       return

    def sort(self):
       self.dictionary.sort()

    def clear(self):
      self.dictionary.header = node();
      

    def __iter__(self):
        self.dictionary.node = self.dictionary.set.header
        return self
    
    def __next__(self):
        self.dictionary.node = self.dictionary.node.next()
        if self.dictionary.node.is_header():
            raise StopIteration
        return self.dictionary.node.key.value

    def __getitem__(self, key):
          kv = self.dictionary.set.find(key_value(key,None))
          return kv.value

    def __setitem__(self, key, value):
          self.add(key,value)
          return

    def __delitem__(self, key):
          self.dictionary.remove(key)

    def __lshift__(self, data):
         self.push(data)
         return self

    def __lt__(self, other):
       return self.dictionary < other.dictionary
 
    def __str__(self):
       l = self.dictionary.set.header.right;
       s = "{"
       i = self.dictionary.set.header.left;
       h = self.dictionary.set.header;
       while i != h:
           s = s + i.key.value.__str__()
           if i != l:
               s = s + ","
           i = i.next()

       s = s + "}"
       return s;
          

class bag:
    
    def __init__(self):
        self.header = node()
      
    def __iter__(self):
        self.node = self.header
        return self

    def __delitem__(self, key):
          self.remove(key)
    
    def __next__(self):
        self.node = self.node.next()
        if self.node.is_header():
            raise StopIteration
        return self.node.key

    def __str__(self):
       l = self.header.right;
       s = "("
       i = self.header.left;
       h = self.header;
       while i != h:
           s = s + i.key.__str__()
           if i != l:
               s = s + ","
           i = i.next()

       s = s + ")"
       return s;

    def __len__(self):
        return self.header.parent.length()

    def __lshift__(self, data):
       self.add(data)
       return self

    def add(self, data):
            if self.header.parent is None:
                self.header.parent = set_node(self.header,data)
                self.header.left = self.header.parent
                self.header.right = self.header.parent
            else:
                
                root = self.header.parent

                while True:
                    c = root.compare(data)
                    if c >= 0:
                        if root.left is not None:
                            root = root.left
                        else:
                            new_node = set_node(root,data)
                            root.left = new_node
                            
                            if self.header.left == root:
                                 self.header.left = new_node

                            root.balance_tree(direction.from_left)
                            return
                        
                    else:
                        if root.right is not None:
                            root = root.right
                        else:
                            new_node = set_node(root, data)
                            root.right = new_node

                            if self.header.right == root:
                                  self.header.right = new_node

                            root.balance_tree(direction.from_right)
                            return
 
    def remove_first(self,data):
       
        root = self.header.parent;

        while True:
            if root is None:
                return False;

            c  = root.compare(data);

            if c > 0:
               root = root.left;

            elif c < 0:
               root = root.right;

            else:
                 
                 if root.left is not None:
                     if root.right is not None: 
                         replace = root.left;
                         while replace.right is not None:
                             replace = replace.right;
                         root.swap_nodes(replace);
                         
                 _parent = root.parent

                 if _parent.left == root:
                     _from = direction.from_left
                 else:
                     _from = direction.from_right

                 if self.header.left == root:
                                
                     n = root.next();
                 
                     if n.is_header():
                         self.header.left = self.header
                         self.header.right = self.header
                     else:
                        self.header.left = n;
                 elif self.header.right == root: 

                     p = root.previous();

                     if p.is_header():
                          self.header.left = self.header
                          self.header.right = self.header
                     else:
                          self.header.right = p

                 if root.left is None:
                     if _parent == self.header:
                         self.header.parent = root.right
                     elif _parent.left == root:
                         _parent.left = root.right
                     else:
                         _parent.right = root.right

                     if root.right is not None:
                          root.right.parent = _parent
                            
                 else:
                     if _parent == self.header:
                          self.header.parent = root.left
                     elif _parent.left == root:
                         _parent.left = root.left
                     else:
                         _parent.right = root.left

                     if root.left is not None:
                         root.left.parent = _parent;


                 _parent.balance_tree_remove(_from)
                 return True;

    def remove(self,data):
       success = self.remove_first(data)
       while success:
          success = self.remove_first(data)

    def remove_node(self, root):
       
        if root.left != None and root.right != None:
            replace = root.left
            while replace.right != None:
               replace = replace.right
            root.swap_nodes(replace)

        parent = root.parent;

        if parent.left == root:
           next_from = direction.from_left
        else:
           next_from = direction.from_right

        if self.header.left == root:
            n = root.next()

            if n.is_header():
                self.header.left = self.header;
                self.header.right = self.header
            else:
                self.header.left = n
        elif self.header.right == root:
             p = root.previous()

             if p.is_header(): 
                root.header.left = root.header
                root.header.right = header
             else:
                self.header.right = p

        if root.left == None:
            if parent == self.header:
                self.header.parent = root.right
            elif parent.left == root:
                parent.left = root.right
            else:
                parent.right = root.right

            if root.right != None:
               root.right.parent = parent
        else:
            if parent == self.header:
                self.header.parent = root.left
            elif parent.left == root:
                parent.left = root.left
            else:
                parent.right = root.left

            if root.left != None:
               root.left.parent = parent;

        parent.balance_tree_remove(next_from)
    
    def remove_at(self, data, ophset):
 
            p = self.search(data);

            if p == None:
                return
            else:
                lower = p
                after = after(data)
 
            s = 0
            while True:
                if ophset == s:
                    remove_node(lower);
                    return;
                lower = lower.next_node()
                if after == lower:
                   break
                s = s+1
            
            return

    def search(self, key):
        s = before(key)
        s.next()
        if s.is_header():
           return None
        c = s.compare(s.key)
        if c != 0:
           return None
        return s
    
  
    def before(self, data):
        y = self.header;
        x = self.header.parent;

        while x != None:
            if x.compare(data) >= 0:
                x = x.left;
            else:
                y = x;
                x = x.right;
        return y
    
    def after(self, data):
        y = self.header;
        x = self.header.parent;

        while x != None:
            if x.compare(data) > 0:
                y = x
                x = x.left
            else:
                x = x.right

        return y;
    
 
    def find(self,data):
        root = self.header.parent;

        results = array()
        
        while True:
            if root is None:
                break;

            p = self.before(data)
            p = p.next()
            if not p.is_header():
               i = p
               l = self.after(data)
               while i != l:
                  results.push(i.key)
                  i = i.next()
         
               return results
            else:
               break;
            
        return results
    
class bag_dictionary:

    def __init__(self):
        self.bag = bag()
        return None

    def add(self, key, value):
       self.bag.add(key_value(key,value))
       return

    def remove(self, key):
       self.bag.remove(key_value(key,None))
       return

    def remove_at(self, key, index):
       self.bag.remove_at(key_value(key,None), index)
       return

    def clear(self):
       self.bag.header = node()

    def __len__(self):
        return self.bag.header.parent.length()

    def __str__(self):
       l = self.bag.header.right;
       s = "{"
       i = self.bag.header.left;
       h = self.bag.header;
       while i != h:
           s = s + "("
           s = s + i.key.key.__str__()
           s = s + ","
           s = s + i.key.value.__str__()
           s = s + ")"
           if i != l:
               s = s + ","
           i = i.next()

       s = s + "}"
       return s;

    def __iter__(self):
       
        self.bag.node = self.bag.header
        return self
    
    def __next__(self):
        self.bag.node = self.bag.node.next()
        if self.bag.node.is_header():
            raise StopIteration
        return key_value(self.bag.node.key.key,self.bag.node.key.value)

    def __getitem__(self, key):
          kv_array = self.bag.find(key_value(key,None))
          return kv_array

    def __setitem__(self, key, value):
          self.add(key,value)
          return

    def __delitem__(self, key):
          self.bag.remove(key_value(key,None))

class unordered_set:

    def __init__(self):
        self.bag_dictionary = bag_dictionary()

    def __len__(self):
        return self.bag_dictionary.__len__()

    def __hash__(self):
        h = 0
        for i in self:
            h = h + i.__hash__()
        return h    

    def __eq__(self, other):
        for t in self:
           if not other.contains(t):
              return False
        for u in other:
           if self.contains(u):
              return False
        return true;

    def __ne__(self, other):
        return not self == other
      
    def __or__(self, other):
       r = unordered_set()
       
       for t in self:
          r.add(t);
          
       for u in other:
          if not self.contains(u):
             r.add(u);

       return r

    def __and__(self, other):
       r = unordered_set()
   
       for t in self:
          if other.contains(t):
              r.add(t)
              
       for u in other:
              if self.contains(u) and not r.contains(u):
                  r.add(u);
  
       return r

    def __xor__(self, other):
       r = unordered_set()
       
       for t in self:
          if not other.contains(t):
             r.add(t)
             
       for u in other:
          if not self.contains(u) and not r.contains(u):
             r.add(u)
             
       return r


    def __sub__(self, other):
       r = ordered_set()
       
       for t in self:
          if not other.contains(t):
             r.add(t);
             
       return r
 
    def __lshift__(self, data):
       self.add(data)
       return self

    def __rshift__(self, data):
       self.remove(data)
       return self

    def __getitem__(self, key):
          return self.contains(key)

    def is_subset(self, other):

       is_subet = True

       for t in self:
          if not other.contains(t):
             subset = False
             break
            
       return is_subet

    def is_superset(self,other):
       return other.is_subset(self)


    def add(self, value):
       if not self.contains(value):
           self.bag_dictionary.add(hash(value),value)
       else:
          raise entry_already_exists("Entry already exists in the unordered set")

    def contains(self, data):
            if self.bag_dictionary.bag.header.parent == None:
                return False;
            else:
                index = hash(data);

                _search = self.bag_dictionary.bag.header.parent;

                search_index =  _search.key.key;

                if index < search_index:
                   _search = _search.left

                elif index > search_index:
                   _search = _search.right

                if _search == None:
                    return False

                while _search != None:
                    search_index =  _search.key.key;

                    if index < search_index:
                       _search = _search.left

                    elif index > search_index:
                       _search = _search.right

                    else:
                       break

                if _search == None:
                   return False

                return self.contains_node(data, _search)
 
    def contains_node(self,data,_node):
       
        previous = _node.previous()
        save = _node

        while not previous.is_header() and previous.key.key == _node.key.key:
            save = previous;
            previous = previous.previous()
      
        c = _node.key.value
        _node = save
        if c == data:
           return True

        next = _node.next()
        while not next.is_header() and next.key.key == _node.key.key:
            _node = next
            c = _node.key.value
            if c == data:
               return True;
            next = _node.next()
 
        return False;
      
    def find(self,data,_node):
       
        previous = _node.previous()
        save = _node

        while not previous.is_header() and previous.key.key == _node.key.key:
            save = previous;
            previous = previous.previous();
 
        _node = save;
        c = _node.key.value
        if c == data:
           return _node

        next = _node.next()
        while not next.is_header() and next.key.key == _node.key.key:
            _node = next
            c = _node.data.value
            if c == data:
               return _node
            next = _node.next()
 
        return None
    
    def search(self, data):
        if self.bag_dictionary.bag.header.parent == None:
            return None
        else:
            index = hash(data)

            _search = self.bag_dictionary.bag.header.parent

            c = _search.key.key

            if index < c:
               _search = _search.left;

            elif index > c:
               _search = _search.right;

            while _search != None:

                if index != c:
                   break
               
                c = _search.key.key

                if index < c:
                   _search = _search.left;

                elif index > c:
                   _search = _search.right;

                else:
                   break

            if _search == None:
               return None

            return self.find(data, _search)

    def remove(self,data):
       found = self.search(data);
       if found != None:
          self.bag_dictionary.bag.remove_node(found);
       else:
          raise entry_not_found("Entry not found in the unordered set")
 
    def clear(self):
       self.bag_dictionary.bag.header = node()

    def __str__(self):
       l = self.bag_dictionary.bag.header.right;
       s = "{"
       i = self.bag_dictionary.bag.header.left;
       h = self.bag_dictionary.bag.header;
       while i != h:
           s = s + i.key.value.__str__()
           if i != l:
               s = s + ","
           i = i.next()

       s = s + "}"
       return s;

    def __iter__(self):
       
        self.bag_dictionary.bag.node = self.bag_dictionary.bag.header
        return self
    
    def __next__(self):
        self.bag_dictionary.bag.node = self.bag_dictionary.bag.node.next()
        if self.bag_dictionary.bag.node.is_header():
            raise StopIteration
        return self.bag_dictionary.bag.node.key.value


class map:

    def __init__(self):
        self.set = unordered_set()
        return None

    def __len__(self):
        return self.set.__len__()

    def add(self, key, value):
       try:
           self.set.remove(key_value(key,None))
       except entry_not_found:
            pass  
       self.set.add(key_value(key,value))
       return

    def remove(self, key):
       self.set.remove(key_value(key,None))
       return

    def clear(self):
       self.set.clear()

    def __str__(self):
       l = self.set.bag_dictionary.bag.header.right;
       s = "{"
       i = self.set.bag_dictionary.bag.header.left;
       h = self.set.bag_dictionary.bag.header;
       while i != h:
           s = s + "("
           s = s + i.key.value.key.__str__()
           s = s + ","
           s = s + i.key.value.value.__str__()
           s = s + ")"
           if i != l:
               s = s + ","
           i = i.next()

       s = s + "}"
       return s;

    def __iter__(self):
       
        self.set.node = self.set.bag_dictionary.bag.header
        return self
    
    def __next__(self):
        self.set.node = self.set.node.next()
        if self.set.node.is_header():
            raise StopIteration
        return key_value(self.set.node.key.key,self.set.node.key.value)

    def __getitem__(self, key):
          kv = self.set.find(key_value(key,None))
          return kv.value

    def __setitem__(self, key, value):
          self.add(key,value)
          return

    def __delitem__(self, key):
          self.remove(key)

Raku

(formerly Perl 6) This code has been translated from the Java version on <https://rosettacode.org>. Consequently, it should have the same license: GNU Free Document License 1.2. In addition to the translated code, other public methods have been added as shown by the asterisks in the following list of all public methods:

  • insert node
  • delete node
  • show all node keys
  • show all node balances
  • *delete nodes by a list of node keys
  • *find and return node objects by key
  • *attach data per node
  • *return list of all node keys
  • *return list of all node objects


Note one of the interesting features of Raku is the ability to use characters like the apostrophe (') and hyphen (-) in identifiers.

class AVL-Tree {
    has $.root is rw = 0;

    class Node {
        has $.key    is rw = '';
        has $.parent is rw = 0;
        has $.data   is rw = 0;
        has $.left   is rw = 0;
        has $.right  is rw = 0;
        has Int $.balance is rw = 0;
        has Int $.height  is rw = 0;
    }

    #=====================================================
    # public methods
    #=====================================================

    #| returns a node object or 0 if not found
    method find($key) {
        return 0 if !$.root;
        self!find: $key, $.root;
    }

    #| returns a list of tree keys
    method keys() {
        return () if !$.root;
        my @list;
        self!keys: $.root, @list;
        @list;
    }

    #| returns a list of tree nodes
    method nodes() {
        return () if !$.root;
        my @list;
        self!nodes: $.root, @list;
        @list;
    }

    #| insert a node key, optionally add data (the `parent` arg is for
    #| internal use only)
    method insert($key, :$data = 0, :$parent = 0,) {
        return $.root = Node.new: :$key, :$parent, :$data if !$.root;
        my $n = $.root;
        while True {
            return False if $n.key eq $key;
            my $parent = $n;
            my $goLeft = $n.key > $key;
            $n = $goLeft ?? $n.left !! $n.right;
            if !$n {
                if $goLeft {
                    $parent.left = Node.new: :$key, :$parent, :$data;
                }
                else {
                    $parent.right = Node.new: :$key, :$parent, :$data;
                }
                self!rebalance: $parent;
                last
            }
        }
        True
    }

    #| delete one or more nodes by key
    method delete(*@del-key) {
        return if !$.root;
        for @del-key -> $del-key {
            my $child = $.root;
            while $child {
                my $node = $child;
                $child = $del-key >= $node.key ?? $node.right !! $node.left;
                if $del-key eq $node.key {
                    self!delete: $node;
                    next;
                }
            }
        }
    }

    #| show a list of all nodes by key
    method show-keys {
        self!show-keys: $.root;
        say()
    }

    #| show a list of all nodes' balances (not normally needed)
    method show-balances {
        self!show-balances: $.root;
        say()
    }

    #=====================================================
    # private methods
    #=====================================================

    method !delete($node) {
        if !$node.left && !$node.right {
            if !$node.parent {
                $.root = 0;
            }
            else {
                my $parent = $node.parent;
                if $parent.left === $node {
                    $parent.left = 0;
                }
                else {
                    $parent.right = 0;
                }
                self!rebalance: $parent;
            }
            return
        }

        if $node.left {
            my $child = $node.left;
            while $child.right {
                $child = $child.right;
            }
            $node.key = $child.key;
            self!delete: $child;
        }
        else {
            my $child = $node.right;
            while $child.left {
                $child = $child.left;
            }
            $node.key = $child.key;
            self!delete: $child;
        }
    }

    method !rebalance($n is copy) {
        self!set-balance: $n;

        if $n.balance == -2 {
            if self!height($n.left.left) >= self!height($n.left.right) {
                $n = self!rotate-right: $n;
            }
            else {
                $n = self!rotate-left'right: $n;
            }
        }
        elsif $n.balance == 2 {
            if self!height($n.right.right) >= self!height($n.right.left) {
                $n = self!rotate-left: $n;
            }
            else {
                $n = self!rotate-right'left: $n;
            }
        }

        if $n.parent {
            self!rebalance: $n.parent;
        }
        else {
            $.root = $n;
        }
    }

    method !rotate-left($a) {

        my $b     = $a.right;
        $b.parent = $a.parent;

        $a.right = $b.left;

        if $a.right {
            $a.right.parent = $a;
        }

        $b.left   = $a;
        $a.parent = $b;

        if $b.parent {
            if $b.parent.right === $a {
                $b.parent.right = $b;
            }
            else {
                $b.parent.left = $b;
            }
        }

        self!set-balance: $a, $b;
        $b;
    }

    method !rotate-right($a) {

        my $b = $a.left;
        $b.parent = $a.parent;

        $a.left = $b.right;

        if $a.left {
            $a.left.parent = $a;
        }

        $b.right  = $a;
        $a.parent = $b;

        if $b.parent {
            if $b.parent.right === $a {
                $b.parent.right = $b;
            }
            else {
                $b.parent.left = $b;
            }
        }

        self!set-balance: $a, $b;

        $b;
    }

    method !rotate-left'right($n) {
        $n.left = self!rotate-left: $n.left;
        self!rotate-right: $n;
    }

    method !rotate-right'left($n) {
        $n.right = self!rotate-right: $n.right;
        self!rotate-left: $n;
    }

    method !height($n) {
        $n ?? $n.height !! -1;
    }

    method !set-balance(*@n) {
        for @n -> $n {
            self!reheight: $n;
            $n.balance = self!height($n.right) - self!height($n.left);
        }
    }

    method !show-balances($n) {
        if $n {
            self!show-balances: $n.left;
            printf "%s ", $n.balance;
            self!show-balances: $n.right;
        }
    }

    method !reheight($node) {
        if $node {
            $node.height = 1 + max self!height($node.left), self!height($node.right);
        }
    }

    method !show-keys($n) {
        if $n {
            self!show-keys: $n.left;
            printf "%s ", $n.key;
            self!show-keys: $n.right;
        }
    }

    method !nodes($n, @list) {
        if $n {
            self!nodes: $n.left, @list;
            @list.push: $n if $n;
            self!nodes: $n.right, @list;
        }
    }

    method !keys($n, @list) {
        if $n {
            self!keys: $n.left, @list;
            @list.push: $n.key if $n;
            self!keys: $n.right, @list;
        }
    }

    method !find($key, $n) {
        if $n {
            self!find: $key, $n.left;
            return $n if $n.key eq $key;
            self!find: $key, $n.right;
        }
    }
}

Rust

See AVL tree/Rust.

Scala

import scala.collection.mutable

class AVLTree[A](implicit val ordering: Ordering[A]) extends mutable.SortedSet[A] {

  if (ordering eq null) throw new NullPointerException("ordering must not be null")

  private var _root: AVLNode = _
  private var _size = 0

  override def size: Int = _size

  override def foreach[U](f: A => U): Unit = {
    val stack = mutable.Stack[AVLNode]()
    var current = root
    var done = false

    while (!done) {
      if (current != null) {
        stack.push(current)
        current = current.left
      } else if (stack.nonEmpty) {
        current = stack.pop()
        f.apply(current.key)

        current = current.right
      } else {
        done = true
      }
    }
  }

  def root: AVLNode = _root

  override def isEmpty: Boolean = root == null

  override def min[B >: A](implicit cmp: Ordering[B]): A = minNode().key

  def minNode(): AVLNode = {
    if (root == null) throw new UnsupportedOperationException("empty tree")
    var node = root
    while (node.left != null) node = node.left
    node
  }

  override def max[B >: A](implicit cmp: Ordering[B]): A = maxNode().key

  def maxNode(): AVLNode = {
    if (root == null) throw new UnsupportedOperationException("empty tree")
    var node = root
    while (node.right != null) node = node.right
    node
  }

  def next(node: AVLNode): Option[AVLNode] = {
    var successor = node
    if (successor != null) {
      if (successor.right != null) {
        successor = successor.right
        while (successor != null && successor.left != null) {
          successor = successor.left
        }
      } else {
        successor = node.parent
        var n = node
        while (successor != null && successor.right == n) {
          n = successor
          successor = successor.parent
        }
      }
    }
    Option(successor)
  }

  def prev(node: AVLNode): Option[AVLNode] = {
    var predecessor = node
    if (predecessor != null) {
      if (predecessor.left != null) {
        predecessor = predecessor.left
        while (predecessor != null && predecessor.right != null) {
          predecessor = predecessor.right
        }
      } else {
        predecessor = node.parent
        var n = node
        while (predecessor != null && predecessor.left == n) {
          n = predecessor
          predecessor = predecessor.parent
        }
      }
    }
    Option(predecessor)
  }

  override def rangeImpl(from: Option[A], until: Option[A]): mutable.SortedSet[A] = ???

  override def +=(key: A): AVLTree.this.type = {
    insert(key)
    this
  }

  def insert(key: A): AVLNode = {
    if (root == null) {
      _root = new AVLNode(key)
      _size += 1
      return root
    }

    var node = root
    var parent: AVLNode = null
    var cmp = 0

    while (node != null) {
      parent = node
      cmp = ordering.compare(key, node.key)
      if (cmp == 0) return node // duplicate
      node = node.matchNextChild(cmp)
    }

    val newNode = new AVLNode(key, parent)
    if (cmp <= 0) parent._left = newNode
    else parent._right = newNode

    while (parent != null) {
      cmp = ordering.compare(parent.key, key)
      if (cmp < 0) parent.balanceFactor -= 1
      else parent.balanceFactor += 1

      parent = parent.balanceFactor match {
        case -1 | 1 => parent.parent
        case x if x < -1 =>
          if (parent.right.balanceFactor == 1) rotateRight(parent.right)
          val newRoot = rotateLeft(parent)
          if (parent == root) _root = newRoot
          null
        case x if x > 1 =>
          if (parent.left.balanceFactor == -1) rotateLeft(parent.left)
          val newRoot = rotateRight(parent)
          if (parent == root) _root = newRoot
          null
        case _ => null
      }
    }

    _size += 1
    newNode
  }

  override def -=(key: A): AVLTree.this.type = {
    remove(key)
    this
  }

  override def remove(key: A): Boolean = {
    var node = findNode(key).orNull
    if (node == null) return false

    if (node.left != null) {
      var max = node.left

      while (max.left != null || max.right != null) {
        while (max.right != null) max = max.right

        node._key = max.key
        if (max.left != null) {
          node = max
          max = max.left
        }
      }
      node._key = max.key
      node = max
    }

    if (node.right != null) {
      var min = node.right

      while (min.left != null || min.right != null) {
        while (min.left != null) min = min.left

        node._key = min.key
        if (min.right != null) {
          node = min
          min = min.right
        }
      }
      node._key = min.key
      node = min
    }

    var current = node
    var parent = node.parent
    while (parent != null) {
      parent.balanceFactor += (if (parent.left == current) -1 else 1)

      current = parent.balanceFactor match {
        case x if x < -1 =>
          if (parent.right.balanceFactor == 1) rotateRight(parent.right)
          val newRoot = rotateLeft(parent)
          if (parent == root) _root = newRoot
          newRoot
        case x if x > 1 =>
          if (parent.left.balanceFactor == -1) rotateLeft(parent.left)
          val newRoot = rotateRight(parent)
          if (parent == root) _root = newRoot
          newRoot
        case _ => parent
      }

      parent = current.balanceFactor match {
        case -1 | 1 => null
        case _ => current.parent
      }
    }

    if (node.parent != null) {
      if (node.parent.left == node) {
        node.parent._left = null
      } else {
        node.parent._right = null
      }
    }

    if (node == root) _root = null

    _size -= 1
    true
  }

  def findNode(key: A): Option[AVLNode] = {
    var node = root
    while (node != null) {
      val cmp = ordering.compare(key, node.key)
      if (cmp == 0) return Some(node)
      node = node.matchNextChild(cmp)
    }
    None
  }

  private def rotateLeft(node: AVLNode): AVLNode = {
    val rightNode = node.right
    node._right = rightNode.left
    if (node.right != null) node.right._parent = node

    rightNode._parent = node.parent
    if (rightNode.parent != null) {
      if (rightNode.parent.left == node) {
        rightNode.parent._left = rightNode
      } else {
        rightNode.parent._right = rightNode
      }
    }

    node._parent = rightNode
    rightNode._left = node

    node.balanceFactor += 1
    if (rightNode.balanceFactor < 0) {
      node.balanceFactor -= rightNode.balanceFactor
    }

    rightNode.balanceFactor += 1
    if (node.balanceFactor > 0) {
      rightNode.balanceFactor += node.balanceFactor
    }
    rightNode
  }

  private def rotateRight(node: AVLNode): AVLNode = {
    val leftNode = node.left
    node._left = leftNode.right
    if (node.left != null) node.left._parent = node

    leftNode._parent = node.parent
    if (leftNode.parent != null) {
      if (leftNode.parent.left == node) {
        leftNode.parent._left = leftNode
      } else {
        leftNode.parent._right = leftNode
      }
    }

    node._parent = leftNode
    leftNode._right = node

    node.balanceFactor -= 1
    if (leftNode.balanceFactor > 0) {
      node.balanceFactor -= leftNode.balanceFactor
    }

    leftNode.balanceFactor -= 1
    if (node.balanceFactor < 0) {
      leftNode.balanceFactor += node.balanceFactor
    }
    leftNode
  }

  override def contains(elem: A): Boolean = findNode(elem).isDefined

  override def iterator: Iterator[A] = ???

  override def keysIteratorFrom(start: A): Iterator[A] = ???

  class AVLNode private[AVLTree](k: A, p: AVLNode = null) {

    private[AVLTree] var _key: A = k
    private[AVLTree] var _parent: AVLNode = p
    private[AVLTree] var _left: AVLNode = _
    private[AVLTree] var _right: AVLNode = _
    private[AVLTree] var balanceFactor: Int = 0

    def parent: AVLNode = _parent

    private[AVLTree] def selectNextChild(key: A): AVLNode = matchNextChild(ordering.compare(key, this.key))

    def key: A = _key

    private[AVLTree] def matchNextChild(cmp: Int): AVLNode = cmp match {
      case x if x < 0 => left
      case x if x > 0 => right
      case _ => null
    }

    def left: AVLNode = _left

    def right: AVLNode = _right
  }

}

Scheme

Translation of: Fortran

See also ATS.

Works with: CHICKEN version 5.3.0
Library: r7rs

In the following, an argument key a is consider to match a stored key b if neither (pred<? a b) nor (pred<? b a). So pred<? should be analogous to <. No equality predicate is needed.

(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))
Output:

The demonstration is randomized. The following is an example of one run.

The ‘pretty printed’ tree is a diagonal reflection of the usual from-the-root-downwards, left-to-right representation. It goes from-the-root-rightwards, top-to-bottom.

$ csc -DDEMONSTRATION -R r7rs -X r7rs avl_trees-scheme.scm && ./avl_trees-scheme
----------------------------------------------------------------------
keys = (12 16 20 6 9 18 15 10 13 4 2 7 11 5 8 3 19 14 17 1)
----------------------------------------------------------------------
        (1, 1.0)		depth = 4 bal = 0
      (2, 2.0)		depth = 3 bal = 0
        (3, 3.0)		depth = 4 bal = 0
    (4, 4.0)		depth = 2 bal = -1
      (5, 5.0)		depth = 3 bal = 0
  (6, 6.0)		depth = 1 bal = 0
      (7, 7.0)		depth = 3 bal = 1
        (8, 8.0)		depth = 4 bal = 0
    (9, 9.0)		depth = 2 bal = 0
      (10, 10.0)		depth = 3 bal = 1
        (11, 11.0)		depth = 4 bal = 0
(12, 12.0)		depth = 0  bal = 0
      (13, 13.0)		depth = 3 bal = 0
    (14, 14.0)		depth = 2 bal = 0
      (15, 15.0)		depth = 3 bal = 0
  (16, 16.0)		depth = 1 bal = 1
        (17, 17.0)		depth = 4 bal = 0
      (18, 18.0)		depth = 3 bal = -1
    (19, 19.0)		depth = 2 bal = -1
      (20, 20.0)		depth = 3 bal = 0
----------------------------------------------------------------------
tree size = 20
(1, 1.0)
(2, 2.0)
(3, 3.0)
(4, 4.0)
(5, 5.0)
(6, 6.0)
(7, 7.0)
(8, 8.0)
(9, 9.0)
(10, 10.0)
(11, 11.0)
(12, 12.0)
(13, 13.0)
(14, 14.0)
(15, 15.0)
(16, 16.0)
(17, 17.0)
(18, 18.0)
(19, 19.0)
(20, 20.0)
----------------------------------------------------------------------
        (1, "1")		depth = 4 bal = 0
      (2, "2")		depth = 3 bal = 0
        (3, "3")		depth = 4 bal = 0
    (4, "4")		depth = 2 bal = -1
      (5, "5")		depth = 3 bal = 0
  (6, "6")		depth = 1 bal = 0
      (7, "7")		depth = 3 bal = 1
        (8, "8")		depth = 4 bal = 0
    (9, "9")		depth = 2 bal = 0
      (10, "10")		depth = 3 bal = 1
        (11, "11")		depth = 4 bal = 0
(12, "12")		depth = 0  bal = 0
      (13, "13")		depth = 3 bal = 0
    (14, "14")		depth = 2 bal = 0
      (15, "15")		depth = 3 bal = 0
  (16, "16")		depth = 1 bal = 1
        (17, "17")		depth = 4 bal = 0
      (18, "18")		depth = 3 bal = -1
    (19, "19")		depth = 2 bal = -1
      (20, "20")		depth = 3 bal = 0
----------------------------------------------------------------------
tree size = 20
(1, "1")
(2, "2")
(3, "3")
(4, "4")
(5, "5")
(6, "6")
(7, "7")
(8, "8")
(9, "9")
(10, "10")
(11, "11")
(12, "12")
(13, "13")
(14, "14")
(15, "15")
(16, "16")
(17, "17")
(18, "18")
(19, "19")
(20, "20")
----------------------------------------------------------------------
forwards generator:
(1, "1")
(2, "2")
(3, "3")
(4, "4")
(5, "5")
(6, "6")
(7, "7")
(8, "8")
(9, "9")
(10, "10")
(11, "11")
(12, "12")
(13, "13")
(14, "14")
(15, "15")
(16, "16")
(17, "17")
(18, "18")
(19, "19")
(20, "20")
----------------------------------------------------------------------
backwards generator:
(20, "20")
(19, "19")
(18, "18")
(17, "17")
(16, "16")
(15, "15")
(14, "14")
(13, "13")
(12, "12")
(11, "11")
(10, "10")
(9, "9")
(8, "8")
(7, "7")
(6, "6")
(5, "5")
(4, "4")
(3, "3")
(2, "2")
(1, "1")
----------------------------------------------------------------------

Sidef

Translation of: D
class AVLtree {

    has root = nil

    struct Node {
        Number key,
        Number balance = 0,
        Node left = nil,
        Node right = nil,
        Node parent = nil,
    }

    method insert(key) {
        if (root == nil) {
            root = Node(key)
            return true
        }

        var n = root
        var parent = nil

        loop {
            if (n.key == key) {
                return false
            }
            parent = n
            var goLeft = (n.key > key)
            n = (goLeft ? n.left : n.right)

            if (n == nil) {
                var tn = Node(key, parent: parent)
                if (goLeft) {
                    parent.left = tn
                }
                else {
                    parent.right = tn
                }
                self.rebalance(parent)
                break
            }
        }

        return true
    }

    method delete_key(delKey) {
        if (root == nil) { return nil }

        var n = root
        var parent = root
        var delNode = nil
        var child = root

        while (child != nil) {
            parent = n
            n = child
            child = (delKey >= n.key ? n.right : n.left)
            if (delKey == n.key) {
                delNode = n
            }
        }

        if (delNode != nil) {
            delNode.key = n.key
            child = (n.left != nil ? n.left : n.right)

            if (root.key == delKey) {
                root = child
            }
            else {
                if (parent.left == n) {
                    parent.left = child
                }
                else {
                    parent.right = child
                }
                self.rebalance(parent)
            }
        }
    }

    method rebalance(n) {
        if (n == nil) { return nil }
        self.setBalance(n)

        given (n.balance) {
            when (-2) {
                if (self.height(n.left.left) >= self.height(n.left.right)) {
                    n = self.rotate(n, :right)
                }
                else {
                    n = self.rotate_twice(n, :left, :right)
                }
            }
            when (2) {
                if (self.height(n.right.right) >= self.height(n.right.left)) {
                    n = self.rotate(n, :left)
                }
                else {
                    n = self.rotate_twice(n, :right, :left)
                }
            }
        }

        if (n.parent != nil) {
            self.rebalance(n.parent)
        }
        else {
            root = n
        }
    }

    method rotate(a, dir) {
        var b = (dir == :left ? a.right : a.left)
        b.parent = a.parent

        (dir == :left) ? (a.right = b.left)
                       : (a.left  = b.right)

        if (a.right != nil) {
            a.right.parent = a
        }

        b.$dir = a
        a.parent = b

        if (b.parent != nil) {
            if (b.parent.right == a) {
                b.parent.right = b
            }
            else {
                b.parent.left = b
            }
        }

        self.setBalance(a, b)
        return b
    }

    method rotate_twice(n, dir1, dir2) {
        n.left = self.rotate(n.left, dir1)
        self.rotate(n, dir2)
    }

    method height(n) {
        if (n == nil) { return -1 }
        1 + Math.max(self.height(n.left), self.height(n.right))
    }

    method setBalance(*nodes) {
        nodes.each { |n|
            n.balance = (self.height(n.right) - self.height(n.left))
        }
    }

    method printBalance {
        self.printBalance(root)
    }

    method printBalance(n) {
        if (n != nil) {
            self.printBalance(n.left)
            print(n.balance, ' ')
            self.printBalance(n.right)
        }
    }
}

var tree = AVLtree()

say "Inserting values 1 to 10"
{|i| tree.insert(i) } << 1..10
print "Printing balance: "
tree.printBalance
Output:
Inserting values 1 to 10
Printing balance: 0 0 0 1 0 0 0 0 1 0

Simula

CLASS AVL;
BEGIN
 
    ! AVL TREE ADAPTED FROM JULIENNE WALKER'S PRESENTATION AT ;
    ! HTTP://ETERNALLYCONFUZZLED.COM/TUTS/DATASTRUCTURES/JSW_TUT_AVL.ASPX. ;
    ! THIS PORT USES SIMILAR INDENTIFIER NAMES. ;
     
    ! THE KEY INTERFACE MUST BE SUPPORTED BY DATA STORED IN THE AVL TREE. ;
    CLASS KEY;
    VIRTUAL:
        PROCEDURE LESS  IS BOOLEAN PROCEDURE LESS (K); REF(KEY) K;;
        PROCEDURE EQUAL IS BOOLEAN PROCEDURE EQUAL(K); REF(KEY) K;;
    BEGIN
    END KEY;
     
    ! NODE IS A NODE IN AN AVL TREE. ;
    CLASS NODE(DATA); REF(KEY) DATA;  ! ANYTHING COMPARABLE WITH LESS AND EQUAL. ;
    BEGIN
        INTEGER  BALANCE;             ! BALANCE FACTOR ;
        REF(NODE) ARRAY LINK(0:1);    ! CHILDREN, INDEXED BY "DIRECTION", 0 OR 1. ;
    END NODE;
     
    ! A LITTLE READABILITY FUNCTION FOR RETURNING THE OPPOSITE OF A DIRECTION, ;
    ! WHERE A DIRECTION IS 0 OR 1. ;
    ! WHERE JW WRITES !DIR, THIS CODE HAS OPP(DIR). ;
    INTEGER PROCEDURE OPP(DIR); INTEGER DIR;
    BEGIN
        OPP := 1 - DIR;
    END OPP;
     
    ! SINGLE ROTATION ;
    REF(NODE) PROCEDURE SINGLE(ROOT, DIR); REF(NODE) ROOT; INTEGER DIR;
    BEGIN
        REF(NODE) SAVE;
        SAVE :- ROOT.LINK(OPP(DIR));
        ROOT.LINK(OPP(DIR)) :- SAVE.LINK(DIR);
        SAVE.LINK(DIR) :- ROOT;
        SINGLE :- SAVE;
    END SINGLE;
     
    ! DOUBLE ROTATION ;
    REF(NODE) PROCEDURE DOUBLE(ROOT, DIR); REF(NODE) ROOT; INTEGER DIR;
    BEGIN
        REF(NODE) SAVE;
        SAVE :- ROOT.LINK(OPP(DIR)).LINK(DIR);
     
        ROOT.LINK(OPP(DIR)).LINK(DIR) :- SAVE.LINK(OPP(DIR));
        SAVE.LINK(OPP(DIR)) :- ROOT.LINK(OPP(DIR));
        ROOT.LINK(OPP(DIR)) :- SAVE;
     
        SAVE :- ROOT.LINK(OPP(DIR));
        ROOT.LINK(OPP(DIR)) :- SAVE.LINK(DIR);
        SAVE.LINK(DIR) :- ROOT;
        DOUBLE :- SAVE;
    END DOUBLE;
     
    ! ADJUST BALANCE FACTORS AFTER DOUBLE ROTATION ;
    PROCEDURE ADJUSTBALANCE(ROOT, DIR, BAL); REF(NODE) ROOT; INTEGER DIR, BAL;
    BEGIN
        REF(NODE) N, NN;
        N :- ROOT.LINK(DIR);
        NN :- N.LINK(OPP(DIR));
        IF NN.BALANCE = 0   THEN BEGIN ROOT.BALANCE := 0;    N.BALANCE := 0;   END ELSE
        IF NN.BALANCE = BAL THEN BEGIN ROOT.BALANCE := -BAL; N.BALANCE := 0;   END
                            ELSE BEGIN ROOT.BALANCE := 0;    N.BALANCE := BAL; END;
        NN.BALANCE := 0;
    END ADJUSTBALANCE;
     
    REF(NODE) PROCEDURE INSERTBALANCE(ROOT, DIR); REF(NODE) ROOT; INTEGER DIR;
    BEGIN REF(NODE) N;  INTEGER BAL;
        N :- ROOT.LINK(DIR);
        BAL := 2*DIR - 1;
        IF N.BALANCE = BAL THEN
        BEGIN
            ROOT.BALANCE := 0;
            N.BALANCE := 0;
            INSERTBALANCE :- SINGLE(ROOT, OPP(DIR));
        END ELSE
        BEGIN
            ADJUSTBALANCE(ROOT, DIR, BAL);
            INSERTBALANCE :- DOUBLE(ROOT, OPP(DIR));
        END;
    END INSERTBALANCE;
    
    CLASS TUPLE(N,B); REF(NODE) N; BOOLEAN B;;
     
    REF(TUPLE) PROCEDURE INSERTR(ROOT, DATA); REF(NODE) ROOT; REF(KEY) DATA;
    BEGIN
        IF ROOT == NONE THEN
            INSERTR :- NEW TUPLE(NEW NODE(DATA), FALSE)
        ELSE
        BEGIN
            REF(TUPLE) T;  BOOLEAN DONE;  INTEGER DIR;
            DIR := 0;
            IF ROOT.DATA.LESS(DATA) THEN
                DIR := 1;
            T :- INSERTR(ROOT.LINK(DIR), DATA);
            ROOT.LINK(DIR) :- T.N;
            DONE := T.B;
            IF DONE THEN INSERTR :- NEW TUPLE(ROOT, TRUE) ELSE
            BEGIN
                ROOT.BALANCE := ROOT.BALANCE + 2*DIR - 1;
                IF ROOT.BALANCE = 0 THEN
                    INSERTR :- NEW TUPLE(ROOT, TRUE) ELSE
                IF ROOT.BALANCE = 1 OR ROOT.BALANCE = -1 THEN
                    INSERTR :- NEW TUPLE(ROOT, FALSE)
                ELSE
                    INSERTR :- NEW TUPLE(INSERTBALANCE(ROOT, DIR), TRUE);
            END;
        END;
    END INSERTR;
     
    ! INSERT A NODE INTO THE AVL TREE. ;
    ! DATA IS INSERTED EVEN IF OTHER DATA WITH THE SAME KEY ALREADY EXISTS. ;
    PROCEDURE INSERT(TREE, DATA); NAME TREE; REF(NODE) TREE; REF(KEY) DATA;
    BEGIN
        REF(TUPLE) T;
        T :- INSERTR(TREE, DATA);
        TREE :- T.N;
    END INSERT;
     
    REF(TUPLE) PROCEDURE REMOVEBALANCE(ROOT, DIR); REF(NODE) ROOT; INTEGER DIR;
    BEGIN REF(NODE) N;  INTEGER BAL;
        N :- ROOT.LINK(OPP(DIR));
        BAL := 2*DIR - 1;
    
        IF N.BALANCE = -BAL THEN
        BEGIN ROOT.BALANCE := 0; N.BALANCE := 0;
            REMOVEBALANCE :- NEW TUPLE(SINGLE(ROOT, DIR), FALSE);
        END ELSE
    
        IF N.BALANCE = BAL THEN
        BEGIN ADJUSTBALANCE(ROOT, OPP(DIR), -BAL);
            REMOVEBALANCE :- NEW TUPLE(DOUBLE(ROOT, DIR), FALSE);
        END ELSE
    
        BEGIN ROOT.BALANCE := -BAL; N.BALANCE := BAL;
            REMOVEBALANCE :- NEW TUPLE(SINGLE(ROOT, DIR), TRUE);
        END
    END REMOVEBALANCE;
     
    REF(TUPLE) PROCEDURE REMOVER(ROOT, DATA); REF(NODE) ROOT; REF(KEY) DATA;
    BEGIN INTEGER DIR; BOOLEAN DONE; REF(TUPLE) T;

        IF ROOT == NONE THEN
            REMOVER :- NEW TUPLE(NONE, FALSE)
        ELSE
        IF ROOT.DATA.EQUAL(DATA) THEN
        BEGIN
            IF ROOT.LINK(0) == NONE THEN
            BEGIN
                REMOVER :- NEW TUPLE(ROOT.LINK(1), FALSE);
                GOTO L;
            END
    
            ELSE IF ROOT.LINK(1) == NONE THEN
            BEGIN
                REMOVER :- NEW TUPLE(ROOT.LINK(0), FALSE);
                GOTO L;
            END
    
            ELSE
            BEGIN REF(NODE) HEIR;
                HEIR :- ROOT.LINK(0);
                WHILE HEIR.LINK(1) =/= NONE DO
                    HEIR :- HEIR.LINK(1);
                ROOT.DATA :- HEIR.DATA;
                DATA :- HEIR.DATA;
            END;
        END;
        DIR := 0;
        IF ROOT.DATA.LESS(DATA) THEN
            DIR := 1;
        T :- REMOVER(ROOT.LINK(DIR), DATA); ROOT.LINK(DIR) :- T.N; DONE := T.B;
        IF DONE THEN
        BEGIN
            REMOVER :- NEW TUPLE(ROOT, TRUE);
            GOTO L;
        END;
        ROOT.BALANCE := ROOT.BALANCE + 1 - 2*DIR;
        IF ROOT.BALANCE = 1 OR ROOT.BALANCE = -1 THEN
            REMOVER :- NEW TUPLE(ROOT, TRUE)
    
        ELSE IF ROOT.BALANCE = 0 THEN
            REMOVER :- NEW TUPLE(ROOT, FALSE)
    
        ELSE
            REMOVER :- REMOVEBALANCE(ROOT, DIR);
    L:
    END REMOVER;
     
    ! REMOVE A SINGLE ITEM FROM AN AVL TREE. ;
    ! IF KEY DOES NOT EXIST, FUNCTION HAS NO EFFECT. ;
    PROCEDURE REMOVE(TREE, DATA); NAME TREE; REF(NODE) TREE; REF(KEY) DATA;
    BEGIN REF(TUPLE) T;
        T :- REMOVER(TREE, DATA);
        TREE :- T.N;
    END REMOVEM;

END.

A demonstration program:

EXTERNAL CLASS AVL;

AVL
BEGIN
 
    KEY CLASS INTEGERKEY(I); INTEGER I;
    BEGIN
        BOOLEAN PROCEDURE LESS (K); REF(KEY) K; LESS  := I < K QUA INTEGERKEY.I;
        BOOLEAN PROCEDURE EQUAL(K); REF(KEY) K; EQUAL := I = K QUA INTEGERKEY.I;
    END INTEGERKEY;

    PROCEDURE DUMP(ROOT); REF(NODE) ROOT;
    BEGIN
        IF ROOT =/= NONE THEN
        BEGIN
            DUMP(ROOT.LINK(0));
            OUTINT(ROOT.DATA QUA INTEGERKEY.I, 0); OUTTEXT(" ");
            DUMP(ROOT.LINK(1));
        END
    END DUMP;

    INTEGER I;
    REF(NODE) TREE;
    OUTTEXT("Empty tree: "); DUMP(TREE); OUTIMAGE;
 
    FOR I := 3, 1, 4, 1, 5 DO
    BEGIN OUTTEXT("Insert "); OUTINT(I, 0); OUTTEXT(": ");
          INSERT(TREE, NEW INTEGERKEY(I)); DUMP(TREE); OUTIMAGE;
    END;
 
    FOR I := 3, 1 DO
    BEGIN OUTTEXT("Remove "); OUTINT(I, 0); OUTTEXT(": ");
          REMOVE(TREE, NEW INTEGERKEY(I)); DUMP(TREE); OUTIMAGE;
    END;

END.
Output:
Empty tree:
Insert 3: 3
Insert 1: 1 3
Insert 4: 1 3 4
Insert 1: 1 1 3 4
Insert 5: 1 1 3 4 5
Remove 3: 1 1 4 5
Remove 1: 1 4 5

Tcl

Note that in general, you would not normally write a tree directly in Tcl when writing code that required an = map, but would rather use either an array variable or a dictionary value (which are internally implemented using a high-performance hash table engine).

Works with: Tcl version 8.6
package require TclOO

namespace eval AVL {
    # Class for the overall tree; manages real public API
    oo::class create Tree {
	variable root nil class
	constructor {{nodeClass AVL::Node}} {
	    set class [oo::class create Node [list superclass $nodeClass]]
 
	    # Create a nil instance to act as a leaf sentinel
	    set nil [my NewNode ""]
	    set root [$nil ref]

	    # Make nil be special
	    oo::objdefine $nil {
		method height {} {return 0}
		method key {} {error "no key possible"}
		method value {} {error "no value possible"}
		method destroy {} {
		    # Do nothing (doesn't prohibit destruction entirely)
		}
		method print {indent increment} {
		    # Do nothing
		}
	    }
	}

	# How to actually manufacture a new node
	method NewNode {key} {
	    if {![info exists nil]} {set nil ""}
	    $class new $key $nil [list [namespace current]::my NewNode]
	}

	# Create a new node in the tree and return it
	method insert {key} {
	    set node [my NewNode $key]
	    if {$root eq $nil} {
		set root $node
	    } else {
		$root insert $node
	    }
	    return $node
	}

	# Find the node for a particular key
	method lookup {key} {
	    for {set node $root} {$node ne $nil} {} {
		if {[$node key] == $key} {
		    return $node
		} elseif {[$node key] > $key} {
		    set node [$node left]
		} else {
		    set node [$node right]
		}
	    }
	    error "no such node"
	}

	# Print a tree out, one node per line
	method print {{indent 0} {increment 1}} {
	    $root print $indent $increment
	    return
	}
    }

    # Class of an individual node; may be subclassed
    oo::class create Node {
	variable key value left right 0 refcount newNode
	constructor {n nil instanceFactory} {
	    set newNode $instanceFactory
	    set 0 [expr {$nil eq "" ? [self] : $nil}]
	    set key $n
	    set value {}
	    set left [set right $0]
	    set refcount 0
	}
	method ref {} {
	    incr refcount
	    return [self]
	}
	method destroy {} {
	    if {[incr refcount -1] < 1} next
	}
	method New {key value} {
	    set n [{*}$newNode $key]
	    $n setValue $value
	    return $n
	}

	# Getters
	method key {} {return $key}
	method value {} {return $value}
	method left {} {return $left}
	method right {args} {return $right}

	# Setters
	method setValue {newValue} {
	    set value $newValue
	}
	method setLeft {node} {
	    # Non-trivial because of reference management
	    $node ref
	    $left destroy
	    set left $node
	    return
	}
	method setRight {node} {
	    # Non-trivial because of reference management
	    $node ref
	    $right destroy
	    set right $node
	    return
	}

	# Print a node and its descendents
	method print {indent increment} {
	    puts [format "%s%s => %s" [string repeat " " $indent] $key $value]
	    incr indent $increment
	    $left print $indent $increment
	    $right print $indent $increment
	}

	method height {} {
	    return [expr {max([$left height], [$right height]) + 1}]
	}
	method balanceFactor {} {
	    expr {[$left height] - [$right height]}
	}

	method insert {node} {
	    # Simple insertion
	    if {$key > [$node key]} {
		if {$left eq $0} {
		    my setLeft $node
		} else {
		    $left insert $node
		}
	    } else {
		if {$right eq $0} {
		    my setRight $node
		} else {
		    $right insert $node
		}
	    }

	    # Rebalance this node
	    if {[my balanceFactor] > 1} {
		if {[$left balanceFactor] < 0} {
		    $left rotateLeft
		}
		my rotateRight
	    } elseif {[my balanceFactor] < -1} {
		if {[$right balanceFactor] > 0} {
		    $right rotateRight
		}
		my rotateLeft
	    }
	}

	# AVL Rotations
	method rotateLeft {} {
	    set new [my New $key $value]
	    set key [$right key]
	    set value [$right value]
	    $new setLeft $left
	    $new setRight [$right left]
	    my setLeft $new
	    my setRight [$right right]
	}

	method rotateRight {} {
	    set new [my New $key $value]
	    set key [$left key]
	    set value [$left value]
	    $new setLeft [$left right]
	    $new setRight $right
	    my setLeft [$left left]
	    my setRight $new
	}
    }
}

Demonstrating:

# Create an AVL tree
AVL::Tree create tree

# Populate it with some semi-random data
for {set i 33} {$i < 127} {incr i} {
    [tree insert $i] setValue \
	[string repeat [format %c $i] [expr {1+int(rand()*5)}]]
}

# Print it out
tree print

# Look up a few values in the tree
for {set i 0} {$i < 10} {incr i} {
    set k [expr {33+int((127-33)*rand())}]
    puts $k=>[[tree lookup $k] value]
}

# Destroy the tree and all its nodes
tree destroy
Output:
64 => @@@
 48 => 000
  40 => (((((
   36 => $
    34 => """
     33 => !!
     35 => #####
    38 => &&&
     37 => %
     39 => ''''
   44 => ,
    42 => **
     41 => )))
     43 => +++++
    46 => .
     45 => --
     47 => ////
  56 => 888
   52 => 444
    50 => 22222
     49 => 1111
     51 => 333
    54 => 6
     53 => 555
     55 => 77
   60 => <<<<
    58 => ::::
     57 => 99999
     59 => ;
    62 => >>>
     61 => ===
     63 => ??
 96 => ``
  80 => PPPPP
   72 => HHHH
    68 => DDD
     66 => BBBB
      65 => A
      67 => CCC
     70 => FFF
      69 => EEEE
      71 => GGG
    76 => LL
     74 => JJ
      73 => III
      75 => KKKK
     78 => N
      77 => MMMMM
      79 => OOOOO
   88 => XXX
    84 => TTTT
     82 => R
      81 => QQQQ
      83 => SSSS
     86 => V
      85 => UUU
      87 => WWW
    92 => \\\
     90 => Z
      89 => YYYYY
      91 => [
     94 => ^^^^^
      93 => ]]]]
      95 => _____
  112 => pppp
   104 => hh
    100 => d
     98 => bb
      97 => aaa
      99 => cccc
     102 => ff
      101 => eeee
      103 => gggg
    108 => lll
     106 => j
      105 => iii
      107 => kkkkk
     110 => nn
      109 => m
      111 => o
   120 => x
    116 => ttt
     114 => rrrrr
      113 => qqqqq
      115 => s
     118 => vvv
      117 => uuuu
      119 => wwww
    124 => ||||
     122 => zzzz
      121 => y
      123 => {{{
     125 => }}}}
      126 => ~~~~
53=>555
55=>77
60=><<<<
100=>d
99=>cccc
93=>]]]]
57=>99999
56=>888
47=>////
39=>''''

TypeScript

Translation of: Java

For use within a project, consider adding "export default" to AVLtree class declaration.

/** A single node in an AVL tree */
class AVLnode <T> {
    balance: number
    left: AVLnode<T>
    right: AVLnode<T>

    constructor(public key: T, public parent: AVLnode<T> = null) {
        this.balance = 0
        this.left = null
        this.right = null
    }
}

/** The balanced AVL tree */
class AVLtree <T> {
    // public members organized here
    constructor() {
        this.root = null
    }

    insert(key: T): boolean {
        if (this.root === null) {
            this.root = new AVLnode<T>(key)
        } else {
            let n: AVLnode<T> = this.root,
                parent: AVLnode<T> = null

            while (true) {
                if(n.key === key) {
                    return false
                }

                parent = n

                let goLeft: boolean = n.key > key
                n = goLeft ? n.left : n.right

                if (n === null) {
                    if (goLeft) {
                        parent.left = new AVLnode<T>(key, parent)
                    } else {
                        parent.right = new AVLnode<T>(key, parent)
                    }

                    this.rebalance(parent)
                    break
                }
            }
        }

        return true
    }

    deleteKey(delKey: T): void {
        if (this.root === null) {
            return
        }

        let n: AVLnode<T> = this.root,
            parent: AVLnode<T> = this.root,
            delNode: AVLnode<T> = null,
            child: AVLnode<T> = this.root
        
        while (child !== null) {
            parent = n
            n = child
            child = delKey >= n.key ? n.right : n.left
            if (delKey === n.key) {
                delNode = n
            }
        }

        if (delNode !== null) {
            delNode.key = n.key

            child = n.left !== null ? n.left : n.right

            if (this.root.key === delKey) {
                this.root = child
            } else {
                if (parent.left === n) {
                    parent.left = child
                } else {
                    parent.right = child
                }

                this.rebalance(parent)
            }
        }
    }

    treeBalanceString(n: AVLnode<T> = this.root): string {
        if (n !== null) {
            return `${this.treeBalanceString(n.left)} ${n.balance} ${this.treeBalanceString(n.right)}`
        }
        return ""
    }

    toString(n: AVLnode<T> = this.root): string {
        if (n !== null) {
            return `${this.toString(n.left)} ${n.key} ${this.toString(n.right)}`
        }
        return ""
    }


    // private members organized here
    private root: AVLnode<T>

    private rotateLeft(a: AVLnode<T>): AVLnode<T> {
        let b: AVLnode<T> = a.right
        b.parent = a.parent
        a.right = b.left

        if (a.right !== null) {
            a.right.parent = a
        }

        b.left = a
        a.parent = b

        if (b.parent !== null) {
            if (b.parent.right === a) {
                b.parent.right = b
            } else {
                b.parent.left = b
            }
        }

        this.setBalance(a)
        this.setBalance(b)

        return b
    }

    private rotateRight(a: AVLnode<T>): AVLnode<T> {
        let b: AVLnode<T> = a.left
        b.parent = a.parent
        a.left = b.right

        if (a.left !== null) {
            a.left.parent = a
        }

        b.right = a
        a.parent = b

        if (b.parent !== null) {
            if (b.parent.right === a) {
                b.parent.right = b
            } else {
                b.parent.left = b
            }
        }

        this.setBalance(a)
        this.setBalance(b)

        return b
    }

    private rotateLeftThenRight(n: AVLnode<T>): AVLnode<T> {
        n.left = this.rotateLeft(n.left)
        return this.rotateRight(n)
    }

    private rotateRightThenLeft(n: AVLnode<T>): AVLnode<T> {
        n.right = this.rotateRight(n.right)
        return this.rotateLeft(n)
    }

    private rebalance(n: AVLnode<T>): void {
        this.setBalance(n)

        if (n.balance === -2) {
            if(this.height(n.left.left) >= this.height(n.left.right)) {
                n = this.rotateRight(n)
            } else {
                n = this.rotateLeftThenRight(n)
            }
        } else if (n.balance === 2) {
            if(this.height(n.right.right) >= this.height(n.right.left)) {
                n = this.rotateLeft(n)
            } else {
                n = this.rotateRightThenLeft(n)
            }
        }

        if (n.parent !== null) {
            this.rebalance(n.parent)
        } else {
            this.root = n
        }
    }

    private height(n: AVLnode<T>): number {
        if (n === null) {
            return -1
        }
        return 1 + Math.max(this.height(n.left), this.height(n.right))
    }

    private setBalance(n: AVLnode<T>): void {
        n.balance = this.height(n.right) - this.height(n.left)
    }
    
    public showNodeBalance(n: AVLnode<T>): string {
        if (n !== null) {
            return `${this.showNodeBalance(n.left)} ${n.balance} ${this.showNodeBalance(n.right)}`
        }
        return ""
    }
}

Wren

Translation of: Kotlin
class Node {
    construct new(key, parent) {
        _key = key
        _parent = parent
        _balance = 0
        _left = null
        _right = null
    }

    key     { _key     }
    parent  { _parent  }
    balance { _balance }
    left    { _left    }
    right   { _right   }

    key=(k)     { _key = k     }
    parent=(p)  { _parent = p  }
    balance=(v) { _balance = v }
    left=(n)    { _left = n    }
    right= (n)  { _right = n   }
}

class AvlTree {
    construct new() {
        _root = null
    }

    insert(key) {
        if (!_root) {
            _root = Node.new(key, null)
        } else {
            var n = _root
            while (true) {
                if (n.key == key) return false
                var parent = n
                var goLeft = n.key > key
                n = goLeft ? n.left : n.right
                if (!n) {
                    if (goLeft) {
                        parent.left  = Node.new(key, parent)
                    } else {
                        parent.right = Node.new(key, parent)
                    }
                    rebalance(parent)
                    break
                }
            }
       }
       return true
    }

    delete(delKey) {
        if (!_root) return
        var n       = _root
        var parent  = _root
        var delNode = null
        var child   = _root
        while (child) {
            parent = n
            n = child
            child = (delKey >= n.key) ? n.right : n.left
            if (delKey == n.key) delNode = n
        }
        if (delNode) {
            delNode.key = n.key
            child = n.left ? n.left : n.right
            if (_root.key == delKey) {
                _root = child 
                if (_root) _root.parent = null
            } else {
                if (parent.left == n) {
                    parent.left = child
                } else {
                    parent.right = child
                }
                if (child) child.parent = parent
                rebalance(parent)
            }
        }
    }

    rebalance(n) {
        setBalance([n])
        var nn = n
        if (nn.balance == -2) {
            if (height(nn.left.left) >= height(nn.left.right)) {
                nn = rotateRight(nn)
            } else {
                nn = rotateLeftThenRight(nn)
            }
        } else if (nn.balance == 2) {
            if (height(nn.right.right) >= height(nn.right.left)) {
                nn = rotateLeft(nn)
            } else {
                nn = rotateRightThenLeft(nn)
            }
        }
        if (nn.parent) rebalance(nn.parent) else _root = nn
    }

    rotateLeft(a) {
        var b = a.right
        b.parent = a.parent
        a.right = b.left
        if (a.right) a.right.parent = a
        b.left = a
        a.parent = b
        if (b.parent) {
            if (b.parent.right == a) {
                b.parent.right = b
            } else {
                b.parent.left = b
            }
        }
        setBalance([a, b])
        return b
    }

    rotateRight(a) {
        var b = a.left
        b.parent = a.parent
        a.left = b.right
        if (a.left) a.left.parent = a
        b.right = a
        a.parent = b
        if (b.parent) {
            if (b.parent.right == a) {
                b.parent.right = b
            } else {
                b.parent.left = b
            }
        }
        setBalance([a, b])
        return b
    }

    rotateLeftThenRight(n) {
        n.left = rotateLeft(n.left)
        return rotateRight(n)
    }

    rotateRightThenLeft(n) {
        n.right = rotateRight(n.right)
        return rotateLeft(n)
    }

    height(n) {
        if (!n) return -1
        return 1 + height(n.left).max(height(n.right))
    }

    setBalance(nodes) {
        for (n in nodes) n.balance = height(n.right) - height(n.left)
    }

    printKey() {
        printKey(_root)
        System.print()
    }
 
    printKey(n) {
        if (n) {
            printKey(n.left)
            System.write("%(n.key) ")
            printKey(n.right)
        }
    }

    printBalance() {
        printBalance(_root)
        System.print()
    }
 
    printBalance(n) {
        if (n) {
            printBalance(n.left)
            System.write("%(n.balance) ")
            printBalance(n.right)
        }
    }
}

var tree = AvlTree.new()
System.print("Inserting values 1 to 10")
for (i in 1..10) tree.insert(i)
System.write("Printing key     : ")
tree.printKey()
System.write("Printing balance : ")
tree.printBalance()
Output:
Inserting values 1 to 10
Printing key     : 1 2 3 4 5 6 7 8 9 10 
Printing balance : 0 0 0 1 0 0 0 0 1 0 

Yabasic

// AVL-Tree C code, https://www.programiz.com/dsa/avl-tree
// Ported to Yabasic by Galileo 2022/07

KEY = 1 : LRIGHT = 2 : LLEFT = 3 : HEIGHT = 4

root = 0 : ramas = 5 : indice = 0

dim arbol(ramas, 4)


sub rotateRight(y)
    local x, T2
    
    x = arbol(y, LLEFT)
    T2 = arbol(x, LRIGHT)
    arbol(x, LRIGHT) = y
    arbol(y, LLEFT) = T2
    arbol(y, HEIGHT) = max(height(arbol(y, LLEFT)), height(arbol(y, LRIGHT))) + 1
    arbol(x, HEIGHT) = max(height(arbol(x, LLEFT)), height(arbol(x, LRIGHT))) + 1
    return x
end sub


sub rotateLeft(x)
    local y, T2
    
    y = arbol(x, LRIGHT)
    T2 = arbol(y, LLEFT)
    arbol(y, LLEFT) = x
    arbol(x, LRIGHT) = T2
    arbol(x, HEIGHT) = max(height(arbol(x, LLEFT)), height(arbol(x, LRIGHT))) + 1
    arbol(y, HEIGHT) = max(height(arbol(y, LLEFT)), height(arbol(y, LRIGHT))) + 1
    return y
end sub


sub Balance(current)
    return height(arbol(current, LLEFT)) - height(arbol(current, LRIGHT))
end sub


sub height(current)
    return arbol(current, HEIGHT)
end sub


sub insert(current, key)
    local balance
    
    if current = 0 indice = indice + 1 : if indice > ramas then ramas = ramas + 5 : redim arbol(ramas, 4) endif : arbol(indice, KEY) = key : arbol(indice, HEIGHT) = 1 : return indice
    if key < arbol(current, KEY) then
        arbol(current, LLEFT) = insert(arbol(current, LLEFT), key)
    elsif key > arbol(current, KEY) then
        arbol(current, LRIGHT) = insert(arbol(current, LRIGHT), key)
    else
        return current
    endif
    
    arbol(current, HEIGHT) = max(height(arbol(current, LLEFT)), height(arbol(current, LRIGHT))) + 1
    balance = Balance(current) 
    if balance > 1 and key < arbol(arbol(current, LLEFT), KEY) return rotateRight(current)
    if balance < -1 and key > arbol(arbol(current, LRIGHT), KEY) return rotateLeft(current)
    if balance > 1 and key > arbol(arbol(current, LLEFT), KEY) then
        arbol(current, LLEFT) = rotateLeft(arbol(current, LLEFT))
        return rotateRight(current)
    endif
    if balance < -1 and key < arbol(arbol(current, LRIGHT), KEY) then
        arbol(current, LRIGHT) = rotateRight(arbol(current, LRIGHT))
        return rotateLeft(current)
    endif
    return current
end sub


sub minValueNode(current)
  while arbol(current, LLEFT)
    current = arbol(current, LLEFT)
  wend

  return current
end sub

// Delete a nodes
sub deleteNode(root, key)
    local temp, balance
  // Find the node and delete it
  if root = 0 return root

  if key < arbol(root, KEY) then
    arbol(root, LLEFT) = deleteNode(arbol(root, LLEFT), key)
  elsif key > arbol(root, KEY) then
    arbol(root, LRIGHT) = deleteNode(arbol(root, LRIGHT), key)
  else
    if arbol(root, LLEFT) = 0 or arbol(root, LRIGHT) = 0 then
      temp = max(arbol(root, LLEFT), arbol(root, LRIGHT))

      if temp = 0 then
        temp = root
        root = 0
      else
        root = temp
      endif
    else
      temp = minValueNode(arbol(root, LRIGHT))
      arbol(root, KEY) = arbol(temp, KEY)
      arbol(root, LRIGHT) = deleteNode(arbol(root, LRIGHT), arbol(temp, KEY))
    endif
  endif

  if root = 0 return root

  // Update the balance factor of each node and
  // balance the tree
  arbol(root, HEIGHT) = 1 + max(height(arbol(root, LLEFT)), height(arbol(root, LRIGHT)))

  balance = Balance(root)
  if balance > 1 and Balance(arbol(root, LLEFT)) >= 0 return rightRotate(root)
  if balance > 1 and Balance(arbol(root, LLEFT)) < 0 arbol(root, LLEFT) = leftRotate(arbol(root, LLEFT)) : return rightRotate(root)
  if balance < -1 and Balance(arbol(root, LRIGHT)) <= 0 return leftRotate(root)
  if balance < -1 and Balance(arbol(root, LRIGHT)) > 0 arbol(root, LRIGHT) = rightRotate(arbol(root, LRIGHT)) : return leftRotate(root)

  return root
end sub

sub preOrder(temp)
    if temp then
        print arbol(temp, KEY), " ", arbol(temp, HEIGHT), " ", Balance(temp)
        preOrder(arbol(temp, LLEFT))
        preOrder(arbol(temp, LRIGHT))
    endif
end sub


  root = insert(root, 2)
  root = insert(root, 1)
  root = insert(root, 7)
  root = insert(root, 4)
  root = insert(root, 5)
  root = insert(root, 3)
  root = insert(root, 8)

  preOrder(root)

  root = deleteNode(root, 3)

  print "\nAfter deletion: "
  preOrder(root)
Output:
4 3 0
2 2 0
1 1 0
3 1 0
7 2 0
5 1 0
8 1 0

After deletion:
4 3 0
2 2 1
1 1 0
7 2 0
5 1 0
8 1 0
---Program done, press RETURN---