AVL tree: Difference between revisions
Add Emacs Lisp
(julia example) |
(Add Emacs Lisp) |
||
| (115 intermediate revisions by 18 users not shown) | |||
Line 2:
{{wikipedia|AVL tree}}
[[Category:Data Structures]]
<br>
Line 13 ⟶ 12:
Implement an AVL tree in the language of choice, and provide at least basic operations.
<br><br>
;Related task
[[Red_black_tree_sort]]
<br><br>
=={{header|AArch64 Assembly}}==
{{works with|as|Raspberry Pi 3B version Buster 64 bits}}
<syntaxhighlight lang="aarch64 assembly">
/* 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"
</syntaxhighlight>
=={{header|Ada}}==
{{trans|C++}}
<syntaxhighlight lang="ada">
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;
</syntaxhighlight>
{{Output}}
<pre>
Printing balance: 0 0 0 1 0 0 0 0 1 0
</pre>
=={{header|Agda}}==
This implementation uses the type system to enforce the height invariants, though not the BST invariants
<
module Avl where
Line 120 ⟶ 1,235:
... | Same T' = avl T'
... | Bigger T' = avl T'
</syntaxhighlight>
=={{header|ARM Assembly}}==
{{works with|as|Raspberry Pi}}
<syntaxhighlight lang="arm assembly">
/* 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
ldr r0,iAdrszMessErreur
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
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
@ search value
ldr r0,iAdrstTree1 @ tree root address (begin structure)
mov r1,#11 @ value to search
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
99: @ display error
ldr r0,iAdrszMessErreur
bl affichageMess
100: @ standard end of the program
mov r7, #EXIT @ request to exit program
svc 0
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
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
ldrne r8,[r7,#node_height]
ldr r7,[r5,#node_left]
cmp
moveq
ldrne r9,[r7,#node_height]
sub
cmp r3,#2
bne 100f
ldr r7,[r6,#node_right]
cmp r7,#0
moveq
ldrne r8,[r7,#node_height]
ldr r7,[r6,#node_left]
cmp
moveq r9,#0
ldrne r9,[r7,#node_height]
sub r3,r8,r9
cmp
ble 2f
mov r0,r5
bl rotLeft
b
2:
mov
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
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
2:
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"
</syntaxhighlight>
{{Output}}
<pre>
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
</pre>
=={{header|ATS}}==
=== Persistent, non-linear trees ===
{{trans|Scheme}}
See also [[#Fortran|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.)
<syntaxhighlight lang="ats">(*------------------------------------------------------------------*)
#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 _
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 _
prval
val _
}
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,
fixbal :
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 :
(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 :
(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 :
[sz :
(avl_t (key_t, data_t, sz),
balance_for_shrunken_left<key_t><data_t> p
fn
balance_R__ {size :
(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 :
(p
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 :
(p
fixbal : fixbal_t)
[sz :
(avl_t (key_t, data_t, sz),
if fixbal
balance_R__ p
else
(p, F)
fun
del {size :
(r : avl_t (key_t, data_t,
fixbal : fixbal_t) :<!ntm>
(* Returns a new avl_t, a new fixbal, and key and
‘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 :
(p : avl_t (key_t, data_t,
fixbal : fixbal_t)
(* Return three values: a new avl_t, a new fixbal,
whether the key was
[sz :
(avl_t (key_t, data_t, sz), fixbal_t,
case+ p
| NIL => (p, F,
| CONS (k, d, bal,
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}
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
| 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
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
traverse {n :
{size : nat}
(lst : list ((key_t, data_t),
p : avl_t
[sz : pos] avl_t (key_t, data_t,
case+ lst of
| (k, d) :: LNIL => avl_t_insert<key_t><data_t> (p, k, d)
| (k, d) :: (_ :: _)
let
val+ _ :: tail =
traverse (tail, avl_t_insert<key_t><data_t> (p, k,
end
in
case+ lst of
| LNIL => NIL
| (_ :: _) => traverse (lst, NIL)
end
fun {key_t : t@ype}
{data_t :
push_all_the_way_left (stack : List (avl_t (key_t, data_t)),
p
List0 (avl_t (key_t, data_t)) =
prval _ = lemma_list_param stack
in
case+ p of
| NIL => stack
| CONS (_, _, _, left, _)
push_all_the_way_left (p :: stack,
end
fun {key_t : t@ype}
{data_t :
push_all_the_way_right (stack : List (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 :
push_all_the_way (stack : List (avl_t (key_t, data_t)),
p
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 :
update_generator_stack (stack : List (avl_t (key_t, data_t)),
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
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
(* 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
val
$UNSAFE.castvwtp0{ref (List avl_t)} p_stack_ref
var stack : List0
var retval : Option
in
case+ stack
| LNIL => retval := None
| p :: tail
val- CONS (k, d, _, left,
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_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
(* 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)}
var stack : List0
var retval : Option key_t
in
case+ stack of
| LNIL => retval := None
| p :: tail
val- CONS (k, _, _, left,
in
retval := Some
stack
(tail, left, right,
!stack_ref := stack;
in
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
(* 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)}
var stack : List0
var retval : Option data_t
in
case+ stack of
| LNIL => retval := None
| p :: tail
val- CONS (_, d, _, left, right) =
retval := Some
stack
(tail, left, right,
end;
!stack_ref :=
in
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,
| CONS (k, d, bal, left, right)
val (height_LL, height_LR) = get_heights
val (height_RL, height_RR) = get_heights right
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
*)
%{^
#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
let
var i : [i
for (i := i2sz 0; i < n; i := succ i)
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
var a_saved : avl_t (int,
var a1 : (avl_t (int, double),
var i : [i : nat] int i
val dflt =
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
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
let
var j : [j : nat] int
in
a := avl_t_insert<int> (a, keys[i], g0i2f keys[i]);
assertloc (avl_t_size a = succ
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],
avl_t_check_avl_condition (a);
assertloc (avl_t_search<int><double> (a, keys[i], 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
avl_t_check_avl_condition (a);
assertloc (avl_t_size a = succ
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
val k =
val has_key = avl_t_has_key<int> (a,
val data_opt = avl_t_search<int><double> (a,
val data_dflt = avl_t_search<int><double>
in
assertloc (has_key = (j <=
assertloc (option_is_some data_opt = (j <=
if (j <=
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
(*------------------------------------------------------------------*)</syntaxhighlight>
{{out}}
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.)
<pre>$ 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
----------------------------------------------------</pre>
=={{header|C}}==
Line 759 ⟶ 3,814:
See [[AVL_tree/C|AVL tree/C]]
=={{header|C sharp|C#}}==
See [[AVL_tree/C_sharp]].
Line 765 ⟶ 3,820:
=={{header|C++}}==
{{trans|D}}
<
#include <algorithm>
#include <iostream>
Line 807 ⟶ 3,862:
void setBalance ( AVLnode<T> *n );
void printBalance ( AVLnode<T> *n );
};
Line 1,022 ⟶ 4,076:
t.printBalance();
}
</syntaxhighlight>
{{out}}
<pre>
Line 1,032 ⟶ 4,086:
See [[AVL_tree/C++]]
==
See [[AVL_tree/Managed_C++]]
=={{header|Common Lisp}}==
Provided is an imperative implementation of an AVL tree with a similar interface and documentation to HASH-TABLE.
<
(:use :cl)
(:export
Line 1,324 ⟶ 4,378:
(let ((tree (make-avl-tree #'<=))
(randoms (loop repeat 1000000 collect (random 100.0))))
(loop for key in randoms do (setf (gettree key tree) key))))</
=={{header|Component Pascal}}==
{{works with|BlackBox Component Builder}}
Two modules are provided - one for implementing and one for using AVL trees
<syntaxhighlight lang="oberon2">
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.
</syntaxhighlight>
Interface extracted from implementation:
<syntaxhighlight lang="oberon2">
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.
</syntaxhighlight>
Module that uses previous module:
<syntaxhighlight lang="oberon2">
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.
</syntaxhighlight>
Execute: ^Q RosettaAVLTreesUse.Use
{{out}}
<pre>
+--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
</pre>
=={{header|D}}==
{{trans|Java}}
<
class AVLtree {
Line 1,522 ⟶ 4,946:
write("Printing balance: ");
tree.printBalance;
}</
{{out}}
<pre>Inserting values 1 to 10
Printing balance: 0 0 0 1 0 0 0 0 1 0 </pre>
=={{header|Emacs Lisp}}==
{{trans|Java}}
<syntaxhighlight lang="lisp">
(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) " ")))
</syntaxhighlight>
{{out}}
<pre>
Inserting values 1 to 10
Printing balance: 0 0 0 1 0 1 0 0 0 0
</pre>
=={{header|Fortran}}==
{{works with|Fortran|2008}}
{{works with|Fortran|2018}}
See also [[#ATS|ATS]] and [[#Scheme|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.
<syntaxhighlight lang="fortran">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</syntaxhighlight>
{{out}}
The demonstration is randomized, so this is just one example of a run.
<pre>$ 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)
----------------------------------------------------------------------</pre>
=={{header|Generic}}==
The Generic Language is a database compiler. The code is compiled into database and then executed out of database.
<syntaxhighlight lang="cpp">
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)}</syntaxhighlight>
=={{header|Go}}==
A package:
<
// AVL tree adapted from Julienne Walker's presentation at
Line 1,694 ⟶ 7,970:
func Remove(tree **Node, data Key) {
*tree, _ = removeR(*tree, data)
}</
A demonstration program:
<
import (
Line 1,738 ⟶ 8,014:
avl.Remove(&tree, intKey(1))
dump(tree)
}</
{{out}}
<pre>
Line 1,809 ⟶ 8,085:
=={{header|Haskell}}==
Based on solution of homework #4 from course http://www.seas.upenn.edu/~cis194/spring13/lectures.html.
<
= Leaf
| Node
(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
depth a b = succ (max (height a) (height b))
insert v Leaf = Node 1 Leaf v Leaf
insert v t@(Node n left v_ right)
Line 1,837 ⟶ 8,110:
| 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) =
Line 1,846 ⟶ 8,117:
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 (
| 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
Line 1,890 ⟶ 8,157:
node = padding d <> show (v, h) <> "\n"
padding n = replicate (n * 4) ' '
main :: IO ()
main = putStr $ draw $ foldTree [1 ..
{{Out}}
<pre> (
(
(
(
(
(
(
(
(
(
(
(
(
(
(
(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)</pre>
=={{header|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 [[wp:AoS_and_SoA#Structure_of_arrays|structure of arrays]] for best performance with that approach. (Typical avl implementation also uses memory equivalent to several copies of a flat list.)
Implementation:
<syntaxhighlight lang="j">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
}}</syntaxhighlight>
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:
<pre style="line-height: 0.9em"> 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│││ │ ││ │└┴─┴─┘│
││└─┴─┴┘│ │ ││ │ │
│└──────┴─┴─┘│ │ │
└────────────┴─┴──────┘</pre>
=={{header|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.)
<
private Node root;
Line 2,130 ⟶ 8,541:
tree.printBalance();
}
}</
<pre>Inserting values 1 to 10
Line 2,137 ⟶ 8,548:
=== More elaborate version ===
See [[AVL_tree/Java]]
=={{header|Javascript}}==
<syntaxhighlight lang="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);
}
}
}</syntaxhighlight>
Some examples:
<syntaxhighlight lang="javascript">
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();</syntaxhighlight>
{{out}}
<pre>(((((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,))</pre>
=={{header|Julia}}==
{{trans|Sidef}}
<syntaxhighlight lang="julia">module AVLTrees
import Base.print
export AVLNode, AVLTree, insert,
@enum Direction LEFT RIGHT
avlhash(x) = Int32(hash(x) & 0xfffffff)
const MIDHASH = Int32(div(0xfffffff, 2))
mutable struct AVLNode{T}
Line 2,159 ⟶ 8,696:
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}
Line 2,184 ⟶ 8,720:
parent.right = AVLNode(value, key, 0, nothing, nothing, parent)
end
rebalance(parent)
break
end
Line 2,225 ⟶ 8,738:
end
end
if delnode
if node.key == delkey
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)
Line 2,254 ⟶ 8,773:
end
end
if node != nothing &&
rebalance(node.parent)
end
end
Line 2,295 ⟶ 8,816:
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 ==
n.right != nothing && print(io, n.right)
end
Line 2,310 ⟶ 8,851:
const tree = AVLTree(Int)
println("Inserting
foreach(x -> insert(tree, x), rand(collect(1:80),
println("Printing tree after insertion: ")
println(tree)
</
<pre>
Inserting
Printing tree after insertion:
<
</pre>
=={{header|Kotlin}}==
{{trans|Java}}
<
private var root: Node? = null
Line 2,497 ⟶ 9,038:
print("Printing balance : ")
tree.printBalance()
}</
{{out}}
Line 2,504 ⟶ 9,045:
Printing key : 1 2 3 4 5 6 7 8 9 10
Printing balance : 0 0 0 1 0 0 0 0 1 0
</pre>
=={{header|Logtalk}}==
The Logtalk library comes with an AVL implementation of its <code>dictionaryp</code> protocol, whose definition begins thusly:
<syntaxhighlight lang="logtalk">
:- object(avltree,
implements(dictionaryp),
extends(term)).
% ... lots of elision ...
:- end_object.
</syntaxhighlight>
{{Out}}
This makes the use of an AVL tree in Logtalk dirt simple. First we load the <code>dictionaries</code> library.
<pre>
?- logtalk_load(dictionaries(loader)).
% ... messages elided ...
true.
</pre>
We can make a new, empty AVL tree.
<pre>
?- avltree::new(Dictionary).
Dictionary = t.
</pre>
Using Logtalk's broadcast notation to avoid having to repeatedly type <code>avltree::</code> 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 (<code>D0</code> through <code>D4</code>) representing the initial empty state, various intermediate states, as well as the final state.
<pre>
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.
</pre>
To save some rote typing, the <code>as_dictionary/2</code> method lets a list of <code>Key-Value</code> pairs be used to initialize a dictionary instead:
<pre>
?- 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.
</pre>
=={{header|Lua}}==
<
AVL.__mt={__index = AVL}
Line 2,639 ⟶ 9,242:
print("\nlist:")
print(unpack(test:toList()))
</syntaxhighlight>
{{out}}
<pre> 20 (0)
Line 2,689 ⟶ 9,292:
1 2 3 4 5 7 8 9 13 14 15 17 20</pre>
=={{header|Nim}}==
{{trans|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.
<syntaxhighlight lang="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)</syntaxhighlight>
{{out}}
<pre>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
]
}
]
}
}</pre>
=={{header|Objeck}}==
{{trans|Java}}
<
@key : Int;
@balance : Int;
Line 2,975 ⟶ 9,848:
}
}
</syntaxhighlight>
{{out}}
Line 2,986 ⟶ 9,859:
{{trans|Java}}
{{incomplete|Objective-C|It is missing an <code>@interface</code> for AVLTree and also missing any <code>@interface</code> or <code>@implementation</code> for AVLTreeNode.}}
<syntaxhighlight lang="objective-c">
@implementation AVLTree
Line 3,182 ⟶ 10,055:
}
</syntaxhighlight>
{{out}}
Line 3,204 ⟶ 10,077:
</pre>
=={{header|
Translated from the C version at http://www.geeksforgeeks.org/avl-tree-set-2-deletion <br>
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)
<!--<syntaxhighlight lang="phix">(phixonline)-->
<span style="color: #008080;">with</span> <span style="color: #008080;">javascript_semantics</span>
<span style="color: #008080;">enum</span> <span style="color: #000000;">KEY</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">0</span><span style="color: #0000FF;">,</span>
<span style="color: #000000;">LEFT</span><span style="color: #0000FF;">,</span>
<span style="color: #000000;">HEIGHT</span><span style="color: #0000FF;">,</span> <span style="color: #000080;font-style:italic;">-- (NB +/-1 gives LEFT or RIGHT)</span>
<span style="color: #000000;">RIGHT</span>
<span style="color: #004080;">sequence</span> <span style="color: #000000;">tree</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{}</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">freelist</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">0</span>
<span style="color: #008080;">function</span> <span style="color: #000000;">newNode</span><span style="color: #0000FF;">(</span><span style="color: #004080;">object</span> <span style="color: #000000;">key</span><span style="color: #0000FF;">)</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">node</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">freelist</span><span style="color: #0000FF;">=</span><span style="color: #000000;">0</span> <span style="color: #008080;">then</span>
<span style="color: #000000;">node</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">length</span><span style="color: #0000FF;">(</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">)+</span><span style="color: #000000;">1</span>
<span style="color: #000000;">tree</span> <span style="color: #0000FF;">&=</span> <span style="color: #0000FF;">{</span><span style="color: #000000;">key</span><span style="color: #0000FF;">,</span><span style="color: #004600;">NULL</span><span style="color: #0000FF;">,</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span><span style="color: #004600;">NULL</span><span style="color: #0000FF;">}</span>
<span style="color: #008080;">else</span>
<span style="color: #000000;">node</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">freelist</span>
<span style="color: #000000;">freelist</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">freelist</span><span style="color: #0000FF;">]</span>
<span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">node</span><span style="color: #0000FF;">+</span><span style="color: #000000;">KEY</span><span style="color: #0000FF;">..</span><span style="color: #000000;">node</span><span style="color: #0000FF;">+</span><span style="color: #000000;">RIGHT</span><span style="color: #0000FF;">]</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{</span><span style="color: #000000;">key</span><span style="color: #0000FF;">,</span><span style="color: #004600;">NULL</span><span style="color: #0000FF;">,</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span><span style="color: #004600;">NULL</span><span style="color: #0000FF;">}</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">return</span> <span style="color: #000000;">node</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
<span style="color: #008080;">function</span> <span style="color: #000000;">height</span><span style="color: #0000FF;">(</span><span style="color: #004080;">integer</span> <span style="color: #000000;">node</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">return</span> <span style="color: #008080;">iff</span><span style="color: #0000FF;">(</span><span style="color: #000000;">node</span><span style="color: #0000FF;">=</span><span style="color: #004600;">NULL</span><span style="color: #0000FF;">?</span><span style="color: #000000;">0</span><span style="color: #0000FF;">:</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">node</span><span style="color: #0000FF;">+</span><span style="color: #000000;">HEIGHT</span><span style="color: #0000FF;">])</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
<span style="color: #008080;">procedure</span> <span style="color: #000000;">setHeight</span><span style="color: #0000FF;">(</span><span style="color: #004080;">integer</span> <span style="color: #000000;">node</span><span style="color: #0000FF;">)</span>
<span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">node</span><span style="color: #0000FF;">+</span><span style="color: #000000;">HEIGHT</span><span style="color: #0000FF;">]</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">max</span><span style="color: #0000FF;">(</span><span style="color: #000000;">height</span><span style="color: #0000FF;">(</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">node</span><span style="color: #0000FF;">+</span><span style="color: #000000;">LEFT</span><span style="color: #0000FF;">]),</span> <span style="color: #000000;">height</span><span style="color: #0000FF;">(</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">node</span><span style="color: #0000FF;">+</span><span style="color: #000000;">RIGHT</span><span style="color: #0000FF;">]))+</span><span style="color: #000000;">1</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">procedure</span>
<span style="color: #008080;">function</span> <span style="color: #000000;">rotate</span><span style="color: #0000FF;">(</span><span style="color: #004080;">integer</span> <span style="color: #000000;">node</span><span style="color: #0000FF;">,</span> <span style="color: #004080;">integer</span> <span style="color: #000000;">direction</span><span style="color: #0000FF;">)</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">idirection</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">LEFT</span><span style="color: #0000FF;">+</span><span style="color: #000000;">RIGHT</span><span style="color: #0000FF;">-</span><span style="color: #000000;">direction</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">pivot</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">node</span><span style="color: #0000FF;">+</span><span style="color: #000000;">idirection</span><span style="color: #0000FF;">]</span>
<span style="color: #0000FF;">{</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">pivot</span><span style="color: #0000FF;">+</span><span style="color: #000000;">direction</span><span style="color: #0000FF;">],</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">node</span><span style="color: #0000FF;">+</span><span style="color: #000000;">idirection</span><span style="color: #0000FF;">]}</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{</span><span style="color: #000000;">node</span><span style="color: #0000FF;">,</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">pivot</span><span style="color: #0000FF;">+</span><span style="color: #000000;">direction</span><span style="color: #0000FF;">]}</span>
<span style="color: #000000;">setHeight</span><span style="color: #0000FF;">(</span><span style="color: #000000;">node</span><span style="color: #0000FF;">)</span>
<span style="color: #000000;">setHeight</span><span style="color: #0000FF;">(</span><span style="color: #000000;">pivot</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">return</span> <span style="color: #000000;">pivot</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
<span style="color: #008080;">function</span> <span style="color: #000000;">getBalance</span><span style="color: #0000FF;">(</span><span style="color: #004080;">integer</span> <span style="color: #000000;">N</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">return</span> <span style="color: #008080;">iff</span><span style="color: #0000FF;">(</span><span style="color: #000000;">N</span><span style="color: #0000FF;">==</span><span style="color: #004600;">NULL</span> <span style="color: #0000FF;">?</span> <span style="color: #000000;">0</span> <span style="color: #0000FF;">:</span> <span style="color: #000000;">height</span><span style="color: #0000FF;">(</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">N</span><span style="color: #0000FF;">+</span><span style="color: #000000;">LEFT</span><span style="color: #0000FF;">])-</span><span style="color: #000000;">height</span><span style="color: #0000FF;">(</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">N</span><span style="color: #0000FF;">+</span><span style="color: #000000;">RIGHT</span><span style="color: #0000FF;">]))</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
<span style="color: #008080;">function</span> <span style="color: #000000;">insertNode</span><span style="color: #0000FF;">(</span><span style="color: #004080;">integer</span> <span style="color: #000000;">node</span><span style="color: #0000FF;">,</span> <span style="color: #004080;">object</span> <span style="color: #000000;">key</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">node</span><span style="color: #0000FF;">==</span><span style="color: #004600;">NULL</span> <span style="color: #008080;">then</span>
<span style="color: #008080;">return</span> <span style="color: #000000;">newNode</span><span style="color: #0000FF;">(</span><span style="color: #000000;">key</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">c</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">compare</span><span style="color: #0000FF;">(</span><span style="color: #000000;">key</span><span style="color: #0000FF;">,</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">node</span><span style="color: #0000FF;">+</span><span style="color: #000000;">KEY</span><span style="color: #0000FF;">])</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">c</span><span style="color: #0000FF;">!=</span><span style="color: #000000;">0</span> <span style="color: #008080;">then</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">direction</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">HEIGHT</span><span style="color: #0000FF;">+</span><span style="color: #000000;">c</span> <span style="color: #000080;font-style:italic;">-- LEFT or RIGHT
-- note this crashes under p2js... (easy to fix, not so easy to find)
-- tree[node+direction] = insertNode(tree[node+direction], key)</span>
<span style="color: #004080;">atom</span> <span style="color: #000000;">tnd</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">insertNode</span><span style="color: #0000FF;">(</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">node</span><span style="color: #0000FF;">+</span><span style="color: #000000;">direction</span><span style="color: #0000FF;">],</span> <span style="color: #000000;">key</span><span style="color: #0000FF;">)</span>
<span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">node</span><span style="color: #0000FF;">+</span><span style="color: #000000;">direction</span><span style="color: #0000FF;">]</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">tnd</span>
<span style="color: #000000;">setHeight</span><span style="color: #0000FF;">(</span><span style="color: #000000;">node</span><span style="color: #0000FF;">)</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">balance</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">trunc</span><span style="color: #0000FF;">(</span><span style="color: #000000;">getBalance</span><span style="color: #0000FF;">(</span><span style="color: #000000;">node</span><span style="color: #0000FF;">)/</span><span style="color: #000000;">2</span><span style="color: #0000FF;">)</span> <span style="color: #000080;font-style:italic;">-- +/-1 (or 0)</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">balance</span> <span style="color: #008080;">then</span>
<span style="color: #000000;">direction</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">HEIGHT</span><span style="color: #0000FF;">-</span><span style="color: #000000;">balance</span> <span style="color: #000080;font-style:italic;">-- LEFT or RIGHT</span>
<span style="color: #000000;">c</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">compare</span><span style="color: #0000FF;">(</span><span style="color: #000000;">key</span><span style="color: #0000FF;">,</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">node</span><span style="color: #0000FF;">+</span><span style="color: #000000;">direction</span><span style="color: #0000FF;">]+</span><span style="color: #000000;">KEY</span><span style="color: #0000FF;">])</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">c</span><span style="color: #0000FF;">=</span><span style="color: #000000;">balance</span> <span style="color: #008080;">then</span>
<span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">node</span><span style="color: #0000FF;">+</span><span style="color: #000000;">direction</span><span style="color: #0000FF;">]</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">rotate</span><span style="color: #0000FF;">(</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">node</span><span style="color: #0000FF;">+</span><span style="color: #000000;">direction</span><span style="color: #0000FF;">],</span><span style="color: #000000;">direction</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">c</span><span style="color: #0000FF;">!=</span><span style="color: #000000;">0</span> <span style="color: #008080;">then</span>
<span style="color: #000000;">node</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">rotate</span><span style="color: #0000FF;">(</span><span style="color: #000000;">node</span><span style="color: #0000FF;">,</span><span style="color: #000000;">LEFT</span><span style="color: #0000FF;">+</span><span style="color: #000000;">RIGHT</span><span style="color: #0000FF;">-</span><span style="color: #000000;">direction</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">return</span> <span style="color: #000000;">node</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
<span style="color: #008080;">function</span> <span style="color: #000000;">minValueNode</span><span style="color: #0000FF;">(</span><span style="color: #004080;">integer</span> <span style="color: #000000;">node</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">while</span> <span style="color: #000000;">1</span> <span style="color: #008080;">do</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">next</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">node</span><span style="color: #0000FF;">+</span><span style="color: #000000;">LEFT</span><span style="color: #0000FF;">]</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">next</span><span style="color: #0000FF;">=</span><span style="color: #004600;">NULL</span> <span style="color: #008080;">then</span> <span style="color: #008080;">exit</span> <span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #000000;">node</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">next</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">while</span>
<span style="color: #008080;">return</span> <span style="color: #000000;">node</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
<span style="color: #008080;">function</span> <span style="color: #000000;">deleteNode</span><span style="color: #0000FF;">(</span><span style="color: #004080;">integer</span> <span style="color: #000000;">root</span><span style="color: #0000FF;">,</span> <span style="color: #004080;">object</span> <span style="color: #000000;">key</span><span style="color: #0000FF;">)</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">c</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">root</span><span style="color: #0000FF;">=</span><span style="color: #004600;">NULL</span> <span style="color: #008080;">then</span> <span style="color: #008080;">return</span> <span style="color: #000000;">root</span> <span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #000000;">c</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">compare</span><span style="color: #0000FF;">(</span><span style="color: #000000;">key</span><span style="color: #0000FF;">,</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">KEY</span><span style="color: #0000FF;">])</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">c</span><span style="color: #0000FF;">=-</span><span style="color: #000000;">1</span> <span style="color: #008080;">then</span>
<span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">LEFT</span><span style="color: #0000FF;">]</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">deleteNode</span><span style="color: #0000FF;">(</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">LEFT</span><span style="color: #0000FF;">],</span> <span style="color: #000000;">key</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">elsif</span> <span style="color: #000000;">c</span><span style="color: #0000FF;">=+</span><span style="color: #000000;">1</span> <span style="color: #008080;">then</span>
<span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">RIGHT</span><span style="color: #0000FF;">]</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">deleteNode</span><span style="color: #0000FF;">(</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">RIGHT</span><span style="color: #0000FF;">],</span> <span style="color: #000000;">key</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">elsif</span> <span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">LEFT</span><span style="color: #0000FF;">]==</span><span style="color: #004600;">NULL</span>
<span style="color: #008080;">or</span> <span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">RIGHT</span><span style="color: #0000FF;">]==</span><span style="color: #004600;">NULL</span> <span style="color: #008080;">then</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">temp</span> <span style="color: #0000FF;">=</span> <span style="color: #008080;">iff</span><span style="color: #0000FF;">(</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">LEFT</span><span style="color: #0000FF;">]</span> <span style="color: #0000FF;">?</span> <span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">LEFT</span><span style="color: #0000FF;">]</span> <span style="color: #0000FF;">:</span> <span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">RIGHT</span><span style="color: #0000FF;">])</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">temp</span><span style="color: #0000FF;">==</span><span style="color: #004600;">NULL</span> <span style="color: #008080;">then</span> <span style="color: #000080;font-style:italic;">-- No child case</span>
<span style="color: #0000FF;">{</span><span style="color: #000000;">temp</span><span style="color: #0000FF;">,</span><span style="color: #000000;">root</span><span style="color: #0000FF;">}</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{</span><span style="color: #000000;">root</span><span style="color: #0000FF;">,</span><span style="color: #004600;">NULL</span><span style="color: #0000FF;">}</span>
<span style="color: #008080;">else</span> <span style="color: #000080;font-style:italic;">-- One child case</span>
<span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">KEY</span><span style="color: #0000FF;">..</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">RIGHT</span><span style="color: #0000FF;">]</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">temp</span><span style="color: #0000FF;">+</span><span style="color: #000000;">KEY</span><span style="color: #0000FF;">..</span><span style="color: #000000;">temp</span><span style="color: #0000FF;">+</span><span style="color: #000000;">RIGHT</span><span style="color: #0000FF;">]</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">temp</span><span style="color: #0000FF;">+</span><span style="color: #000000;">KEY</span><span style="color: #0000FF;">]</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">freelist</span>
<span style="color: #000000;">freelist</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">temp</span>
<span style="color: #008080;">else</span> <span style="color: #000080;font-style:italic;">-- Two child case</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">temp</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">minValueNode</span><span style="color: #0000FF;">(</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">RIGHT</span><span style="color: #0000FF;">])</span>
<span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">KEY</span><span style="color: #0000FF;">]</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">temp</span><span style="color: #0000FF;">+</span><span style="color: #000000;">KEY</span><span style="color: #0000FF;">]</span>
<span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">RIGHT</span><span style="color: #0000FF;">]</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">deleteNode</span><span style="color: #0000FF;">(</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">RIGHT</span><span style="color: #0000FF;">],</span> <span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">temp</span><span style="color: #0000FF;">+</span><span style="color: #000000;">KEY</span><span style="color: #0000FF;">])</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">root</span><span style="color: #0000FF;">=</span><span style="color: #004600;">NULL</span> <span style="color: #008080;">then</span> <span style="color: #008080;">return</span> <span style="color: #000000;">root</span> <span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #000000;">setHeight</span><span style="color: #0000FF;">(</span><span style="color: #000000;">root</span><span style="color: #0000FF;">)</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">balance</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">trunc</span><span style="color: #0000FF;">(</span><span style="color: #000000;">getBalance</span><span style="color: #0000FF;">(</span><span style="color: #000000;">root</span><span style="color: #0000FF;">)/</span><span style="color: #000000;">2</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">balance</span> <span style="color: #008080;">then</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">direction</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">HEIGHT</span><span style="color: #0000FF;">-</span><span style="color: #000000;">balance</span>
<span style="color: #000000;">c</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">compare</span><span style="color: #0000FF;">(</span><span style="color: #000000;">getBalance</span><span style="color: #0000FF;">(</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">direction</span><span style="color: #0000FF;">]),</span><span style="color: #000000;">0</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">c</span><span style="color: #0000FF;">=-</span><span style="color: #000000;">balance</span> <span style="color: #008080;">then</span>
<span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">direction</span><span style="color: #0000FF;">]</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">rotate</span><span style="color: #0000FF;">(</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">root</span><span style="color: #0000FF;">+</span><span style="color: #000000;">direction</span><span style="color: #0000FF;">],</span><span style="color: #000000;">direction</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #000000;">root</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">rotate</span><span style="color: #0000FF;">(</span><span style="color: #000000;">root</span><span style="color: #0000FF;">,</span><span style="color: #000000;">LEFT</span><span style="color: #0000FF;">+</span><span style="color: #000000;">RIGHT</span><span style="color: #0000FF;">-</span><span style="color: #000000;">direction</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">return</span> <span style="color: #000000;">root</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
<span style="color: #008080;">procedure</span> <span style="color: #000000;">inOrder</span><span style="color: #0000FF;">(</span><span style="color: #004080;">integer</span> <span style="color: #000000;">node</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">node</span><span style="color: #0000FF;">!=</span><span style="color: #004600;">NULL</span> <span style="color: #008080;">then</span>
<span style="color: #000000;">inOrder</span><span style="color: #0000FF;">(</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">node</span><span style="color: #0000FF;">+</span><span style="color: #000000;">LEFT</span><span style="color: #0000FF;">])</span>
<span style="color: #7060A8;">printf</span><span style="color: #0000FF;">(</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span> <span style="color: #008000;">"%d "</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">node</span><span style="color: #0000FF;">+</span><span style="color: #000000;">KEY</span><span style="color: #0000FF;">])</span>
<span style="color: #000000;">inOrder</span><span style="color: #0000FF;">(</span><span style="color: #000000;">tree</span><span style="color: #0000FF;">[</span><span style="color: #000000;">node</span><span style="color: #0000FF;">+</span><span style="color: #000000;">RIGHT</span><span style="color: #0000FF;">])</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">procedure</span>
<span style="color: #004080;">integer</span> <span style="color: #000000;">root</span> <span style="color: #0000FF;">=</span> <span style="color: #004600;">NULL</span>
<span style="color: #004080;">sequence</span> <span style="color: #000000;">test</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">shuffle</span><span style="color: #0000FF;">(</span><span style="color: #7060A8;">tagset</span><span style="color: #0000FF;">(</span><span style="color: #000000;">50003</span><span style="color: #0000FF;">))</span>
<span style="color: #008080;">for</span> <span style="color: #000000;">i</span><span style="color: #0000FF;">=</span><span style="color: #000000;">1</span> <span style="color: #008080;">to</span> <span style="color: #7060A8;">length</span><span style="color: #0000FF;">(</span><span style="color: #000000;">test</span><span style="color: #0000FF;">)</span> <span style="color: #008080;">do</span>
<span style="color: #000000;">root</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">insertNode</span><span style="color: #0000FF;">(</span><span style="color: #000000;">root</span><span style="color: #0000FF;">,</span><span style="color: #000000;">test</span><span style="color: #0000FF;">[</span><span style="color: #000000;">i</span><span style="color: #0000FF;">])</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">for</span>
<span style="color: #000000;">test</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">shuffle</span><span style="color: #0000FF;">(</span><span style="color: #7060A8;">tagset</span><span style="color: #0000FF;">(</span><span style="color: #000000;">50000</span><span style="color: #0000FF;">))</span>
<span style="color: #008080;">for</span> <span style="color: #000000;">i</span><span style="color: #0000FF;">=</span><span style="color: #000000;">1</span> <span style="color: #008080;">to</span> <span style="color: #7060A8;">length</span><span style="color: #0000FF;">(</span><span style="color: #000000;">test</span><span style="color: #0000FF;">)</span> <span style="color: #008080;">do</span>
<span style="color: #000000;">root</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">deleteNode</span><span style="color: #0000FF;">(</span><span style="color: #000000;">root</span><span style="color: #0000FF;">,</span><span style="color: #000000;">test</span><span style="color: #0000FF;">[</span><span style="color: #000000;">i</span><span style="color: #0000FF;">])</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">for</span>
<span style="color: #000000;">inOrder</span><span style="color: #0000FF;">(</span><span style="color: #000000;">root</span><span style="color: #0000FF;">)</span>
<!--</syntaxhighlight>-->
{{out}}
<pre>50001 50002 50003</pre>
=={{header|Picat}}==
{{trans|Haskell}}
The function delete is missing.
<syntaxhighlight lang="picat">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).
</syntaxhighlight>
{{out}}
<pre>
nil
1
nil
2
nil
3
nil
4
nil
5
nil
6
nil
7
nil
8
nil
9
nil
10
nil
</pre>
=={{header|Python}}==
This is the source code of Pure Calculus in Python. The code includes:
<ul>
<li>an ordered_set class</li>
<li>an unordered_set class</li>
<li>an array class</li>
<li>a dictionary class</li>
<li>a bag class</li>
<li>a map class</li>
</ul>
<p>The dictionary and array classes includes an AVL bag sort method - which is novel.</p>
<syntaxhighlight lang="python">
# 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)
</syntaxhighlight>
=={{header|Raku}}==
(formerly Perl 6)
This code has been translated from the Java version on
<https://rosettacode.org>. Consequently, it should have the same
Line 3,226 ⟶ 12,122:
like the apostrophe (') and hyphen (-) in identifiers.
<br>
<syntaxhighlight lang="raku" line>
class AVL-Tree {
has $.root is rw = 0;
Line 3,508 ⟶ 12,404:
}
}
</syntaxhighlight>
=={{header|Rust}}==
See [[AVL tree/Rust]].
=={{header|Scala}}==
<
class AVLTree[A](implicit val ordering: Ordering[A]) extends mutable.SortedSet[A] {
Line 4,313 ⟶ 12,736:
}
}</
=={{header|Scheme}}==
{{trans|Fortran}}
See also [[#ATS|ATS]].
{{works with|CHICKEN|5.3.0}}
{{libheader|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.
<syntaxhighlight lang="scheme">(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))</syntaxhighlight>
{{out}}
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.
<pre>$ 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")
----------------------------------------------------------------------</pre>
=={{header|Sidef}}==
{{trans|D}}
<
has root = nil
Line 4,489 ⟶ 13,866:
{|i| tree.insert(i) } << 1..10
print "Printing balance: "
tree.printBalance</
{{out}}
<pre>
Line 4,497 ⟶ 13,874:
=={{header|Simula}}==
<
BEGIN
Line 4,696 ⟶ 14,073:
END REMOVEM;
END.</
A demonstration program:
<
AVL
Line 4,733 ⟶ 14,110:
END;
END.</
{{out}}
<pre>
Line 4,749 ⟶ 14,126:
Note that in general, you would not normally write a tree directly in Tcl when writing code that required an <math>\alpha</math><sup>=</sup><math>\rightarrow\beta</math> 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|8.6}}
<
namespace eval AVL {
Line 4,929 ⟶ 14,306:
}
}
}</
Demonstrating:
<
AVL::Tree create tree
Line 4,950 ⟶ 14,327:
# Destroy the tree and all its nodes
tree destroy</
{{out}}
<pre style="overflow:auto;height:400px">
Line 5,062 ⟶ 14,439:
{{trans|Java}}
For use within a project, consider adding "export default" to AVLtree class declaration.
<
class AVLnode <T> {
balance: number
Line 5,275 ⟶ 14,652:
}
}
</syntaxhighlight>
=={{header|Wren}}==
{{trans|Kotlin}}
<syntaxhighlight lang="wren">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()</syntaxhighlight>
{{out}}
<pre>
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
</pre>
=={{header|Yabasic}}==
<syntaxhighlight lang="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)</syntaxhighlight>
{{out}}
<pre>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---</pre>
{{omit from|MiniZinc|type system is too inexpressive}}
| |||