|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 18432 (0x4800)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Binary_Trees_Pkg, seg_04960e
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
with Unchecked_Deallocation;
package body Binary_Trees_Pkg is
--| Efficient implementation of binary trees.
----------------------------------------------------------------------------
-- Local Operations --
----------------------------------------------------------------------------
procedure Free_Node is new Unchecked_Deallocation (Node, Node_Ptr);
procedure Free_Tree is new Unchecked_Deallocation (Tree_Header, Tree);
procedure Free_Iterator is new Unchecked_Deallocation
(Iterator_Record, Iterator);
----------------------------------------------------------------------------
-- Visible Operations --
----------------------------------------------------------------------------
function Create --| Return an empty tree.
return Tree is
begin
return new Tree_Header'(0, null);
end Create;
----------------------------------------------------------------------------
procedure Insert_Node (V : Value_Type;
N : in out Node_Ptr;
Found : out Boolean;
Duplicate : out Value_Type) is
D : Integer;
begin
Found := False;
if N = null then
N := new Node'(V, null, null);
else
D := Difference (V, N.Value);
if D < 0 then
Insert_Node (V, N.Less, Found, Duplicate);
elsif D > 0 then
Insert_Node (V, N.More, Found, Duplicate);
else
Found := True;
Duplicate := N.Value;
end if;
end if;
end Insert_Node;
procedure Replace_Node (V : Value_Type;
N : in out Node_Ptr;
Found : out Boolean;
Duplicate : out Value_Type) is
D : Integer;
begin Found := False;
if N = null then
N := new Node'(V, null, null);
else
D := Difference (V, N.Value);
if D < 0 then
Replace_Node (V, N.Less, Found, Duplicate);
elsif D > 0 then
Replace_Node (V, N.More, Found, Duplicate);
else
Found := True;
Duplicate := N.Value;
N.Value := V;
end if;
end if;
end Replace_Node;
procedure Insert ( --| Insert a value into a tree.
V : Value_Type; --| Value to be inserted
T : Tree --| Tree to contain the new value
) --| Raises: Duplicate_Value, Invalid_Tree.
is
Found : Boolean;
Duplicate : Value_Type;
begin
if T = null then
raise Invalid_Tree;
end if;
Insert_Node (V, T.Root, Found, Duplicate);
if Found then
raise Duplicate_Value;
end if;
T.Count := T.Count + 1;
end Insert;
procedure Insert_If_Not_Found
(
--| Insert a value into a tree, provided a duplicate value is not already there
V : Value_Type; --| Value to be inserted
T : Tree; --| Tree to contain the new value
Found : out Boolean;
Duplicate : out Value_Type) --| Raises: Invalid_Tree.
is
Was_Found : Boolean;
begin
if T = null then
raise Invalid_Tree;
end if;
Insert_Node (V, T.Root, Was_Found, Duplicate);
Found := Was_Found;
if not Was_Found then
T.Count := T.Count + 1;
end if;
end Insert_If_Not_Found;
procedure Replace_If_Found
(
--| Replace a value if label exists, otherwise insert it.
V : Value_Type; --| Value to be inserted
T : Tree; --| Tree to contain the new value
Found : out Boolean; --| Becomes True iff L already in tree
Old_Value : out
Value_Type --| the duplicate value, if there is one
) --| Raises: Invalid_Tree.
is
Was_Found : Boolean;
Duplicate : Value_Type;
begin
if T = null then
raise Invalid_Tree;
end if;
Replace_Node (V, T.Root, Was_Found, Duplicate);
Found := Was_Found;
if Was_Found then
Old_Value := Duplicate;
else
T.Count := T.Count + 1;
end if;
end Replace_If_Found;
----------------------------------------------------------------------------
procedure Destroy_Nodes (N : in out Node_Ptr) is
begin
if N /= null then
Destroy_Nodes (N.Less);
Destroy_Nodes (N.More);
Free_Node (N);
end if;
end Destroy_Nodes;
procedure Destroy ( --| Free space allocated to a tree.
T : in out Tree --| The tree to be reclaimed.
) is
begin
if T /= null then
Destroy_Nodes (T.Root);
Free_Tree (T);
end if;
end Destroy;
----------------------------------------------------------------------------
procedure Destroy_Deep ( --| Free all space allocated to a tree.
T : in out Tree --| The tree to be reclaimed.
) is
procedure Destroy_Nodes (N : in out Node_Ptr) is
begin
if N /= null then
Free_Value (N.Value);
Destroy_Nodes (N.Less);
Destroy_Nodes (N.More);
Free_Node (N);
end if;
end Destroy_Nodes;
begin
if T /= null then
Destroy_Nodes (T.Root);
Free_Tree (T);
end if;
end Destroy_Deep;
----------------------------------------------------------------------------
function Balanced_Tree (Count : Natural) return Tree
is
New_Tree : Tree := Create;
procedure Subtree (Count : Natural; N : in out Node_Ptr) is
New_Node : Node_Ptr;
begin
if Count = 1 then
New_Node := new Node'(Next_Value, null, null);
elsif Count > 1 then
New_Node := new Node;
Subtree (Count / 2, New_Node.Less); -- Half are less
New_Node.Value := Next_Value; -- Median value
Subtree (Count - Count / 2 - 1,
New_Node.More); -- Other half are more
end if;
N := New_Node;
end Subtree;
begin
New_Tree.Count := Count;
Subtree (Count, New_Tree.Root);
return New_Tree;
end Balanced_Tree;
----------------------------------------------------------------------------
function Copy_Tree (T : Tree) return Tree is
I : Iterator;
function Next_Val return Value_Type is
V : Value_Type;
begin
Next (I, V);
return Copy_Value (V);
end Next_Val;
function Copy_Balanced is new Balanced_Tree (Next_Val);
begin
I := Make_Iter (T); -- Will raise Invalid_Tree if necessary
return Copy_Balanced (Size (T));
end Copy_Tree;
----------------------------------------------------------------------------
function Is_Empty ( --| Check for an empty tree.
T : Tree) return Boolean is
begin
return T = null or else T.Root = null;
end Is_Empty;
----------------------------------------------------------------------------
procedure Find_Node
(V : Value_Type; --| Value to be located
N : Node_Ptr; --| subtree to be searched
Match : out Value_Type; --| Matching value found in the tree
Found : out Boolean --| TRUE iff a match was found
) is
D : Integer;
begin
if N = null then
Found := False;
return;
end if;
D := Difference (V, N.Value);
if D < 0 then
Find_Node (V, N.Less, Match, Found);
elsif D > 0 then
Find_Node (V, N.More, Match, Found);
else
Match := N.Value;
Found := True;
end if;
end Find_Node;
function Find ( --| Search a tree for a value.
V : Value_Type; --| Value to be located
T : Tree --| Tree to be searched
) return Value_Type --| Raises: Not_Found.
is
Found : Boolean;
Match : Value_Type;
begin
if T = null then
raise Invalid_Tree;
end if;
Find_Node (V, T.Root, Match, Found);
if Found then
return Match;
else
raise Not_Found;
end if;
end Find;
procedure Find
( --| Search a tree for a value.
V : Value_Type; --| Value to be located
T : Tree; --| Tree to be searched
Found : out Boolean; --| TRUE iff a match was found
Match : out Value_Type --| Matching value found in the tree
) is
begin
if T = null then
raise Invalid_Tree;
end if;
Find_Node (V, T.Root, Match, Found);
end Find;
----------------------------------------------------------------------------
function Is_Found ( --| Check a tree for a value.
V : Value_Type; --| Value to be located
T : Tree --| Tree to be searched
) return Boolean is
Found : Boolean;
Match : Value_Type;
begin
if T = null then
raise Invalid_Tree;
end if;
Find_Node (V, T.Root, Match, Found);
return Found;
end Is_Found;
----------------------------------------------------------------------------
function Size ( --| Return the count of values in T.
T : Tree --| a tree
) return Natural is
begin
if T = null then
return 0;
else
return T.Count;
end if;
end Size;
----------------------------------------------------------------------------
procedure Visit (T : Tree; Order : Scan_Kind) is
procedure Visit_Inorder (N : Node_Ptr) is
begin
if N.Less /= null then
Visit_Inorder (N.Less);
end if;
Process (N.Value);
if N.More /= null then
Visit_Inorder (N.More);
end if;
end Visit_Inorder;
procedure Visit_Preorder (N : Node_Ptr) is
begin
Process (N.Value);
if N.Less /= null then
Visit_Preorder (N.Less);
end if;
if N.More /= null then
Visit_Preorder (N.More);
end if;
end Visit_Preorder;
procedure Visit_Postorder (N : Node_Ptr) is
begin
if N.Less /= null then
Visit_Postorder (N.Less);
end if;
if N.More /= null then
Visit_Postorder (N.More);
end if;
Process (N.Value);
end Visit_Postorder;
begin
if T = null then
raise Invalid_Tree;
else
case Order is
when Inorder =>
Visit_Inorder (T.Root);
when Preorder =>
Visit_Preorder (T.Root);
when Postorder =>
Visit_Postorder (T.Root);
end case;
end if;
end Visit;
----------------------------------------------------------------------------
function Subtree_Iter ( --| Create an iterator over a subtree
N : Node_Ptr;
P : Iterator) return Iterator is
begin
if N = null then
return new Iterator_Record'
(State => Done, Parent => P, Subtree => N);
elsif N.Less = null then
return new Iterator_Record'
(State => Middle, Parent => P, Subtree => N);
else return new Iterator_Record'
(State => Left, Parent => P, Subtree => N);
end if;
end Subtree_Iter;
function Make_Iter ( --| Create an iterator over a tree
T : Tree) return Iterator is
begin
if T = null then
raise Invalid_Tree;
end if;
return Subtree_Iter (T.Root, null);
end Make_Iter;
----------------------------------------------------------------------------
function More ( --| Test for exhausted iterator
I : Iterator --| The iterator to be tested
) return Boolean is
begin
if I = null then
return False;
elsif I.Parent = null then
return I.State /= Done and I.Subtree /= null;
elsif I.State = Done then
return More (I.Parent);
else
return True;
end if;
end More;
----------------------------------------------------------------------------
procedure Pop_Iterator (I : in out Iterator) is
Ni : Iterator;
begin
loop
Ni := I;
I := I.Parent;
Free_Iterator (Ni);
exit when I = null;
exit when I.State /= Done;
end loop;
end Pop_Iterator;
procedure Next ( --| Scan the next value in I
I : in out Iterator; --| an active iterator
V : out Value_Type --| Next value scanned
) --| Raises: No_More.
is
Ni : Iterator;
begin
if I = null or I.State = Done then
raise No_More;
end if;
case I.State is
when Left => -- Return the leftmost value
while I.Subtree.Less /= null loop -- Find leftmost subtree
I.State := Middle; -- Middle is next at this level
I := Subtree_Iter (I.Subtree.Less, I);
end loop;
V := I.Subtree.Value;
if I.Subtree.More /= null then -- There will be more...
I.State := Right; -- ... coming from the right
else -- Nothing else here
Pop_Iterator (I); -- Pop up to parent iterator
end if;
when Middle =>
V := I.Subtree.Value;
if I.Subtree.More /= null then -- There will be more...
I.State := Right; -- ... coming from the right
else -- Nothing else here so...
Pop_Iterator (I); -- ... Pop up to parent iterator
end if;
when Right => -- Return the value on the right
I.State := Done; -- No more at this level
I := Subtree_Iter (I.Subtree.More, I);
Next (I, V);
when Done =>
Pop_Iterator (I);
Next (I, V);
end case;
end Next;
----------------------------------------------------------------------------
end Binary_Trees_Pkg;
nblk1=11
nid=0
hdr6=22
[0x00] rec0=1f rec1=00 rec2=01 rec3=068
[0x01] rec0=20 rec1=00 rec2=0e rec3=002
[0x02] rec0=1e rec1=00 rec2=0d rec3=052
[0x03] rec0=21 rec1=00 rec2=0c rec3=00e
[0x04] rec0=1e rec1=00 rec2=0b rec3=03a
[0x05] rec0=1f rec1=00 rec2=0a rec3=034
[0x06] rec0=22 rec1=00 rec2=09 rec3=006
[0x07] rec0=24 rec1=00 rec2=08 rec3=048
[0x08] rec0=1d rec1=00 rec2=07 rec3=00a
[0x09] rec0=1f rec1=00 rec2=06 rec3=068
[0x0a] rec0=23 rec1=00 rec2=05 rec3=058
[0x0b] rec0=21 rec1=00 rec2=04 rec3=028
[0x0c] rec0=1f rec1=00 rec2=03 rec3=002
[0x0d] rec0=23 rec1=00 rec2=02 rec3=000
[0x0e] rec0=1d rec1=00 rec2=0f rec3=08e
[0x0f] rec0=13 rec1=00 rec2=10 rec3=012
[0x10] rec0=0c rec1=00 rec2=11 rec3=000
tail 0x21546bda6865e5b185d70 0x42a00088462060003