|
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: 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