AVL Trees
This module provides a thread safe implementation of AVL Trees. AVL Trees are binary trees that have the nice property that they are kept balanced. Actually, unlike normal binary trees, all insert, delete and find operations on AVL Trees are guarantied O(log n). See http://wikipedia.org/wiki/AVL_tree for more information on AVL Trees.
This implementation has been derived from a C++ implementation of William A. McKee (google: avl tree algorithm McKee will get you to his homepage).
It starts out with an avl algorithm implementation on the tree nodes, after which the algorithm on the nodes is wrapped as a whole avl tree. Refer to the avl tree documentation for the provided AVL Tree functions.
On thread safety
Although the basic operations on avl trees are thread safe, if multiple avl trees are combined into one operation, e.g. an avl-map function, thread safety will not be guaranteed for all trees.
Thread safety for one tree is provided using a recursion enabled critical section.
Supportive macros
These macros provide access to the avl tree node datastructure. The 'get-set' macro defines a getter and a setter macro on a vector. All getters and setters are defined using this get-set macro.
(define-syntax get-set
(syntax-rules ()
((_ name-get name-set index)
(begin
(define-syntax name-get
(syntax-rules ()
((name-get avl-node)
(vector-ref avl-node index))))
(define-syntax name-set
(syntax-rules ()
((name-set avl-node value)
(begin
(vector-set! avl-node index value)
avl-node))))))
((_ name-get name-set index get-vector-from-struct)
(begin
(define-syntax name-get
(syntax-rules ()
((name-get avl-node)
(vector-ref (get-vector-from-struct avl-node) index))))
(define-syntax name-set
(syntax-rules ()
((name-set avl-node value)
(begin
(vector-set! (get-vector-from-struct avl-node) index value)
avl-node))))))
))
(get-set data data! 0)
(get-set left left! 1)
(get-set right right! 2)
(get-set height height! 3)
AVL Node Implementation
The AVL Tree Node implementation is not hard to understand. AVL Trees are being balanced by keeping a balance factor in each node. A node with balance factor -1, 0 or 1 is considered balanced. All other (integer) values will make the node unbalanced. In this implementation, the balance factor is the 'height' factor.
Compute height, computes this factor for a node.
(define (compute-height node)
(let ((h 0))
(if (not (eq? (left node) 'nil))
(if (> (height (left node)) h)
(set! h (height (left node)))))
(if (not (eq? (right node) 'nil))
(if (> (height (right node)) h)
(set! h (height (right node)))))
(height! node (+ h 1))))
The (new-node obj) function will make a new AVL Tree node with the data part set to obj.
(define (new-node data) (vector data 'nil 'nil 1))
(insert-node is-less? node ndata) is used to insert a new node in the tree. It will use the 'is-less?' function to determine the right order in the tree. Insert-node will traverse the tree and insert a new node at the point in the tree that puts the ndata argument in the right order of the tree. After inserting the new node, the tree is rebalanced.
(define (insert-node is-less? node ndata)
(if (eq? node 'nil)
(new-node ndata)
(begin
(if (is-less? ndata (data node))
(left! node (insert-node is-less? (left node) ndata))
(right! node (insert-node is-less? (right node) ndata)))
(balance node))))
(find-node is-equal? is-less? node fdata) finds fdata in the tree. It will use the 'is-less?' and the 'is-equal?' functions to determine how to traverse the tree and to determine the data of a node equals the given fdata.
(define (find-node is-equal? is-less? node fdata)
(if (eq? node 'nil)
'nil
(if (is-equal? fdata (data node))
node
(if (is-less? fdata (data node))
(find-node is-equal? is-less? (left node) fdata)
(find-node is-equal? is-less? (right node) fdata)))))
(remove-node is-equal? is-less? node rdata) recursively locates the node to be removed in the avl tree, removes the node (using move-down-righthand-side) and rebalances the tree as needed all the way back up the recursion.
(define (remove-node is-equal? is-less? node rdata decreaser)
(if (eq? node 'nil)
'nil
(if (is-equal? rdata (data node))
(begin
(decreaser)
(move-down-righthand-side (left node) (right node)))
(begin
(if (is-less? rdata (data node))
(left! node (remove-node is-equal? is-less? (left node) rdata decreaser))
(right! node (remove-node is-equal? is-less? (right node) rdata decreaser)))
(balance node)))))
(define (move-down-righthand-side node rhs)
(if (eq? node 'nil)
rhs
(begin
(right! node (move-down-righthand-side (right node) rhs))
(balance node))))
(node-for-each level node function) works in ascending order through the whole tree and calls function with the data of each node and the level of the node in the tree. Nothing is done with the result of the function. node-for-each is all about side effects.
(define (node-for-each level node function)
(if (eq? node 'nil)
'nil
(begin
(node-for-each (+ level 1) (left node) function)
(function (data node) level)
(node-for-each (+ level 1) (right node) function))))
(node-map level newroot node function) works in ascending order through the whole avl tree and calls function with the data of each node and the level of the node int the tree. The result of the function is inserted into newroot.
(define (node-map level newroot node function)
(if (eq? node 'nil)
'nil
(begin
(node-map (+ level 1) newroot (left node) function)
(avl-insert! newroot (function (data node) level))
(node-map (+ level 1) newroot (right node) function))))
(node-filter level newroot node function) works in ascending order through the whole avl tree and calls function with the data and the level of each node. The function is expected to be a boolean function. If function returns #t, the current node is inserted into newroot, otherwise not.
(define (node-filter level newroot node function)
(if (eq? node 'nil)
'nil
(begin
(node-filter (+ level 1) newroot (left node) function)
(if (function (data node) level)
(avl-insert! newroot (data node)))
(node-filter (+ level 1) newroot (right node) function))))
(balance node) rebalances a subtree, by rotating nodes. It does this only, if the difference-in-height between the left hand side and the right hand side of a node is < -1 or > 1.
(define (balance node)
(define (exchange-left node parent)
(right! parent (left node))
(left! node (balance parent))
(balance node))
(define (exchange-right node parent)
(left! parent (right node))
(right! node (balance parent))
(balance node))
(define (rotate-left node)
(exchange-left (right node) node))
(define (rotate-right node)
(exchange-right (left node) node))
(define (difference-in-height node)
(let ((lh (if (eq? (left node) 'nil) 0 (height (left node))))
(rh (if (eq? (right node) 'nil) 0 (height (right node)))))
(- lh rh)))
(let ((d (difference-in-height node)))
(if (or (< d -1) (> d 1))
(if (< d 0)
(begin
(if (> (difference-in-height (right node)) 0)
(right! node (rotate-right (right node))))
(rotate-left node))
(begin
(if (< (difference-in-height (left node)) 0)
(left! node (rotate-left (left node))))
(rotate-right node)))
(begin
(compute-height node)
node))))
(node-min node) returns the left most node in the avl tree (which will
hold the minimum data). This function is used by avl-min.
(define (node-min node)
(if (eq? (left node) 'nil)
node
(node-min (left node))))
(node-max node) returns the right most node in the avl tree (which will
hold the maximum data). This function is used by avl-max.
(define (node-max node)
(if (eq? (right node) 'nil)
node
(node-max (right node))))
AVL Tree Wrapper Supportive Macros
These macros provide access to the AVL Tree data structure, and implement thread safety, using a monitor section.
(define-struct %avl (vect))
(get-set is-equal is-equal! 2 %avl-vect)
(get-set is-less is-less! 3 %avl-vect)
(get-set root root! 1 %avl-vect)
(get-set nodes nodes! 4 %avl-vect)
(get-set sem sem! 5 %avl-vect)
(get-set me me! 6 %avl-vect)
(define-syntax protect
(syntax-rules ()
((_ %avl body)
(let ((sem-set
; Conditional semaphore locking,
; to provide recursive protection
(if (not (eq? (me %avl) (current-thread)))
(begin
(semaphore-wait (sem %avl))
(me! %avl (current-thread))
#t)
#f)))
(let ((result body))
(if sem-set
(begin
(me! %avl 'me-done)
(semaphore-post (sem %avl))))
result)))))
Avl Tree Interface
(avl is-equal? is-less?) : avl-tree
Given a function 'is-equal?' that determines if two objects in an avl tree are equal, and a function 'is-less' that determines wheter one object is 'less than' an other object, a new avl-tree is created with the 'avl' function.
(define (avl is-equal? is-less?) (make-%avl (vector 'avl 'nil is-equal? is-less? 0 (make-semaphore 1) 'me))) (define (avl-introspect avl) (%avl-vect avl))
(avl-from-avl avl-tree-donator) : avl-tree
The 'avl-from-avl' function creates a new avl-tree from a given avl tree, which 'donates' the 'is-equal?' and 'is-less?' functions.
(define (avl-from-avl troot) (avl (is-equal troot) (is-less troot)))
(avl? obj) : boolean
Returns #t, if obj is an avl-tree; #f, otherwise. Note! all objects that the predicate 'avl?' is true for, will also have predicate 'vector?'.
(define (avl? obj) (%avl? obj))
(avl-insert! avl obj) : avl-tree
Inserts obj in avl by calling insert-node. Returns avl. This is not a functional approach, as the avl tree is updated in place.
(define (avl-insert! avl obj)
(protect avl
(begin
(root! avl (insert-node (is-less avl) (root avl) obj))
(nodes! avl (+ (nodes avl) 1))
avl)))
(avl-remove! avl obj) : avl-tree
Removes obj from avl (if obj exists in avl). Returns avl. This is not a functional approach, as the avl tree is updated in place.
(define (avl-remove! avl obj)
(protect avl
(root! avl (remove-node (is-equal avl)
(is-less avl)
(root avl)
obj
(lambda () (nodes! avl (- (nodes avl) 1)))))))
(avl+ avl obj) : avl-tree, (avl- avl obj) : avl-tree
avl+ and avl- are macros that wrap the avl-insert! and avl-remove! functions. avl+ wraps avl-insert!. avl- wraps avl-remove!.
(define-syntax avl+
(syntax-rules ()
((_ avl obj)
(avl-insert! avl obj))))
(define-syntax avl-
(syntax-rules ()
((_ avl obj)
(avl-remove! avl obj))))
(avl-find avl obj not-found-func) : obj | result of not-found-func
avl-find looks up obj in avl by calling find-node. If no node containing obj is found, not-founc-func, which must be a function with no arguments, is called. Either (data node) is returned, or the result of not-found-func.
Example of use: (avl-find avl obj (lambda () #f)).
(define (avl-find avl obj not-found-func)
(protect avl
(let ((r (find-node (is-equal avl) (is-less avl) (root avl) obj)))
(if (eq? r 'nil)
(not-found-func)
(data r)))))
(avl-exists? avl obj) : boolean
Checks wheter obj exists in avl. Returns #t, if so, returns #f, otherwise. Be carefull, when using this function on an avl tree in a threaded environment. The result of this function may not be valid anymore because an other thread may have inserted or removed an object from the tree.
(define (avl-exists? avl obj)
(let ((found #t))
(avl-find avl obj (lambda () (set! found #f) #f))
found))
(avl-map avl function . is-equal-and-is-less) : new avl-tree
Constructs a new avl tree from avl mapping function on the data and the
level in the tree of each node (in ascending order). (i.e., ascending order
in terms of the is-less? function). Function is a function that takes
two arguments: data and level, e.g.: (avl-map avl (lambda (obj level) (+ obj level))).
If is-equal-and-is-less is the empty list, the new avl tree will be constructed from avl. Otherwise, a new avl tree will be constructed, with is-equal? as (car is-equal-and-is-less) and is-less? as (cadr is-equal-and-is-less).
(define (avl-map troot function . iseq-isless)
(protect troot
(let ((newroot (avl (if (null? iseq-isless)
(is-equal troot)
(car iseq-isless))
(if (null? iseq-isless)
(is-less troot)
(cadr iseq-isless)))))
(node-map 0 newroot (root troot) function)
newroot)))
(avl-for-each avl function) : avl-tree
Calls function for each node of avl. Function is a function that takes the data and the level of a node as arguments (see avl-map).
(define (avl-for-each avl function)
(protect avl
(begin
(node-for-each 0 (root avl) function)
avl)))
(avl-filter avl function) : new avl-tree
Constructs a new avl tree from avl, inserting all nodes of avl for which
function, which is a function that takes the data and level of each node
as arguments, returns #t. The result of function must be of type boolean.
Example: (avl-filter avl (lambda (obj level) (> obj 0))) filters out all
nodes for which data has a value > 0.
(define (avl-filter troot filter-function-boolean)
(protect troot
(let ((newroot (avl (is-equal troot) (is-less troot))))
(node-filter 0 newroot (root troot) filter-function-boolean)
newroot)))
(avl-nodes avl) : number
Returns the number of nodes in avl.
(define (avl-nodes avl) (nodes avl))
(avl-empty? avl) : boolean
Returns #t, if the avl tree has no nodes; #f otherwise.
(define (avl-empty? avl) (= (nodes avl) 0))
(avl-min avl) : data
Will return the minimum data in the avl tree avl, or
'avl-no-nodes, if (avl-nodes avl) equals 0.
(define (avl-min troot)
(protect troot
(if (= (avl-nodes troot) 0)
'avl-no-nodes
(data (node-min (root troot))))))
(avl-max avl) : data
Will return the maximum data in the avl tree avl, or
'avl-no-nodes, if (avl-nodes avl) equals 0.
(define (avl-max troot)
(protect troot
(if (= (avl-nodes troot) 0)
'avl-no-nodes
(data (node-max (root troot))))))
(avl-atomic avl function) : <result of function>
This function will call function with avl in a critical section,
i.e., make the function call atomic.
Example of use:
(avl-atomic avl (lambda (avl)
(if (avl-empty? avl)
#f
(begin
(avl-remove! avl (avl-min avl))
#t))))
Implementation:
(define (avl-atomic avl func)
(protect avl
(func avl)))
Info
Author(s): Hans Oesterholt (hansatelementalprogrammingdotorgextension).
Copyright: (c) 2005.
License : Elemental Programming License.
File : avl.scm $Revision: 1.3 $