Programmer 7500

home *** CD-ROM | disk | FTP | other *** search

/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / FUZZY.ZIP / AVL.B next >

Wrap

Text File | 1986-11-30 | 15.2 KB | 502 lines

------------------------------------------------------------------------------- -- -- -- Library Unit: AVL -- Generic AVL tree package -- -- -- -- Author: Bradley L. Richards -- -- -- -- Version Date Notes . . . -- -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- -- 1.0 12 Mar 86 Initial Version (delete & update not done) -- -- 1.1 19 Aug 86 Added update and release procedures -- -- 1.2 7 Sep 86 Added delete procedure; cleaned up code -- -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- -- -- -- Library units used: none -- -- -- -- Description: This package provides generic functions for creating, -- -- modifying, and accessing AVL trees. AVL trees are binary trees -- -- which never have more than one level of imbalance between any -- -- two subtrees. Balance is maintained automatically when the tree -- -- is being built. -- -- The data to be maintained in the tree is never actually passed -- -- to this package. Rather, pointers to the data are passed in, via -- -- type "node_ptr." Also, comparison functions on the key fields of -- -- the data must be provided. The package requires a less-than and an -- -- equality test. -- -- -- ------------------------------------------------------------------------------- package body avl is procedure add_node( tree : in out tree_ptr; data : in node_ptr; duplicate : out boolean) is needs_balanced : boolean; pivot_parent, pivot, pivot_child, pivot_grandchild : tree_ptr := null; procedure insert_node( tree : in out tree_ptr; data : in node_ptr; duplicate, needs_balanced : out boolean; pivot_parent, pivot, pivot_child, pivot_grandchild : out tree_ptr ) is found, pivot_found, placed : boolean := false; ptr_child, ptr_grandchild : tree_ptr := null; ptr : tree_ptr := tree; begin if tree = null then -- no nodes in tree tree := new tree_node'(same, null, null, null, data); duplicate := false; needs_balanced := false; else -- must search tree loop if equal(data, ptr.data) then found := true; elsif less_than(data, ptr.data) then if ptr.left_child = null then ptr.left_child := new tree_node'(same,null,null,ptr,data); ptr_child := ptr.left_child; placed := true; else ptr := ptr.left_child; end if; else if ptr.right_child = null then ptr.right_child := new tree_node'(same,null,null,ptr,data); ptr_child := ptr.right_child; placed := true; else ptr := ptr.right_child; end if; end if; exit when found or placed; end loop; if found then duplicate := true; else -- trace back through the tree adjusting balances duplicate := false; loop case ptr.balance is when left => if ptr_child = ptr.left_child then ptr.balance := tall_left; else ptr.balance := same; end if; pivot_found := true; when same => if ptr_child = ptr.left_child then ptr.balance := left; else ptr.balance := right; end if; ptr_grandchild := ptr_child; ptr_child := ptr; ptr := ptr.parent; when right => if ptr_child = ptr.left_child then ptr.balance := same; else ptr.balance := tall_right; end if; pivot_found := true; when others => -- some sort of major tree construction -- error has occurred raise avl_error; end case; exit when pivot_found or (ptr = null); end loop; needs_balanced := false; if pivot_found then if (ptr.balance = tall_left) or (ptr.balance = tall_right) then needs_balanced := true; pivot_parent := ptr.parent; pivot := ptr; pivot_child := ptr_child; pivot_grandchild := ptr_grandchild; end if; end if; end if; end if; end insert_node; begin -- add node -- -- insert_node places the node into the tree, adjusts all -- required balances, and determines whether or not the -- tree needs balanced. If it does, pivot points to the -- pivot node for the rotation(s) -- insert_node(tree, data, duplicate, needs_balanced, pivot_parent, pivot, pivot_child, pivot_grandchild); if needs_balanced then if needs_single_rotation(pivot_parent, pivot, pivot_child, pivot_grandchild) then rotate_singly(pivot_parent, pivot, pivot_child); else rotate_doubly(pivot_parent, pivot, pivot_child, pivot_grandchild); end if; if pivot_parent = null then -- pivot points to new root node tree := pivot; end if; end if; end add_node; function copy_tree( original : tree_ptr ) return tree_ptr is root : tree_ptr; begin if original = null then return null; else root := new tree_node; root.balance := original.balance; root.data := original.data; root.left_child := copy_tree(original.left_child); root.right_child := copy_tree(original.right_child); end if; end copy_tree; -- -- Delete_node -- This routine, when implemented, will remove the matching -- node from the AVL structure and automatically rebalance -- the tree. It should also allow an option to deallocate -- the data. -- procedure delete_node( tree : in out tree_ptr; data : in node_ptr; not_found : out boolean) is duplicate : boolean; new_tree, parent, ptr : tree_ptr; -- -- Merge merges two trees together. The right tree is assumed to be -- either the smaller tree (for efficiency) or perhaps an invalid -- AVL tree. -- procedure merge( t1, t2 : tree_ptr; new_tree : out tree_ptr ) is tree : tree_ptr := t1; -- t1 is the working AVL tree ptr : tree_ptr := t2; parent : tree_ptr; begin if tree /= null then tree.parent := null; end if; if ptr /= null then ptr.parent := null; end if; while ptr /= null loop if ptr.left_child /= null then ptr := ptr.left_child; elsif ptr.right_child /= null then ptr := ptr.right_child; else -- both children null add_node(tree, ptr.data, duplicate); if duplicate then raise avl_error; end if; parent := ptr.parent; if parent /= null then if parent.left_child = ptr then free_AVL(parent.left_child); else free_AVL(parent.right_child); end if; else free_AVL(ptr); end if; ptr := parent; end if; end loop; new_tree := tree; end merge; begin -- delete_node if tree = null then not_found := true; else ptr := fetch_node(tree, data); if ptr = null then not_found := true; else if ptr.balance = right then -- list taller tree first merge(ptr.right_child, ptr.left_child, new_tree); else merge(ptr.left_child, ptr.right_child, new_tree); end if; parent := ptr.parent; if parent /= null then -- didn't delete the root node if parent.left_child = ptr then parent.left_child := null; else parent.right_child := null; end if; merge(new_tree, tree, new_tree); end if; free_AVL(ptr); tree := new_tree; end if; end if; end delete_node; -- -- Fetch_node -- This function returns a pointer to the data associated -- with the AVL node which matches the input data key field. -- function fetch_node( tree : tree_ptr; data : node_ptr) return node_ptr is node : tree_ptr; begin node := fetch_node(tree, data); if node = null then return null; else return node.data; end if; end fetch_node; function fetch_node( tree : tree_ptr; data : node_ptr) return tree_ptr is ptr : tree_ptr := tree; begin if tree = null then return null; else loop if equal(data, ptr.data) then return ptr; elsif less_than(data, ptr.data) then if ptr.left_child = null then return null; else ptr := ptr.left_child; end if; else if ptr.right_child = null then return null; else ptr := ptr.right_child; end if; end if; end loop; end if; end fetch_node; function init_tree return tree_ptr is begin return null; end init_tree; function needs_single_rotation(p1, p2, p3, p4 : in tree_ptr) return boolean is begin if p4 /= null then if ( (p3.balance = left) and (p2.balance = tall_right) ) or ( (p3.balance = right) and (p2.balance = tall_left) ) then return false; -- requires double rotation else return true; end if; else -- we shouldn't have been called raise avl_error; end if; end needs_single_rotation; --procedure print_tree( tree : tree_ptr ) is -- debug --procedure print_node( node : tree_ptr; indent : natural ) is --procedure space( num : natural ) is --begin --for i in 1..num loop --put(' '); --end loop; --end space; --begin --space(indent); --if node = null then --put_line("<null>"); --else --put_data(node.data); --put(" "); --put(node.balance); --if (node.left_child /= null) and then --(node.left_child.parent /= node) then --put(" left child parent discrepancy"); --end if; --if (node.right_child /= null) and then --(node.right_child.parent /= node) then --put(" right child parent discrepancy"); --end if; --new_line; --print_node(node.left_child, indent+2); --print_node(node.right_child, indent+2); --end if; --end print_node; --begin --if (tree /= null) and then (tree.parent /= null) then --put_line("tree parent discrepancy"); --end if; --print_node(tree, 0); --end print_tree; -- -- Release -- This routine releases all nodes in an AVL tree. It does -- not release the data associated with the nodes. For cases -- where the AVL structure was just a temporary way of -- structuring the data this is fine, but eventually the -- release procedure should allow an option to release data -- associated with AVL nodes. This will require another -- generic procedure parameter to the package. -- procedure release( tree : in out tree_ptr ) is begin if tree /= null then if tree.left_child /= null then release( tree.left_child ); end if; if tree.right_child /= null then release( tree.right_child ); end if; free_AVL(tree); end if; end release; procedure rotate_doubly(p1, p2, p3, p4 : in out tree_ptr) is begin if p2.balance = tall_left then p2.left_child := p4.right_child; if p4.right_child /= null then p4.right_child.parent := p2; end if; p3.right_child := p4.left_child; if p4.left_child /= null then p4.left_child.parent := p3; end if; p4.left_child := p3; p4.right_child := p2; case p4.balance is when left => p2.balance := right; p3.balance := same; when same => p2.balance := same; p3.balance := same; when right => p2.balance := same; p3.balance := left; when others => raise avl_error; end case; else p2.right_child := p4.left_child; if p4.left_child /= null then p4.left_child.parent := p2; end if; p3.left_child := p4.right_child; if p4.right_child /= null then p4.right_child.parent := p3; end if; p4.left_child := p2; p4.right_child := p3; case p4.balance is when left => p3.balance := right; p2.balance := same; when same => p3.balance := same; p2.balance := same; when right => p3.balance := same; p2.balance := left; when others => raise avl_error; end case; end if; p4.parent := p1; p4.balance := same; p2.parent := p4; p3.parent := p4; if p1 = null then p2 := p4; -- we've changed the root elsif p1.left_child = p2 then p1.left_child := p4; else p1.right_child := p4; end if; end rotate_doubly; procedure rotate_singly(p1, p2, p3 : in out tree_ptr) is begin if p2.balance = tall_left then p2.left_child := p3.right_child; if p3.right_child /= null then p3.right_child.parent := p2; end if; p3.right_child := p2; if p3.balance = left then p2.balance := same; else p2.balance := left; end if; else p2.right_child := p3.left_child; if p3.left_child /= null then p3.left_child.parent := p2; end if; p3.left_child := p2; if p3.balance = right then p2.balance := same; else p2.balance := right; end if; end if; p2.parent := p3; p3.balance := same; p3.parent := p1; if p1 = null then p2 := p3; -- we've changed the root elsif p1.left_child = p2 then p1.left_child := p3; else p1.right_child := p3; end if; end rotate_singly; -- -- Update_node -- This routine locates the node whose key field matches -- the data and replaces the node data witht the new data -- included in this call. If no matching node is found -- not_found will be true. -- -- This routine should be modified to optionally release -- the old data. -- procedure update_node( tree : in tree_ptr; data : in node_ptr; not_found : out boolean ) is ptr : tree_ptr := tree; begin if tree = null then not_found := true; else loop if equal(data, ptr.data) then not_found := false; ptr.data := data; exit; elsif less_than(data, ptr.data) then if ptr.left_child = null then not_found := true; exit; else ptr := ptr.left_child; end if; else if ptr.right_child = null then not_found := true; exit; else ptr := ptr.right_child; end if; end if; end loop; end if; end update_node; end avl;