|
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 - metrics - download
Length: 11104 (0x2b60)
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«
└─⟦10e94fc88⟧
└─⟦this⟧
generic
type P is private;
package T_Stack is
type Tstack is limited private;
Error_Tstack_Allocation : exception;
-------------------------------------------------
-- Create : -> Tstack
-------------------------------------------------
procedure Create (Thetop : in out Tstack);
-------------------------------------------------
-- Empty : Tstack -> BOOLEAN
-------------------------------------------------
function Empty (Thetop : Tstack) return Boolean;
--------------------------------------------------
-- Push : P,Tstack ->Tstack
--------------------------------------------------
procedure Push (Thetop : in out Tstack; X : P);
--------------------------------------------------
-- Pop : Tstack -> Tstack
--------------------------------------------------
procedure Pop (Thetop : in out Tstack);
------------------------------------------------
-- Get : Tstack -> P
------------------------------------------------
function Get (Thetop : Tstack) return P;
private
type Stack_Cell;
type Tstack is access Stack_Cell;
type Stack_Cell is
record
Element : P;
Next_Cell : Tstack;
end record;
end T_Stack;
with Unchecked_Deallocation, T_Stack, Text_Io;
package body T_Stack is
procedure Free is new Unchecked_Deallocation (Stack_Cell, Tstack);
procedure Create (Thetop : in out Tstack) is
begin
Thetop := null;
end Create;
function Empty (Thetop : Tstack) return Boolean is
begin
return (Thetop = null);
end Empty;
procedure Push (Thetop : in out Tstack; X : P) is
Astack : Tstack;
begin
Astack := new Stack_Cell;
Astack.all.Element := X;
Astack.all.Next_Cell := Thetop;
Thetop := Astack;
exception
when others =>
raise Error_Tstack_Allocation;
end Push;
procedure Pop (Thetop : in out Tstack) is
Astack : Tstack;
begin
if not Empty (Thetop) then
Astack := Thetop;
Thetop := Astack.all.Next_Cell;
Free (Astack);
end if;
end Pop;
function Get (Thetop : Tstack) return P is
begin
return Thetop.all.Element;
end Get;
end T_Stack;
with T_Stack;
generic
type T is private;
with function Compare (Left_Op, Right_Op : T) return integer is <>;
with procedure Affect (Dest : in out T; Source : T) is <>;
with procedure Print (Item : T);
package T_Tree is
INF :constant Integer := -1;
EQU :constant Integer := 0;
SUP :constant Integer := 1;
type Ttree is limited private;
type Tree_Index is limited private;
Error_Ttree_Allocation : exception;
--------------------------------------------------
-- Create : -> Ttree
--------------------------------------------------
procedure Create (A : in out Ttree);
--------------------------------------------------
-- Empty : Ttree -> BOOLEAN
--------------------------------------------------
function Empty (A : Ttree) return Boolean;
--------------------------------------------------
-- Left : Ttree -> Ttree
--------------------------------------------------
function Left (A : Ttree) return Ttree;
--------------------------------------------------
-- Right : Ttree -> Ttree
--------------------------------------------------
function Right (A : Ttree) return Ttree;
--------------------------------------------------
-- Build : T,Ttree,Ttree -> Ttree
--------------------------------------------------
procedure Build (X : T; Node : in out Ttree; Sad, Sag : Ttree);
--------------------------------------------------
-- Build : T -> Ttree
--------------------------------------------------
procedure Build (X : T; Node : in out Ttree);
--------------------------------------------------
-- Get : Ttree->T
--------------------------------------------------
function Get (A : Ttree) return T;
--------------------------------------------------
-- Put : T,Ttree->Ttree
--------------------------------------------------
procedure Put (X : T; A : in out Ttree);
--------------------------------------------------
-- Create_Iterator : Ttree -> Tree_Index
--------------------------------------------------
procedure Create_Iterator (A : Ttree; I : in out Tree_Index);
--------------------------------------------------
-- Current_Iterator : Tree_Index-> Ttree
--------------------------------------------------
function Current_Iterator (I : Tree_Index) return Ttree;
--------------------------------------------------
-- End_Iterator : Tree_Index-> BOOLEAN
--------------------------------------------------
function End_Iterator (I : Tree_Index) return Boolean;
--------------------------------------------------
-- Next_Iterator : Tree_Index ->Tree_Index
--------------------------------------------------
procedure Next_Iterator (I : in out Tree_Index);
--------------------------------------------------
-- Dump : Ttree->
--------------------------------------------------
procedure Dump(A: Ttree);
--------------------------------------------------
-- Insert : T ,Ttree->Ttree
--------------------------------------------------
procedure Insert(X :T;A:in out Ttree);
--------------------------------------------------
-- Search : T ,Ttree,Tree->Boolean,Ttree
--------------------------------------------------
Procedure Search (X :T;A: Ttree;Found: in out Ttree);
private
type Tree_Cell;
type Ttree is access Tree_Cell;
type Tree_Cell is
record
Element : T;
Left, Right : Ttree;
end record;
package Stack_Node is new T_Stack (Ttree);
type Tree_Index is
record
Ptr : Stack_Node.Tstack;
end record;
end T_Tree;
with Unchecked_Deallocation, T_Stack, Text_Io;
package body T_Tree is
procedure Free is new Unchecked_Deallocation (Tree_Cell, Ttree);
procedure Create (A : in out Ttree) is
begin
A := null;
end Create;
function Empty (A : Ttree) return Boolean is
begin
return (A = null);
end Empty;
function Left (A : Ttree) return Ttree is
begin
return A.all.Left;
end Left;
function Right (A : Ttree) return Ttree is
begin
return A.all.Right;
end Right;
procedure Build (X : T; Node : in out Ttree; Sad, Sag : Ttree) is
begin
Node := new Tree_Cell;
Affect (Node.all.Element, X);
Node.all.Left := Sag;
Node.all.Right := Sad;
exception
when others =>
raise Error_Ttree_Allocation;
end Build;
procedure Build (X : T; Node : in out Ttree) is
begin
Node := new Tree_Cell;
Affect (Node.all.Element, X);
Node.all.Left := null;
Node.all.Right := null;
exception
when others =>
raise Error_Ttree_Allocation;
end Build;
function Get (A : Ttree) return T is
begin
return A.all.Element;
end Get;
procedure Put (X : T; A : in out Ttree) is
begin
Affect (A.all.Element, X);
end Put;
procedure Create_Iterator (A : Ttree; I : in out Tree_Index) is
G : Ttree;
begin
Stack_Node.Create (I.Ptr);
Stack_Node.Push (I.Ptr, A);
G := A;
while (G.all.Left /= null) loop
Stack_Node.Push (I.Ptr, G.all.Left);
G := G.all.Left;
end loop;
end Create_Iterator;
function Current_Iterator (I : Tree_Index) return Ttree is
begin
return Stack_Node.Get (I.Ptr);
end Current_Iterator;
function End_Iterator (I : Tree_Index) return Boolean is
begin
return Stack_Node.Empty (I.Ptr);
end End_Iterator;
procedure Next_Iterator (I : in out Tree_Index) is
The_Top, Left_Tree : Ttree;
begin
if not (Stack_Node.Empty (I.Ptr)) then
The_Top := Stack_Node.Get (I.Ptr);
Stack_Node.Pop (I.Ptr);
if not (Empty (The_Top.all.Right)) then
Stack_Node.Push (I.Ptr, The_Top.all.Right);
Left_Tree := The_Top.all.Right.all.Left;
while not (Empty (Left_Tree)) loop
Stack_Node.Push (I.Ptr, Left_Tree);
Left_Tree := Left_Tree.all.Left;
end loop;
end if;
end if;
end Next_Iterator;
procedure Dump(A: Ttree) is
Index : Tree_Index;
begin
Create_Iterator (A, Index);
while not (End_Iterator (Index)) loop
Print (Get (Current_Iterator (Index)));
Next_Iterator (Index);
end loop;
end dump;
procedure Insert(X :T ; A:in out Ttree) is
current :T;
begin
if Empty(A) then
Build (X,A);
else
Affect(current,Get(A));
If Compare(Current,X)=SUP then
Insert(X,A.all.Left);
else
Insert(X,A.all.Right);
end if;
end if;
end Insert;
Procedure Search (X :T;A: Ttree;Found:in out Ttree)is
Index : Tree_Index;
begin
Create_Iterator (A, Index);
Found:=Null;
search_loop:while not (End_Iterator (Index)) loop
if Compare(X, Get (Current_Iterator (Index))) = EQU then
Found:=Current_Iterator (Index);
exit search_loop;
else Next_Iterator (Index);
end if;
end loop search_loop;
end;
end T_Tree;
with T_Tree, Text_Io;
procedure Main is
subtype Variable_String is String (1 .. 2);
function Compare (A, B : Variable_String) return integer;
procedure Copie (D : in out Variable_String; S : Variable_String);
procedure Write (D : Variable_String);
package Arbre is new T_Tree (Variable_String, Compare,Copie, Write);
Data : Variable_String;
Racine,Trouve : Arbre.Ttree;
function Compare (A, B : Variable_String) return integer is
begin
if A<B then
return arbre.INF;
elsif A=B then
return arbre.EQU;
else return arbre.SUP;
end if;
end Compare;
procedure Copie (D : in out Variable_String; S : Variable_String) is
begin
D := S;
end Copie;
procedure Write (D : Variable_String) is
begin
Text_Io.Put_Line ("->" & D);
end Write;
begin
Arbre.Create (Racine);
Arbre.Insert("ga",Racine);
Arbre.Insert("dd",Racine);
Arbre.Insert("rg",Racine);
Arbre.Insert("fg",Racine);
Arbre.Search("rg",Racine,trouve);
if not arbre.Empty(trouve) then
Arbre.Insert("zz",Racine);
end if;
Arbre.Dump(Racine);
if not arbre.Empty(trouve) then
Arbre.Put("kk",Trouve);
end if;
Arbre.Dump(Racine);
end Main