-- Copyright 1994 Grady Booch
-- Copyright 1994-1997 David Weller
-- Copyright 1998-2002 Simon Wright <simon@pushface.org>
-- This package is free software; you can redistribute it and/or
-- modify it under terms of the GNU General Public License as
-- published by the Free Software Foundation; either version 2, or
-- (at your option) any later version. This package 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 GNU General Public License for more
-- details. You should have received a copy of the GNU General Public
-- License distributed with this package; see file COPYING. If not,
-- write to the Free Software Foundation, 59 Temple Place - Suite
-- 330, Boston, MA 02111-1307, USA.
-- As a special exception, if other files instantiate generics from
-- this unit, or you link this unit with other files to produce an
-- executable, this unit does not by itself cause the resulting
-- executable to be covered by the GNU General Public License. This
-- exception does not however invalidate any other reasons why the
-- executable file might be covered by the GNU Public License.
-- $RCSfile: bc-containers-trees-binary.adb,v $
-- $Revision: 1.13.2.1 $
-- $Date: 2002/12/29 16:42:08 $
-- $Author: simon $
with Ada.Unchecked_Deallocation;
with BC.Support.Exceptions;
package body BC.Containers.Trees.Binary is
package BSE renames BC.Support.Exceptions;
procedure Assert
is new BSE.Assert ("BC.Containers.Trees.Binary");
function Create
(I : Item; Parent, Left, Right : Binary_Node_Ref)
return Binary_Node_Ref;
function Create
(I : Item; Parent, Left, Right : Binary_Node_Ref)
return Binary_Node_Ref is
Result : Binary_Node_Ref;
begin
Result := new Binary_Node'(Element => I,
Parent => Parent,
Left => Left,
Right => Right,
Count => 1);
if Left /= null then
Left.Parent := Result;
end if;
if Right /= null then
Right.Parent := Result;
end if;
return Result;
end Create;
procedure Delete
is new Ada.Unchecked_Deallocation (Binary_Node, Binary_Node_Ref);
function Create (From : Binary_Tree) return Binary_Tree is
Temp : Binary_Tree := (Ada.Finalization.Controlled with Rep => From.Rep);
begin
if From.Rep /= null then
Temp.Rep.Count := Temp.Rep.Count + 1;
end if;
return Temp;
end Create;
function "=" (Left, Right : Binary_Tree) return Boolean is
begin
return Left.Rep.all = Right.Rep.all;
end "=";
procedure Clear (T : in out Binary_Tree) is
begin
Purge (T.Rep);
T.Rep := null;
end Clear;
procedure Insert (T : in out Binary_Tree;
Elem : in Item;
Child : in Child_Branch) is
begin
Assert (T.Rep = null or else T.Rep.Parent = null,
BC.Not_Root'Identity,
"Insert",
BSE.Not_Root);
if Child = Left then
T.Rep := Create (Elem,
Parent => null,
Left => T.Rep,
Right => null);
else
T.Rep := Create (Elem,
Parent => null,
Left => null,
Right => T.Rep);
end if;
end Insert;
procedure Append (T : in out Binary_Tree;
Elem : in Item;
Child : in Child_Branch;
After : in Child_Branch) is
begin
if T.Rep = null then
T.Rep := Create (Elem,
Parent => null,
Left => null,
Right => null);
else
if After = Left then
if Child = Left then
T.Rep.Left := Create (Elem,
Parent => T.Rep,
Left => T.Rep.Left,
Right => null);
else
T.Rep.Left := Create (Elem,
Parent => T.Rep,
Left => null,
Right => T.Rep.Left);
end if;
else
if Child = Left then
T.Rep.Right := Create (Elem,
Parent => T.Rep,
Left => T.Rep.Right,
Right => null);
else
T.Rep.Right := Create (Elem,
Parent => T.Rep,
Left => null,
Right => T.Rep.Right);
end if;
end if;
end if;
end Append;
procedure Remove (T : in out Binary_Tree; Child : in Child_Branch) is
begin
Assert (T.Rep /= null,
BC.Is_Null'Identity,
"Remove",
BSE.Is_Null);
if Child = Left then
Purge (T.Rep.Left);
T.Rep.Left := null;
else
Purge (T.Rep.Right);
T.Rep.Right := null;
end if;
end Remove;
procedure Share (T : in out Binary_Tree;
Share_With : in Binary_Tree;
Child : in Child_Branch) is
Temp : Binary_Node_Ref := Share_With.Rep;
begin
Assert (Share_With.Rep /= null,
BC.Is_Null'Identity,
"Share",
BSE.Is_Null);
if Child = Left then
Temp := Share_With.Rep.Left;
else
Temp := Share_With.Rep.Right;
end if;
Clear (T);
T.Rep := Temp;
T.Rep.Count := T.Rep.Count + 1;
end Share;
procedure Swap_Child (T : in out Binary_Tree;
Swap_With : in out Binary_Tree;
Child : in Child_Branch) is
Curr : Binary_Node_Ref;
begin
Assert (T.Rep /= null,
BC.Is_Null'Identity,
"Swap_Child",
BSE.Is_Null);
Assert (Swap_With.Rep = null or else Swap_With.Rep.Parent = null,
BC.Not_Root'Identity,
"Swap_Child",
BSE.Not_Root);
if Child = Left then
Curr := T.Rep.Left;
T.Rep.Left := Swap_With.Rep;
else
Curr := T.Rep.Right;
T.Rep.Right := Swap_With.Rep;
end if;
if Swap_With.Rep /= null then
Swap_With.Rep.Parent := T.Rep;
end if;
Swap_With.Rep := Curr;
if Swap_With.Rep /= null then
Swap_With.Rep.Parent := null;
end if;
end Swap_Child;
procedure Child (T : in out Binary_Tree; Child : in Child_Branch) is
begin
if Child = Left then
Left_Child (T);
else
Right_Child (T);
end if;
end Child;
procedure Left_Child (T : in out Binary_Tree) is
Curr : Binary_Node_Ref;
begin
Assert (T.Rep /= null,
BC.Is_Null'Identity,
"Left_Child",
BSE.Is_Null);
Curr := T.Rep;
T.Rep := T.Rep.Left;
if Curr.Count > 1 then
Curr.Count := Curr.Count - 1;
if T.Rep /= null then
T.Rep.Count := T.Rep.Count + 1;
end if;
else
if T.Rep /= null then
T.Rep.Parent := null;
end if;
if Curr.Right /= null then
Curr.Right.Parent := null;
end if;
Delete (Curr);
end if;
end Left_Child;
function Left_Child (T : Binary_Tree) return Binary_Tree is
Result : Binary_Tree;
begin
Result := T;
Left_Child (Result);
return Result;
end Left_Child;
procedure Right_Child (T : in out Binary_Tree) is
Curr : Binary_Node_Ref;
begin
Assert (T.Rep /= null,
BC.Is_Null'Identity,
"Right_Child",
BSE.Is_Null);
Curr := T.Rep;
T.Rep := T.Rep.Right;
if Curr.Count > 1 then
Curr.Count := Curr.Count - 1;
if T.Rep /= null then
T.Rep.Count := T.Rep.Count + 1;
end if;
else
if T.Rep /= null then
T.Rep.Parent := null;
end if;
if Curr.Left /= null then
Curr.Left.Parent := null;
end if;
Delete (Curr);
end if;
end Right_Child;
function Right_Child (T : Binary_Tree) return Binary_Tree is
Result : Binary_Tree;
begin
Result := T;
Right_Child (Result);
return Result;
end Right_Child;
procedure Parent (T : in out Binary_Tree) is
begin
Assert (T.Rep /= null,
BC.Is_Null'Identity,
"Parent",
BSE.Is_Null);
if T.Rep.Parent = null then
Clear (T);
else
T.Rep.Count := T.Rep.Count - 1;
T.Rep := T.Rep.Parent;
if T.Rep /= null then
T.Rep.Count := T.Rep.Count + 1;
end if;
end if;
end Parent;
procedure Set_Item (T : in out Binary_Tree; Elem : in Item) is
begin
Assert (T.Rep /= null,
BC.Is_Null'Identity,
"Set_Item",
BSE.Is_Null);
T.Rep.Element := Elem;
end Set_Item;
function Has_Children (T : in Binary_Tree) return Boolean is
begin
return (T.Rep /= null and then
(T.Rep.Left /= null or else T.Rep.Right /= null));
end Has_Children;
function Is_Null (T : in Binary_Tree) return Boolean is
begin
return T.Rep = null;
end Is_Null;
function Is_Shared (T : in Binary_Tree) return Boolean is
begin
return T.Rep /= null and then T.Rep.Count > 1;
end Is_Shared;
function Is_Root (T : in Binary_Tree) return Boolean is
begin
return T.Rep = null or else T.Rep.Parent = null;
end Is_Root;
function Item_At (T : in Binary_Tree) return Item is
begin
Assert (T.Rep /= null,
BC.Is_Null'Identity,
"Item_At",
BSE.Is_Null);
return T.Rep.Element;
end Item_At;
procedure Purge (Node : in out Binary_Node_Ref) is
begin
if Node /= null then
if Node.Count > 1 then
Node.Count := Node.Count - 1;
else
Purge (Node.Left);
if Node.Left /= null then
Node.Left.Parent := null;
end if;
Purge (Node.Right);
if Node.Right /= null then
Node.Right.Parent := null;
end if;
Delete (Node);
end if;
end if;
end Purge;
procedure Initialize (T : in out Binary_Tree) is
pragma Warnings (Off, T);
begin
null;
end Initialize;
procedure Adjust (T : in out Binary_Tree) is
begin
if T.Rep /= null then
T.Rep.Count := T.Rep.Count + 1;
end if;
end Adjust;
procedure Finalize (T : in out Binary_Tree) is
begin
Clear (T);
end Finalize;
end BC.Containers.Trees.Binary;
syntax highlighted by Code2HTML, v. 0.9.1