(module avl mzscheme
	(provide avl
		 avl-introspect
		 avl?
		 avl-from-avl
		 avl-nodes
		 avl-empty?
		 avl-insert!
		 avl-remove!
		 avl+
		 avl-
		 avl-find
		 avl-exists?
		 avl-for-each
		 avl-map
		 avl-filter
		 avl-min
		 avl-max
		 avl-atomic)

;;; Node definition
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;=head1 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 L<http://wikipedia.org/wiki/AVL_tree|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
;;;L<avl tree documentation|#avl_tree_interface> for the
;;;provided AVL Tree functions.
;;;
;;;=head2 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.
;;;
;;;=head2 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.
;;;
;;;=verbatim scm,8
(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)
;;;=verbatim
;;;
;;;=head2 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.
;;;
;;;=verbatim scm,8
(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))))
;;;=verbatim
;;;
;;;The (new-node obj) function will make a new AVL Tree node with
;;;the data part set to obj.
;;;
;;;=verbatim scm,8
(define (new-node data) 
  (vector data 'nil 'nil 1))
;;;=verbatim
;;;
;;;(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.
;;;
;;;=verbatim scm,8
(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))))
;;;=verbatim
;;;
;;;(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.
;;;
;;;=verbatim scm,8
(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)))))
;;;=verbatim
;;;
;;;(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.
;;;
;;;=verbatim scm,8
(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))))
;;;=verbatim
;;;
;;;(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.
;;;
;;;=verbatim scm,8
(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))))
;;;=verbatim
;;;
;;;(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.
;;;
;;;=verbatim scm,8
(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))))
;;;=verbatim
;;;
;;;(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.
;;;
;;;=verbatim scm,8
(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))))
;;;=verbatim
;;;
;;;(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 E<lt> -1 or E<gt> 1.
;;;
;;;=verbatim scm,8
(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))))
;;;=verbatim
;;;
;;;C<(node-min node)> returns the left most node in the avl tree (which will
;;;hold the minimum data). This function is used by C<avl-min>.
;;;
;;;=verbatim scm,8
(define (node-min node)
  (if (eq? (left node) 'nil)
      node
      (node-min (left node))))
;;;=verbatim
;;;
;;;C<(node-max node)> returns the right most node in the avl tree (which will
;;;hold the maximum data). This function is used by C<avl-max>.
;;;
;;;=verbatim scm,8
(define (node-max node)
  (if (eq? (right node) 'nil)
      node
      (node-max (right node))))
;;;=verbatim
;;;
;;;=head2 AVL Tree Wrapper Supportive Macros
;;;
;;;These macros provide access to the AVL Tree data structure, and
;;;implement thread safety, using a monitor section.
;;;
;;;=verbatim scm,8
(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)))))
;;;=verbatim
;;;
;;;=cut
;;;
;;; AVL implementation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;=head2 Avl Tree Interface
;;;
;;;=head3 C<(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.
;;;
;;;=verbatim scm,8
(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))
;;;=verbatim
;;;
;;;=head3 C<(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.
;;;
;;;=verbatim scm,8
(define (avl-from-avl troot)
  (avl (is-equal troot) (is-less troot)))
;;;=verbatim
;;;
;;;=head3 C<(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?'.
;;;
;;;=verbatim scm,8
(define (avl? obj)
  (%avl? obj))

;;;=verbatim
;;;
;;;=head3 C<(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.
;;;
;;;=verbatim scm,8
(define (avl-insert! avl obj)
  (protect avl
	   (begin
	     (root! avl (insert-node (is-less avl) (root avl) obj))
	     (nodes! avl (+ (nodes avl) 1))
	     avl)))
;;;=verbatim
;;;
;;;=head3 C<(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.
;;;
;;;=verbatim scm,8
(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)))))))
;;;=verbatim
;;;
;;;=head3 C<(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!.
;;;
;;;=verbatim scm,8
(define-syntax avl+
  (syntax-rules ()
    ((_ avl obj)
     (avl-insert! avl obj))))

(define-syntax avl-
  (syntax-rules ()
    ((_ avl obj)
     (avl-remove! avl obj))))
;;;=verbatim
;;;
;;;=head3 C<(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: C<(avl-find avl obj (lambda () #f))>.
;;;
;;;=verbatim scm,8
(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)))))
;;;=verbatim
;;;
;;;=head3 C<(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.
;;;
;;;=verbatim scm,8
(define (avl-exists? avl obj)
  (let ((found #t))
    (avl-find avl obj (lambda () (set! found #f) #f))
    found))
;;;=verbatim
;;;
;;;=head3 C<(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.: C<(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).
;;;
;;;=verbatim scm,8
(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)))
;;;=verbatim
;;;
;;;=head3 C<(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).
;;;
;;;=verbatim scm,8
(define (avl-for-each avl function)
  (protect avl
	   (begin
	     (node-for-each 0 (root avl) function)
	     avl)))
;;;=verbatim
;;;
;;;=head3 C<(avl-filter avl function) : new avl-tree>
;;;
;;;Constructs a new avl tree from C<avl>, inserting all nodes of C<avl> for which
;;;C<function>, which is a function that takes the data and level of each node
;;;as arguments, returns #t. The result of C<function> must be of type boolean.
;;;
;;;Example: C<(avl-filter avl (lambda (obj level) (E<gt> obj 0)))> filters out all
;;;nodes for which C<data> has a value E<gt> 0.
;;;
;;;=verbatim scm,8
(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)))
;;;=verbatim
;;;
;;;=head3 C<(avl-nodes avl) : number>
;;;
;;;Returns the number of nodes in avl.
;;;
;;;=verbatim scm,8
(define (avl-nodes avl)
  (nodes avl))
;;;=verbatim
;;;
;;;=head3 C<(avl-empty? avl) : boolean>
;;;
;;;Returns #t, if the avl tree has no nodes; #f otherwise.
;;;
;;;=verbatim scm,8
(define (avl-empty? avl)
  (= (nodes avl) 0))
;;;=verbatim
;;;
;;;=head3 C<(avl-min avl) : data>
;;;
;;;Will return the minimum data in the avl tree C<avl>, or
;;;C<'avl-no-nodes>, if C<(avl-nodes avl)> equals 0.
;;;
;;;=verbatim scm,8
(define (avl-min troot)
  (protect troot
	   (if (= (avl-nodes troot) 0)
	       'avl-no-nodes
	       (data (node-min (root troot))))))
;;;=verbatim
;;;
;;;=head3 C<(avl-max avl) : data>
;;;
;;;Will return the maximum data in the avl tree C<avl>, or
;;;C<'avl-no-nodes>, if C<(avl-nodes avl)> equals 0.
;;;
;;;=verbatim scm,8
(define (avl-max troot)
  (protect troot
	   (if (= (avl-nodes troot) 0)
	       'avl-no-nodes
	       (data (node-max (root troot))))))
;;;=verbatim
;;;
;;;=head3 C<(avl-atomic avl function) : <result of function>>
;;;
;;;This function will call C<function> with C<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:
;;;
;;;=verbatim scm,8
(define (avl-atomic avl func)
  (protect avl
	   (func avl)))
;;;=verbatim
;;;
;;;=head2 Info
;;;
;;;S<C<Author(s):>> Hans Oesterholt (hansatelementalprogrammingdotorgextension).E<lb>
;;;S<C<Copyright:>> (c) 2005.E<lb>
;;;S<C<License  :>> L<Elemental Programming License|http://www.elemental-programming.org/epwiki/ep_license.html>.E<lb>
;;;S<C<File     :>> avl.scm $Revision: 1.3 $
;;;
;;;=cut
)