|
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: 21504 (0x5400)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Binary_Trees, seg_045787, seg_045799, seg_0457fd, seg_046946
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Text_Io;
with Text_Io;
with Unchecked_Deallocation;
package body Binary_Trees is
----------------------------------------------------------------------------
-- 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 Tree is
begin
return new Tree_Header'(0, null, 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);
Text_Io.Put_Line
("*** WARNING*** " &
"You want to replace an element which does not exist!");
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 (V : Value_Type; T : 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 (V : Value_Type;
T : Tree;
Found : out Boolean;
Duplicate : out Value_Type) 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 (V : Value_Type;
T : Tree;
Found : out Boolean;
Old_Value : out Value_Type)
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 (T : in out Tree) is
begin
if T /= null then
Destroy_Nodes (T.Root);
Free_Tree (T);
end if;
end Destroy;
----------------------------------------------------------------------------
procedure Destroy_Deep (T : in out Tree) 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);
New_Node.Value := Next_Value;
Subtree (Count - Count / 2 - 1, New_Node.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);
return Copy_Balanced (Size (T));
end Copy_Tree;
----------------------------------------------------------------------------
function Is_Empty (T : Tree) return Boolean is
begin
return T = null or else T.Root = null;
end Is_Empty;
----------------------------------------------------------------------------
procedure Find_Node (V : Value_Type;
N : Node_Ptr;
Match : out Value_Type;
Found : out Boolean) 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 (V : Value_Type; T : Tree) return Value_Type 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 (V : Value_Type;
T : Tree;
Found : out Boolean;
Match : out Value_Type) is
begin
if T = null then
raise Invalid_Tree;
end if;
Find_Node (V, T.Root, Match, Found);
end Find;
----------------------------------------------------------------------------
function Is_Found (V : Value_Type; T : Tree) 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 (T : 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 := Inorder) 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 (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 (T : Tree) return Iterator is
begin
if T = null then
raise Invalid_Tree;
end if;
return Subtree_Iter (T.Root, null);
end Make_Iter;
procedure Make_Iterator (T : Tree;
An_Iterator : in out Iterator;
A_Value : out Value_Type) is
begin
if T = null then
raise Invalid_Tree;
end if;
An_Iterator := Subtree_Iter (T.Root, null);
A_Value := An_Iterator.Subtree.Value;
end Make_Iterator;
----------------------------------------------------------------------------
function More (I : Iterator) 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 First (I : in out Iterator; V : out Value_Type) is
begin
if I = null or I.State = Done then
raise No_More;
end if;
V := I.Subtree.Value;
end First;
procedure Next (I : in out Iterator; V : out Value_Type) is
Ni : Iterator;
begin
if I = null or I.State = Done then
raise No_More;
end if;
case I.State is
when Left =>
while I.Subtree.Less /= null loop
I.State := Middle;
I := Subtree_Iter (I.Subtree.Less, I);
end loop;
V := I.Subtree.Value;
if I.Subtree.More /= null then
I.State := Right;
else
Pop_Iterator (I);
end if;
when Middle =>
V := I.Subtree.Value;
if I.Subtree.More /= null then
I.State := Right;
else
Pop_Iterator (I);
end if;
when Right =>
I.State := Done;
I := Subtree_Iter (I.Subtree.More, I);
Next (I, V);
when Done =>
Pop_Iterator (I);
Next (I, V);
end case;
end Next;
----------------------------------------------------------------------------
procedure Search_And_Delete (T : in out Tree; Element : out Value_Type) is
Node_Tmp : Node_Ptr;
procedure Search (N : in out Node_Ptr) is
begin
if N /= null then
while ((N.Less /= null) or (N.More /= null)) loop
if N.Less /= null then
N := N.Less;
elsif N.More /= null then
N := N.More;
end if;
end loop;
end if;
end Search;
procedure Delete (N : in out Node_Ptr) is
Node_Tmp : Node_Ptr;
begin
if N /= null then
while ((N.Less /= null) or (N.More /= null)) loop
if N.Less /= null then
Node_Tmp := N;
N := N.Less;
elsif N.More /= null then
Node_Tmp := N;
N := N.More;
end if;
end loop;
if Node_Tmp.Less /= null and Node_Tmp.More /= null then
N := Node_Tmp;
N.Less := null;
elsif Node_Tmp.More /= null and Node_Tmp.Less = null then
N := Node_Tmp;
N.More := null;
elsif Node_Tmp.More = null and Node_Tmp.Less /= null then
N := Node_Tmp;
N.Less := null;
else
N := Node_Tmp;
N := null;
end if;
Node_Tmp := null;
end if;
end Delete;
begin
if T.Count = 1 then
Element := T.Root.Value;
T.Count := 0;
Destroy (T);
else
Node_Tmp := T.Root;
Search (Node_Tmp);
Element := Node_Tmp.Value;
Node_Tmp := null;
T.Courant := T.Root;
Delete (T.Courant);
T.Count := T.Count - 1;
end if;
end Search_And_Delete;
----------------------------------------------------------------------------
end Binary_Trees;
nblk1=14
nid=0
hdr6=28
[0x00] rec0=20 rec1=00 rec2=01 rec3=046
[0x01] rec0=20 rec1=00 rec2=11 rec3=01a
[0x02] rec0=01 rec1=00 rec2=14 rec3=01a
[0x03] rec0=22 rec1=00 rec2=03 rec3=062
[0x04] rec0=03 rec1=00 rec2=02 rec3=03e
[0x05] rec0=23 rec1=00 rec2=04 rec3=02c
[0x06] rec0=25 rec1=00 rec2=05 rec3=028
[0x07] rec0=23 rec1=00 rec2=06 rec3=000
[0x08] rec0=23 rec1=00 rec2=07 rec3=060
[0x09] rec0=27 rec1=00 rec2=08 rec3=010
[0x0a] rec0=27 rec1=00 rec2=09 rec3=048
[0x0b] rec0=22 rec1=00 rec2=0f rec3=030
[0x0c] rec0=1e rec1=00 rec2=0a rec3=022
[0x0d] rec0=24 rec1=00 rec2=0b rec3=00a
[0x0e] rec0=00 rec1=00 rec2=13 rec3=006
[0x0f] rec0=25 rec1=00 rec2=0c rec3=048
[0x10] rec0=11 rec1=00 rec2=0d rec3=040
[0x11] rec0=21 rec1=00 rec2=0e rec3=01c
[0x12] rec0=19 rec1=00 rec2=12 rec3=000
[0x13] rec0=17 rec1=00 rec2=10 rec3=000
tail 0x21541d63e864b5b0e367f 0x42a00088462060003