|
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: 11948 (0x2eac)
Types: TextFile
Notes: R1k Text-file segment
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦830a7ee75⟧
└─⟦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