File : bc-containers-trees-avl.adb
-- Copyright (C) 1994-1999 Grady Booch, David Weller and Simon Wright.
-- All Rights Reserved.
--
-- This program is free software; you can redistribute it
-- and/or modify it under the terms of the Ada Community
-- License which comes with this Library.
--
-- This program is distributed in the hope that it will be
-- useful, but WITHOUT ANY WARRANTY; without even the implied
-- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-- PURPOSE. See the Ada Community License for more details.
-- You should have received a copy of the Ada Community
-- License with this library, in the file named "Ada Community
-- License" or "ACL". If not, contact the author of this library
-- for a copy.
--
-- $Id: bc-containers-trees-avl.adb,v 1.3.2.3 1999/12/31 15:13:59 simon Exp $
package body BC.Containers.Trees.AVL is
-- Supporting subprograms
procedure Purge (Node : in out Nodes.AVL_Node_Ref) is
use type Nodes.AVL_Node_Ref;
begin
if Node /= null then
Purge (Node.Left);
Purge (Node.Right);
Nodes.Delete (Node);
end if;
end Purge;
procedure Search_Insert (T : in out AVL_Tree;
Element : Item;
Node : in out Nodes.AVL_Node_Ref;
Increased : in out Boolean;
Inserted : out Boolean) is
P1, P2 : Nodes.AVL_Node_Ref;
use type Nodes.AVL_Node_Ref;
use type Nodes.Node_Balance;
begin
Inserted := True;
if Node = null then
Node := new Nodes.AVL_Node'(Element => Element,
Left => null,
Right => null,
Balance => Nodes.Middle);
Increased := True;
elsif Element < Node.Element then
Search_Insert (T, Element, Node.Left, Increased, Inserted);
if Increased then
case Node.Balance is
when Nodes.Right =>
Node.Balance := Nodes.Middle;
Increased := False;
when Nodes.Middle =>
Node.Balance := Nodes.Left;
when Nodes.Left =>
P1 := Node.Left;
if P1.Balance = Nodes.Left then
Node.Left := P1.Right;
P1.Right := Node;
Node.Balance := Nodes.Middle;
Node := P1;
else
P2 := P1.Right;
P1.Right := P2.Left;
P2.Left := P1;
Node.Left := P2.Right;
P2.Right := Node;
if P2.Balance = Nodes.Left then
Node.Balance := Nodes.Right;
else
Node.Balance := Nodes.Middle;
end if;
if P2.Balance = Nodes.Right then
P1.Balance := Nodes.Left;
else
P1.Balance := Nodes.Middle;
end if;
Node := P2;
end if;
Node.Balance := Nodes.Middle;
Increased := False;
end case;
end if;
elsif Node.Element < Element then
Search_Insert (T, Element, Node.Right, Increased, Inserted);
if Increased then
case Node.Balance is
when Nodes.Left =>
Node.Balance := Nodes.Middle;
Increased := False;
when Nodes.Middle =>
Node.Balance := Nodes.Right;
when Nodes.Right =>
P1 := Node.Right;
if P1.Balance = Nodes.Right then
Node.Right := P1.Left;
P1.Left := Node;
Node.Balance := Nodes.Middle;
Node := P1;
else
P2 := P1.Left;
P1.Left := P2.Right;
P2.Right := P1;
Node.Right := P2.Left;
P2.Left := Node;
if P2.Balance = Nodes.Right then
Node.Balance := Nodes.Left;
else
Node.Balance := Nodes.Middle;
end if;
if P2.Balance = Nodes.Left then
P1.Balance := Nodes.Right;
else
P1.Balance := Nodes.Middle;
end if;
Node := P2;
end if;
Node.Balance := Nodes.Middle;
Increased := False;
end case;
end if;
else
Inserted := False;
end if;
end Search_Insert;
procedure Balance_Left (Node : in out Nodes.AVL_Node_Ref;
Decreased : in out Boolean) is
P1, P2 : Nodes.AVL_Node_Ref;
Balance1, Balance2 : Nodes.Node_Balance;
use type Nodes.Node_Balance;
begin
case Node.Balance is
when Nodes.Left =>
Node.Balance := Nodes.Middle;
when Nodes.Middle =>
Node.Balance := Nodes.Right;
Decreased := False;
when Nodes.Right =>
P1 := Node.Right;
Balance1 := P1.Balance;
if Balance1 >= Nodes.Middle then
Node.Right := P1.Left;
P1.Left := Node;
if Balance1 = Nodes.Middle then
Node.Balance := Nodes.Right;
P1.Balance := Nodes.Left;
Decreased := False;
else
Node.Balance := Nodes.Middle;
P1.Balance := Nodes.Middle;
end if;
Node := P1;
else
P2 := P1.Left;
Balance2 := P2.Balance;
P1.Left := P2.Right;
P2.Right := P1;
Node.Right := P2.Left;
P2.Left := Node;
if Balance2 = Nodes.Right then
Node.Balance := Nodes.Left;
else
Node.Balance := Nodes.Middle;
end if;
if Balance2 = Nodes.Left then
P1.Balance := Nodes.Right;
else
P1.Balance := Nodes.Middle;
end if;
Node := P2;
P2.Balance := Nodes.Middle;
end if;
end case;
end Balance_Left;
procedure Balance_Right (Node : in out Nodes.AVL_Node_Ref;
Decreased : in out Boolean) is
P1, P2 : Nodes.AVL_Node_Ref;
Balance1, Balance2 : Nodes.Node_Balance;
use type Nodes.Node_Balance;
begin
case Node.Balance is
when Nodes.Right =>
Node.Balance := Nodes.Middle;
when Nodes.Middle =>
Node.Balance := Nodes.Left;
Decreased := False;
when Nodes.Left =>
P1 := Node.Left;
Balance1 := P1.Balance;
if Balance1 <= Nodes.Middle then
Node.Left := P1.Right;
P1.Right := Node;
if Balance1 = Nodes.Middle then
Node.Balance := Nodes.Left;
P1.Balance := Nodes.Right;
Decreased := False;
else
Node.Balance := Nodes.Middle;
P1.Balance := Nodes.Middle;
end if;
Node := P1;
else
P2 := P1.Right;
Balance2 := P2.Balance;
P1.Right := P2.Left;
P2.Left := P1;
Node.Left := P2.Right;
P2.Right := Node;
if Balance2 = Nodes.Left then
Node.Balance := Nodes.Right;
else
Node.Balance := Nodes.Middle;
end if;
if Balance2 = Nodes.Right then
P1.Balance := Nodes.Left;
else
P1.Balance := Nodes.Middle;
end if;
Node := P2;
P2.Balance := Nodes.Middle;
end if;
end case;
end Balance_Right;
-- On entry, To_Be_Deleted is the node which contains the value that
-- is to be deleted. Candidate_Replacement starts off as the left
-- child of To_Be_Deleted, but the procedure recurses until
-- Candidate_Replacement is the rightmost (largest) child of the
-- left subtree of To_Be_Deleted.
--
-- The value at Candidate_Replacement is then transferred to the
-- node To_Be_Deleted, and the pointer To_Be_Deleted is made to
-- point to the rightmost child (so that that what eventually gets
-- deleted is that rightmost child).
--
-- The tree is rebalanced as the recursion unwinds.
procedure Delete
(To_Be_Deleted, Candidate_Replacement : in out Nodes.AVL_Node_Ref;
Decreased : in out Boolean) is
use type Nodes.AVL_Node_Ref;
begin
if Candidate_Replacement.Right /= null then
-- Recurse down the right branch
Delete (To_Be_Deleted, Candidate_Replacement.Right, Decreased);
if Candidate_Replacement.Left = null
and then Candidate_Replacement.Right = null then
Candidate_Replacement.Balance := Nodes.Middle;
elsif Decreased then
Balance_Right (Candidate_Replacement, Decreased);
end if;
else
-- We've found the rightmost child.
-- Copy the value there to the node that contained the value
-- to be deleted.
To_Be_Deleted.Element := Candidate_Replacement.Element;
-- Replace the pointer to the node that contained the value to
-- be deleted with a pointer to the rightmost child of the left
-- subtree (no longer needed, and to be deleted by the caller).
To_Be_Deleted := Candidate_Replacement;
-- Candidate_Replacement is the actual pointer in the parent
-- node; it needs to point to the left subtree, if any, of the
-- node that was the rightmost child and which we are about to
-- delete.
Candidate_Replacement := Candidate_Replacement.Left;
-- We've definitely reduced the depth.
Decreased := True;
end if;
end Delete;
procedure Search_Delete (T: in out AVL_Tree;
Element : Item;
Node : in out Nodes.AVL_Node_Ref;
Decreased : in out Boolean;
Deleted : out Boolean) is
Q : Nodes.AVL_Node_Ref;
use type Nodes.AVL_Node_Ref;
begin
Deleted := False;
if Node /= null then
if Element < Node.Element then
Search_Delete (T, Element, Node.Left, Decreased, Deleted);
if Decreased then
Balance_Left (Node, Decreased);
end if;
elsif Node.Element < Element then
Search_Delete (T, Element, Node.Right, Decreased, Deleted);
if Decreased then
Balance_Right (Node, Decreased);
end if;
else
Q := Node;
Deleted := True;
if Q.Right = null then
Node := Q.Left;
Decreased := True;
elsif Q.Left = null then
Node := Q.Right;
Decreased := True;
else
Delete (Q, Q.Left, Decreased);
if Decreased then
Balance_Left (Node, Decreased);
end if;
end if;
Nodes.Delete (Q);
end if;
end if;
end Search_Delete;
function Search (T: AVL_Tree;
Element: Item;
Node: Nodes.AVL_Node_Ref) return Boolean is
use type Nodes.AVL_Node_Ref;
begin
if Node /= null then
if Node.Element = Element then
return True;
elsif Element < Node.Element then
return Search (T, Element, Node.Left);
else
return Search (T, Element, Node.Right);
end if;
else
return False;
end if;
end Search;
--end supporting functions
function "=" (L, R : AVL_Tree) return Boolean is
-- Once we know that the sizes are the same, we only need to check
-- that all members of L are in R, because we don't allow
-- duplicate members.
procedure Check_In_Right (Elem : in Item; Found : out Boolean);
procedure Compare is new Visit (Apply => Check_In_Right);
Are_Equal : Boolean := True;
procedure Check_In_Right (Elem : in Item; Found : out Boolean) is
begin
Found := Is_Member (R, Elem); -- to terminate early
if not Found then
Are_Equal := False;
end if;
end Check_In_Right;
begin
if L.Size /= R.Size then
return False;
end if;
Compare (Over_The_Tree => L);
return Are_Equal;
end "=";
procedure Clear (T : in out AVL_Tree) is
begin
Purge (T.Rep);
T.Size := 0;
end Clear;
procedure Insert (T : in out AVL_Tree;
Element : Item;
Not_Found : out Boolean) is
Increased : Boolean := False;
Result : Boolean;
begin
Search_Insert (T, Element, T.Rep, Increased, Result);
if Result then
T.Size := T.Size + 1;
Not_Found := True;
else
Not_Found := False;
end if;
end Insert;
procedure Delete
(T : in out AVL_Tree; Element : Item; Found : out Boolean) is
Decreased : Boolean := False;
Result : Boolean;
begin
Search_Delete (T, Element, T.Rep, Decreased, Result);
if Result then
T.Size := T.Size - 1;
Found := True;
else
Found := False;
end if;
end Delete;
function Extent (T : in AVL_Tree) return Natural is
begin
return T.Size;
end Extent;
function Is_Null (T : in AVL_Tree) return Boolean is
use type Nodes.AVL_Node_Ref;
begin
return T.Rep = null;
end Is_Null;
function Is_Member (T : in AVL_Tree; Element : Item) return Boolean is
begin
return Search (T, Element, T.Rep);
end Is_Member;
-- function Item_Of (Node : AVL_Node_Ref;
-- Element : Item) return Item_Ptr is
-- use type Nodes.AVL_Node_Ref;
-- begin
-- if Node /= null then
-- if Node.Element = Element then
-- return Node.Element'access;
-- elsif Less (Element, Node.Element) then
-- return ItemOf (Node.Left, Element, Less);
-- else
-- return ItemOf (Node.Right, Element ,Less);
-- end if;
-- else
-- return null;
-- end if;
-- end ItemOf;
procedure Access_Actual_Item (In_The_Tree : AVL_Tree;
Elem : Item;
Found : out Boolean) is
procedure Access_Actual_Item (Node : Nodes.AVL_Node_Ref) is
use type Nodes.AVL_Node_Ref;
begin
if Node /= null then
if Node.Element = Elem then
Found := True;
Apply (Node.Element);
elsif Elem < Node.Element then
Access_Actual_Item (Node.Left);
else
Access_Actual_Item (Node.Right);
end if;
end if;
end Access_Actual_Item;
begin
Found := False;
Access_Actual_Item (In_The_Tree.Rep);
end Access_Actual_Item;
-- function Traverse (Node : AVL_Node_Ref;
-- Iter_Func : Iteration_Function) return Boolean is
-- Temp : AVL_Node_Ref;
-- begin
-- if Node /= null then
-- Temp := Node.Left;
-- if not Traverse (Temp, Iter_Func) then
-- return False;
-- end if;
-- if not Iter_Func (Temp.Element) then
-- return False;
-- end if;
-- Temp := Node.Right;
-- if not Traverse (Temp, Iter_Func) then
-- return False;
-- end if;
-- end if;
-- return True;
-- end Traverse;
procedure Visit (Over_The_Tree : AVL_Tree) is
Continue : Boolean := True;
use type Nodes.AVL_Node_Ref;
procedure Visit (Node : Nodes.AVL_Node_Ref) is
use type Nodes.AVL_Node_Ref;
begin
if Node /= null then
Visit (Node.Left);
if not Continue then
return;
end if;
Apply (Node.Element, Continue);
if not Continue then
return;
end if;
Visit (Node.Right);
end if;
end Visit;
begin
Visit (Over_The_Tree.Rep);
end Visit;
procedure Modify (Over_The_Tree : AVL_Tree) is
Continue : Boolean := True;
use type Nodes.AVL_Node_Ref;
procedure Modify (Node : Nodes.AVL_Node_Ref) is
use type Nodes.AVL_Node_Ref;
begin
if Node /= null then
Modify (Node.Left);
if not Continue then
return;
end if;
Apply (Node.Element, Continue);
if not Continue then
return;
end if;
Modify (Node.Right);
end if;
end Modify;
begin
Modify (Over_The_Tree.Rep);
end Modify;
procedure Initialize (T : in out AVL_Tree) is
begin
null;
end Initialize;
procedure Adjust (T : in out AVL_Tree) is
New_Tree : AVL_Tree;
procedure Add (Elem : in Item; OK : out Boolean);
procedure Copy is new Visit (Apply => Add);
procedure Add (Elem : in Item; OK : out Boolean) is
Inserted : Boolean;
begin
Insert (T => New_Tree, Element => Elem, Not_Found => Inserted);
-- XXX should test Inserted?
OK := True;
end Add;
begin
-- Create a deep copy of the representation
Copy (Over_The_Tree => T);
-- Replace the original representation with the copy
T.Rep := New_Tree.Rep;
-- Null out the spare reference to the copy (so that when New_Tree
-- gets finalized on exit from this procedure, we don't Clear it
-- down). NB, mustn't do a whole-record assignment here or we'll
-- end up with a recursive disaster).
New_Tree.Rep := null;
New_Tree.Size := 0;
end Adjust;
procedure Finalize (T : in out AVL_Tree) is
begin
Clear (T);
end;
end BC.Containers.Trees.AVL;