|
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: 13353 (0x3429)
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«
└─⟦22b03a4a5⟧
└─⟦this⟧
package order_array is
procedure put_place(a_place : in string);
procedure put_first_complement(a_complement : in string);
procedure put_second_complement(a_complement : in string);
procedure put_third_complement(a_complement : in string);
procedure put_fourth_complement(a_complement : in string);
procedure show;
procedure init;
procedure next;
function value return an_order;
function done return boolean;
end;
with text_io,order,group_array,moving_string;
package body order_array is
max_element : constant positive 300;
package o_array is new Generic_String_Sort_Array
(Element => order.Object,
Max_Element_Number => max_element,
Null_Element => order.Null_Object,
Get_Key => order.image,
show_element => order.show);
place_array : o_array.object := o_array.null_object;
first_complement_array : o_array.object := o_array.null_object;
second_complement_array : o_array.object := o_array.null_object;
third_complement_array : o_array.object := o_array.null_object;
fourth_complement_array : o_array.object := o_array.null_object;
procedure put_place(a_place : in string) is
an_order : order.object;
begin
place_array := o_array.null_object;
first_complement_array := o_array.null_object;
second_complement_array := o_array.null_object;
third_complement_array := o_array.null_object;
fourth_complement_array := o_array.null_object;
order.put_place(an_order,moving_string.from_string(a_place));
o_array.put(place_array,an_order);
end;
procedure put_first_complement(a_complement : in string) is
an_order : order.object;
begin
if group_array.belong(a_complement) then
group_array.init(a_complement);
while not group_array.done (a_complement) loop
o_array.init(place_array);
while not o_array.done(place_array) loop
an_order := o_array.value(place_array);
order.put_first_complement(an_order,
moving_string.from_string(group_array.value(a_complement)));
o_array.put(first_complement_array,an_order);
o_array.next(place_array);
end loop;
group_array.next(a_complement);
end loop;
else
o_array.init(place_array)
while not o_array.done(place_array) loop
an_order := o_array.value(place_array);
order.put_first_complement(an_order,
moving_string.from_string(a_complement));
o_array.put(first_complement_array,an_order);
o_array.next(place_array);
end loop;
end if;
end;
procedure put_second_complement(a_complement : in string) is
an_order : order.object;
begin
if group_array.belong(a_complement) then
group_array.init(a_complement);
while not group_array.done (a_complement) loop
o_array.init(first_complement_array);
while not o_array.done(first_complement_array) loop
an_order := o_array.value(first_complement_array);
order.put_second_complement(an_order,
moving_string.from_string(group_array.value(a_complement)));
o_array.put(second_complement_array,an_order);
o_array.next(first_complement_array);
end loop;
group_array.next(a_complement);
end loop;
else
o_array.init(first_complement_array)
while not o_array.done(first_complement_array) loop
an_order := o_array.value(first_complement_array);
order.put_second_complement(an_order,
moving_string.from_string(a_complement));
o_array.put(second_complement_array,an_order);
o_array.next(first_complement_array);
end loop;
end if;
end;
procedure put_third_complement(a_complement : in string) is
an_order : order.object;
begin
if group_array.belong(a_complement) then
group_array.init(a_complement);
while not group_array.done (a_complement) loop
o_array.init(second_complement_array);
while not o_array.done(second_complement_array) loop
an_order := o_array.value(second_complement_array);
order.put_third_complement(an_order,
moving_string.from_string(group_array.value(a_complement)));
o_array.put(third_complement_array,an_order);
o_array.next(second_complement_array);
end loop;
group_array.next(a_complement);
end loop;
else
o_array.init(second_complement_array)
while not o_array.done(second_complement_array) loop
an_order := o_array.value(second_complement_array);
order.put_third_complement(an_order,
moving_string.from_string(a_complement));
o_array.put(third_complement_array,an_order);
o_array.next(second_complement_array);
end loop;
end if;
end;
procedure put_fourth_complement(a_complement : in string) is
an_order : order.object;
begin
if group_array.belong(a_complement) then
group_array.init(a_complement);
while not group_array.done (a_complement) loop
o_array.init(third_complement_array);
while not o_array.done(third_complement_array) loop
an_order := o_array.value(third_complement_array);
order.put_fourth_complement(an_order,
moving_string.from_string(group_array.value(a_complement)));
o_array.put(fourth_complement_array,an_order);
o_array.next(third_complement_array);
end loop;
group_array.next(moving_string.image(a_complement));
end loop;
else
o_array.init(third_complement_array)
while not o_array.done(third_complement_array) loop
an_order := o_array.value(third_complement_array);
order.put_fourth_complement(an_order,
moving_string.from_string(a_complement));
o_array.put(fourth_complement_array,an_order);
o_array.next(third_complement_array);
end loop;
end if;
end;
procedure show is
begin
text_io.put_line("Order Array :");
o_array.show(fourth_complement_array);
end;
procedure init is
begin
o_array.init(fourth_complement_array);
end;
procedure next is
begin
o_array.next(fourth_complement_array);
end;
function value return an_order is
begin
return o_array.value(fourth_complement_array);
end;
function done return boolean is
begin
return not o_array.done(fourth_complement_array);
end;
end;
with order,instruction_list; -- identifier
package coded_order is
type object is private;
procedure put(item : out object;an_order : in order.object;a_list : in instruction_list.object);
procedure run(item : in object);
procedure show(item : in object);
function the_order(item : in object) return order.object;
function key(item : in object) return string;
--function redirection(item : in object) return order.index_array;
--function order_to_code(an_order : in order.object) return integer;
--function code_to_key(code : in integer) return string;
--function order_to_key(an_order : in order.object) return string;
--function key_to_code(key : in string) return integer;
null_object : constant object;
private
type object is record;
--key : identifier.object :=identifier.null_object;
--redirection : order.index_array := order.null_index_array;
the_order : order.object := order.null_object;
list : instruction_list.object := instruction_list.null_object;
end record;
null_object := (
--key => identifier.null_object,
--redirection => order.null_index_array,
the_order=> order.null_object,
list =>instruction_list.null_object);
end;
with complement_array; --moving_string;
-- use moving_string;
package body coded_order is
--function order_to_code(an_order : in order.object) return integer is
--code : interger := 0;
--begin
--for i in order.index'first .. order.index'last-1 loop
--code := code + complement_array.index(order.complement(an_order,i))) * complement_array.max_element;
--end loop;
--code := code+order.complement(an_order,index'last);
--return code;
--end;
--function code_to_key(code : in integer) return string is
--ms : moving_string.object := moving_string.null_object;
--number : integer := code;
--begin
-- while number > 255 loop
-- ms:=ms & character'value(number mod 256);
-- number := number / 256;
-- end loop;
-- ms:=ms & character'value(number);
-- return moving_string.image(ms);
--end;
--function order_to_key(an_order : in order.object) return string is
--begin
--return code_to_key(order_to_code(an_order));
--end;
--function key_to_code(key : in string) return integer is
--number : integer :=0;
--begin
-- for a_character in key'first .. key'last-1 loop
-- number := number + character'val(a_character) * 256;
-- end loop;
-- return number + character'val(key(key'last));
--end;
procedure put(item : out object;an_order : in order.object;a_list : in instruction_list.object) is
--code : integer := order_to_code(an_order);
begin
item:=(
--key=>identifer.from_string(order_to_key),
--redirection=>order.redirection(an_order),
the_order => an_order,
list=>a_list);
end;
procedure run(item : in object) is
begin
intruction_list.run(item.list);
end;
procedure show(item : in object) is
begin
-- text_io.put_line("Order : Number : integer'image(key_to_code(item.key)));
text_io.put_line("A Coded Order :");
order.show(item.the_order);
instruction_list.show(item.list);
end;
function the_order(item : in object) return order.object is
begin
return item.the_order;
end;
--function redirection(item : in object) return order.index_array is
--begin
--return item.redirection;
--end;
function key(item : in object) return string is
begin
return order.image(item.the_order); -- attention si changement
-- car ca contient des blancs
-- return identifier.image(item.key);
end;
end;
with order,instruction_list;
package coded_order_array is
max_element : constant positive;
procedure put(an_order : in order.object;list : in instruction_list.object;ok : out boolean);
procedure run(an_order : in order.object;ok : out boolean);
--procedure run(place,first_complement,second_complement,
--third_complement,fourth_complement : in moving_string.object;ok : out boolean);
procedure show;
--function belong(an_order : in string) return boolean;
function belong(an_order : in order.object) return boolean;
--function redirection(an_order : in string) return order.index_array;
end;
with coded_order,the_order;
package body coded_order_array is
max_element : constant positive := 1000;
package o_array is new Generic_String_Sort_Array
(Element => coded_order.Object,
Max_Element_Number => max_element,
Null_Element => coded_order.Null_Object,
Get_Key => coded_order.key,
show_element => coded_order.show);
the_array : o_array.object := o_array.null_object;
procedure put(an_order : in order.object;list : in instruction_list.object;ok : out boolean) is
a_coded_order : object;
begin
coded_order.put(a_coded_order,an_order,list);
o_array.put(the_array,a_coded_order,ok);
end;
procedure run(an_order : in order.object;ok : out boolean) is
a_coded_order : object;
local_ok : boolean
begin
o_array.get(the_array,a_coded_order,order.image(an_order),local_ok);
if local_ok
the_order.put(coded_order.the_order(a_coded_order));
coded_order.run(a_coded_order);
ok := true;
else
ok:=false;
end if;
end;
--procedure run(place,first_complement,second_complement,
--third_complement,fourth_complement : in moving_string.object;ok : out boolean) is
--a_coded_order : coded_order.object;
--local_ok : boolean
--begin
-- o_array.get(the_array,a_coded_order,order_to_key(an_order),local_ok);
-- if local_ok
-- coded_order.run(a_coded_order);
-- ok := true;
-- else
-- ok:=false;
-- end if;
--end;
procedure show is
begin
text_io.put_line("Coded Order Array :");
o_array.show(the_array);
end;
function belong(an_order : in order.object) return boolean is
begin
return o_array.belong(the_array,order.image(an_order));
end;
--function redirection(an_order : in string) return order.index_array is
--a_coded_order : coded_order.object;
--local_ok : boolean
--begin
-- o_array.get(the_array,a_coded_order,order_to_key(an_order),local_ok);
-- if local_ok
-- return coded_order.redirection(a_coded_order);
-- else
-- return order.null_object;
--end if;
--end;
end;
with instruction_list;
package introduction_instructions is
procedure put(list : in instruction_list;object);
procedure run;
procedure show;
end;
package introduction_instructions is
the_list : instruction_list.object;
procedure put(list : in instruction_list;object) is
begin
the_list := list;
end;
procedure run is
begin
instruction_list.run(the_list);
end;
procedure show is
begin
instruction_list.show(the_list);
end;
end;
with instruction_list;
package pre_order_instructions is
procedure put(list : in instruction_list.object);
procedure run;
procedure show;
end;
package body pre_order_instructions is
the_list : instruction_list.object;
procedure put(list : in instruction_list;object) is
begin
the_list := list;
end;
procedure run is
begin
instruction_list.run(the_list);
end;
procedure show is
begin
instruction_list.show(the_list);
end;
end;
with instruction_list;
package post_order_instructions is
procedure put(list : in instruction_list;object);
procedure run;
procedure show;
end;
package body post_order_instructions is
the_list : instruction_list.object;
procedure put(list : in instruction_list;object) is
begin
the_list := list;
end;
procedure run is
begin
instruction_list.run(the_list);
end;
procedure show is
begin
instruction_list.show(the_list);
end;
end