|
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: 42427 (0xa5bb)
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«
└─⟦97791808e⟧
└─⟦this⟧
-- Index generic --
generic
with element_image(an_index : natural) return string;
package index is
type object is private;
procedure put (item : out object;an_index : in positive);
procedure show (item : in object);
function value(item : in object) return natural;
function image(item : in object) return string;
null_object : constant object;
private
type object is record
index : natural :=0;
end record;
null_object : constant object := (index =>0);
end;
package body index is
procedure put (item : out object;an_index : in positive) is
begin
item.object := an_index;
end;
procedure show (item : in object) is
begin
text_io.put_line("Index : " & image(item));
end;
function value(item : in object) return natural is
begin
return item.object;
end;
function image(item : in object) return string is
begin
return element_image(item.object);
end;
end;
-- Index Complement --
with index
package complement_index is
type object is private;
procedure put (item : out object;index : in positive);
procedure show (item : in object);
function value(item : in object) return natural;
function image(item : in object) return string;
null_object : constant object;
private
type object is record
object : natural :=0;
end record;
null_object : constant object := 0
end;
package body index is
procedure put (item : out object;an_index : in positive) is
begin
item.object := an_index;
end;
procedure show (item : in object) is
begin
text_io.put_line("Index : Value : " & image(item.object));
end;
function value(item : in object) return natural is
begin
return item.object;
end;
function image(item : in object) return string is
begin
return natural'image(item.object);
end;
end;
-- index list --
with index,exclusive_list_generic;
package index_list is
type object is private;
procedure put(list: in out object;complement : in positive;ok : out boolean);
procedure show(list :in object);
procedure init(list : in out object);
procedure next(list : in out object);
function value(list : in object) return positive;
function done(list : in object) return boolean;
null_object : constant object;
private
package i_list is new exclusive_list_generic (element => index.object,
null_element=>index.null_object,
show_element=>index.show,
element_image=>index.image);
null_iterator : i_list.iterator;
type object is record
object : i_list.list := i_list.null_object;
iterator : i_list.iterator := null_iterator;
end record;
null_object : constant object := (list => i_list.null_object,
iterator => null_iterator);
end;
with Text_Io;
package body index_list is
procedure put(list : in out object;complement : in positive;ok : out boolean) is
local_ok : boolean := false;
an_index := index.object;
begin
index.put(an_index,complement);
init(list);
while not done(list) and not local_ok loop
local_ok := value(list) = an_index;
next(list);
end loop;
if not local_ok then
i_list.make(an_index,list.object);
end if;
ok:= not local_ok;
end;
procedure show(list :in object) is
iterator : positive_list.iterator;
begin
text_io.put_line("Index List : ");
i_list.show(list.object);
end;
procedure init(list : in out object) is
begin
i_list.init(list.iterator,list.object);
end;
procedure next(list : in out object) is
begin
i_list.next(list.iterator);
end;
function value(list : in object) return positive is
begin
return index.value(i_list.value(list.iterator));
end;
function done(list : in object) return boolean is
begin
return i_list.done(list.iterator);
end;
end;
-- Animate List --
package Animate_list is
procedure put(animate_index : in positive;ok : out boolean);
procedure show;
procedure init;
procedure next;
function value return positive;
function done return boolean;
end;
with Text_Io,index,complement_identifier_array;
package body animate_list is
animate_index is new index(element_image => complement_identifier.image);
-- avec le zero !!!!!!!!!!!
animate_index_list is new exclusive_list_generic (element => animate_index.object,
null_element=>animate_index.null_object,
show_element=>animate_index.show,
element_image=>animate_index.image);
the_list : animate_index_list.object := index_list.null_object;
the_iterator : animate_list.iterator;
procedure put(animate_index : in positive;ok : out boolean) is
iterator : animate_list.iterator;
an_index := animate_index.object;
local_ok : boolean := false;
begin
animate_index.put(an_index,animate_index);
animate_list.init(iterator,the_list); -- voir exclusive list
while not done(iterator) and not local_ok loop
local_ok := value(iterator) = an_index;
animate_list.next(iterator);
end loop;
if not local_ok then
animate_list.make(an_index,list.object); ?????????????
end if;
ok:= not local_ok;
end;
procedure show is
begin
text_io.put_line("Animate List :");
animate_list.show(the_list);
end;
procedure init is
begin
animate_list.init(the_iterator,the_list); -- voir ordre
end;
procedure next is
begin
animate_list.next(the_iterator);
end;
function value return positive is
begin
return animate_list.value(the_iterator);
end;
function done return boolean is
begin
return animate_list.done(the_iterator);
end;
end;
-- message array --
with identifier;
package Message_Array is
procedure Put (message : in identifier.object;ok :out boolean);
procedure Get (message : out identifier.object;key : in natural;ok :out boolean);
function number_of return natural;
procedure show;
end;
with generic_string_sort_array;
package body message_array is
package mess_array is new Generic_String_Sort_Array
(Element => identifier.Object,
Max_Element_Number => 30,
Null_Element => identifier.Null_Object,
Get_Key => identifier.Name,
show_element => identifier.show;
the_array : mess_array.object := mess_array.null_object;
procedure Put (message : in identifier.object;ok :out boolean) is
begin
mess_array.put(the_array,message,ok);
end;
procedure Get (message : out identifier.object;key : in natural;ok :out boolean) is
begin
mess_array.get(the_array,message,key,ok);
end;
function number_of return natural;
begin
return mess_array.number_of(the_array);
end;
procedure show is
begin
text_io.put_line("Message Array :");
mess_array.show(the_array);
end;
end;
-- group --
with identifier,index_list;
package group is
type object is private;
procedure put_name(item : in out object;name : in identifier.object);
procedure put_subject(item : in out object;subject_index : in positive;ok : out boolean);
procedure show(item :in object);
function name(item : in object) return string;
procedure list_init(item : in out object);
procedure list_next(item : in out object);
function list_value(item : in object) return positive;
function list_done(item : in object) return boolean;
null_object : constant object;
private
type object is record
name : identifier.object := identifier.null_object;
the_list : index_list.object := index_list.null_object;
end record;
null_object : constant object := (name => identifier.null_object,
the_list => index_list.null_object);
end;
with Text_Io;
package body group is
procedure put_name(item : in out object;name : in identifier.object) is
begin
item.name:=name;
end;
procedure put_subject(item : in out object;subject_index : in positive;ok : out boolean) is
begin
index_list.put(item.the_list,subject_index,ok);
end;
function name(item : in object) return string is
begin
return identifier.image(item.name);
end;
procedure show(item :in object) is
begin
text_io.put_line ("Group : Name : " & name(item));
index_list.show(item.the_list);
end;
procedure list_init(item : in out object) is
begin
index_list.init(item.the_list);
end;
procedure list_next(item : in out object) is
begin
index_list.next(item.the_list);
end;
function list_value(item : in object) return positive is
begin
return index_list.value(item.the_list);
end;
function list_done(item : in object) return boolean is
begin
return index_list.done(item.the_list);
end;
end;
package group_Array is
max_element : constant positive;
procedure Put (group_name : in identififer.object;subject_index : in positive;ok :out boolean);
procedure show;
procedure list_init(group_name : in string);
procedure list_next(group_name : in string);
function list_value(group_name : in string) return natural;
function list_done(group_name : in string) return boolean;
function belong(group_name : in string) return boolean;
end;
with text_io,group,generic_string_sort_array;
package body group_array is
max_element : constant positive := 200;
package g_array is new Generic_String_Sort_Array
(Element => group.Object,
Max_Element_Number => max_element,
Null_Element => group.Null_Object,
Get_Key => group.Name,
show_element => group.show;
the_array : g_array.object := g_array.null_object;
procedure Put (group_name : in identifier.object;subject_index : in positive;ok :out boolean) is
a_group : group.object;
local_ok:boolean;
begin
g_array.get(the_array,a_group,identifier.image(group_name),local_ok);
if not local_ok then
group.put_name(a_group,group_name);
end if;
group.put_complement(a_group,subject_index,local_ok);
if local_ok then
g_array.put(the_array,a_group);
end if;
ok:=local_ok;
end;
procedure show is
begin
text_io.put_line("Group Array :");
g_array.show(the_array);
end;
procedure list_init(group_name : in string) is
a_group : group.object;
local_ok : boolean;
begin
g_array.get(the_array,a_group,group_name,local_ok);
if local_ok then
group.list_init(a_group);
end if;
end;
procedure list_next(group_name : in string) is
a_group : group.object;
local_ok : boolean;
begin
g_array.get(the_array,a_group,group_name,local_ok);
if local_ok then
group.list_next(a_group);
end if;
end;
function list_value(group_name : in string) return natural is
a_group : group.object;
local_ok : boolean;
begin
g_array.get(the_array,a_group,group_name,local_ok);
if local_ok then
return group.list_value(a_group);
else
return 0;
end if;
end;
function list_done(group_name : in string) return boolean is
a_group : group.object;
local_ok : boolean;
begin
g_array.get(the_array,a_group,group_name,local_ok);
if local_ok then
return group.list_done(a_group);
else
return true;
end if;
end;
function belong(group_name : in string) return boolean is
begin
return g_array.belong(the_array,group_name);
end;
end;
-- complement --
with field,link,identifier,generic_string_sort_array,list_generic,
exclusive_generic_list;
package complement is
type complement_kind is (animate,place,entity,word,verb,unknown);
type object(kind : every_kind := unknown) is private;
procedure copy(input_item: in object;output_object : out object);
procedure put_name(item : in out object;name : in identifier.object;ok : out boolean);
procedure put_word(item : out object;word : in identifier.object);
procedure put_verb(item : out object;verb : in identifier.object;number : in positive);
--procedure create_number_field(item : out object;field_name: in string; ok : out boolean);
--procedure create_sentence_field(item : out object;field_name: in string; ok : out boolean);
--procedure create_enumerate_field(item : out object;field_name: in string; ok : out boolean);
--procedure field_Put_number (Item : in out Object;field_name: in string;number : in integer; ok : out boolean);
--procedure field_Put_sentence (Item : in out Object;field_name: in string;sentence : in string; ok : out boolean);
--procedure field_Put_enumerate (Item : in out Object;field_name: in string;enumeration,literal : in positive; ok : out boolean);
procedure create_number_field(item : out object;field_index: in positive; ok : out boolean);
procedure create_sentence_field(item : out object;field_index: in positive; ok : out boolean);
procedure create_enumerate_field(item : out object;field_index: in positive; ok : out boolean);
procedure field_Put_number (Item : in out Object;field_index: in positive;number : in integer; ok : out boolean);
procedure field_Put_sentence (Item : in out Object;field_index: in positive;sentence : in string; ok : out boolean);
procedure field_Put_enumerate (Item : in out Object;field_index: in positive;enumeration,literal : in positive; ok : out boolean);
procedure put_movement(item : in out object;place : in positive);
procedure movement_init(item : in out object); dans corps
procedure move(item : in out object);
procedure put_exit(item : in out object;name,start_place,start_direction,
next_place,next_direction : in positive;ok : out boolean);
--procedure put_exit(item : in out object;name,start_place,start_direction,
--next_place,next_direction : in positive;ok : out boolean);
--procedure exit_put_enumerate(item : in out object;enumeration,literal: in positive;ok : out boolean);
function exit_exist(item : in out object;direction : in positive) return boolean;
function exits_exist(item : in object) return boolean;
--function exit_enumeration(item : in out object;direction : in positive) return natural;
--function exit_literal(item : in out object;direction : in positive) return natural;
function exit_name(item : in out object;direction : in positive) return natural;
function next_place(item : in out object;direction : in positive) return natural;
function next_direction(item : in out object;direction : in positive) return natural;
procedure put_place(item : in out object;place : in natural;ok : out boolean);
procedure show(item :in object);
procedure list_exits_init(item : in out object);
procedure list_exits_next(item : in out object);
function list_exits_name(item : in out object) return natural;
function list_exits_done(item : in out object) return boolean;
--------------------------
procedure put_group(item : in out : object;an_index : in positive;ok : out boolean);
procedure list_group_init(item : in out object);
procedure list_group_next(item : in out object);
function list_group_name(item : in out object) return string; -- pour list_exits_value aussi string !!!
function list_group_done(item : in out object) return boolean;
----------------------------
--function field_is_a_number (item : in object;field_name : in string) return boolean;
--function field_is_a_sentence (item : in object;field_name : in string) return boolean;
--function field_is_an_enumerate (item : in object;field_name : in string) return boolean;
--function field_exist (item : in object;field_name : in string) return boolean;
function field_is_a_number (item : in object;field_index : in positive) return boolean;
function field_is_a_sentence (item : in object;field_index : in positive) return boolean;
function field_is_an_enumerate (item : in object;field_index : in positive) return boolean;
function field_exist (item : in object;field_index : in positive) return boolean;
function is_a_subject(item : in object) return boolean;
function is_an_animate(item : in object) return boolean;
function is_a_place(item : in object) return boolean;
function is_an_entity(item : in object) return boolean;
function is_a_word(item : in object) return boolean;
function is_a_verb(item : in object) return boolean;
function name (item : in object) return string;
function place (item : in object) return natural;
--function field_number (Item : in Object,field_name:in string) return Integer;
--function field_sentence (Item : in Object,field_name:in string) return String;
--function field_Enumeration (Item : in Object,field_name:in string) return Natural;
--function field_Literal (Item : in Object,field_name:in string) return Natural;
function field_number (Item : in Object,field_index:in positive) return Integer;
function field_sentence (Item : in Object,field_index:in positive) return String;
function field_Enumeration (Item : in Object,field_index:in positive) return Natural;
function field_Literal (Item : in Object,field_index:in positive) return Natural;
function verb_number (Item : in Object) return natural;
null_object : constant object;
animate_object : constant object;
place_object : constant object;
entity_object : constant object;
private
--package field_array is new generic_string_sort_array(
-- element =>field.object,
-- max_element_number =>10,
-- null_element => field.null_object,
-- element_image => field.image,
-- get_key =>field.name);
----------------
mettre group_id_array au debut
group_index is new index(element_image => group_identifier.image);
-- avec le zero !!!!!!!!!!!
animate_index_list is new exclusive_list_generic (element => group_index.object,
null_element=>group_index.null_object,
show_element=>group_index.show,
element_image=>group_index.image);
-----------------
package group_list is new exclusive_list_generic (element => field.object,
null_element=>field.null_object,
show_element=>field.show,
get_key=>field.index);
package place_list is new list_generic (element => positive);
package link_list is new list_generic (element => link.object,
null_element=>link.null_object,
show_element=>link.show,
get_key=>link.key);
null_trip_iterator : place_list.iterator; -- tester dans boucle
null_exits_iterator : link_list.iterator;
----------------
null_group_iterator : group_list.iterator;
----------------
type object(kind : complement_kind := unknown) is record
the_group_list : group_list.object := group_list.null_object;
the_group_iterator : group_list.iterator := group_list.null_group_iterator;
case kind is
------------------
when animate =>
animate_name : identifier.object := idenfitifier.null_object;
-- animate_fields : field_array.object := field_array.null_object;
animate_fields : field_list.list := field_list.null_object;
animate_place : natural :=0;
trip : place_list.list := place_list.nil;
trip_iterator : place_list.iterator := null_trip_iterator ;
--------------
when place =>
place_name : identifier.object := idenfitifier.null_object;
-- place_fields : field_array.object := field_array.null_object;
place_fields : field_list.list := field_list.nuLL_object;
exits : link_list.list :=link_list.nil;
exits_iterator : link_list.iterator :=null_exits_iterator;
--------------
when entity =>
entity_name : identifier.object := idenfitifier.null_object;
-- entity_fields : field_array.object := field_array.null_object;
entity_fields : field_list.list := field_list.null_object;
entity_place : natural :=0;
--------------
when word =>
word_value : identifier.object := idenfitifier.null_object;
--------------
---------------
when verb =>
verb_name : identifier.object := identifier.null_object;
plus de number ou synonyme !!!!!!!!!
-----------------
when unknown =>
null;
end case;
end record;
null_object : constant object := (kind => unknown);
animate_object : constant object, := (kind =>animate,
animate_name =>idenfitifier.null_object,
-- animate_fields => field_array.null_object,
animate_fields => field_list.null_object,
animate_place =>0,
trip => place_list.nil,
trip_iterator =>null_trip_iterator);
place_object : constant object := (kind=>place,
place_name => idenfitifier.null_object,
-- place_fields => field_array.null_object,
place_fields => field_list.null_object,
exits =>link_list.null_object,
exits_iterator =>null_exits_iterator);
entity_object : constant object := (kind =>entity,
entity_name =>idenfitifier.null_object,
-- entity_fields => field_array.null_object,
entity_fields => field_list.null_object,
entity_place =>0);
end;
with Text_Io;
package body complement is
procedure copy(input_item: in object;output_item : out object) is
begin
output_item:=input_item;
case item.kind is
when animate =>
--output_item := (kind =>animate,
-- animate_name =>input_item.animate_name,
-- animate_fields => field_array.null_object,
-- animate_fields => field_list.null,
-- animate_place => input_item.animate_place,
-- trip => place_list.nil,
-- trip_iterator =>null_trip_iterator);
field_list.free(output_item.animate_fields);
field_list.copy(input_item.animate_fields,output_item.animate_fields);
when place =>
-- output_item := (kind=>place,
-- place_name => input_item.place_name,
-- place_fields => field_array.null_object,
-- place_fields => field_list.nil,
-- exits =>link_list.nil,
-- exits_iterator =>null_exits_iterator);
field_list.free(output_item.place_fields);
field_list.copy(input_item.place_fields,output_item.place_fields);
-- field_list.free(output_item.exist);
-- field_list.copy(input_item.exits,output_item.exits);
when entity =>
-- output_item := (kind =>entity,
-- entity_name =>input_item.entity_name,
-- entity_fields => field_array.null_object,
-- entity_fields => field_list.nil,
-- entity_place => input_item.entity_place);
field_list.free(output_item.entity_fields);
field_list.copy(input_item.entity_fields,output_item.entity_fields);
when word | verb | unknown =>
null;
end case;
end;
procedure put_name(item : in out object;name : in identifier.object;ok : boolean) is
begin
ok := true;
case item.kind is
when animate =>
item.animate_name:=name;
when place =>
item.place_name:=name;
when entity =>
item.entity_name:=name;
when word | verb | unknown =>
ok := false;
end case;
end;
procedure put_word(item : out object;word : in identifier.object) is
begin
item := (kind=>word,word_value=>word);
end;
procedure put_verb(item : out object;verb : in identifier.object;number : in positive) is
begin
item := (kind=>verb,verb_name=>verb,number=>number);
end;
--procedure get_field(item : in out object;a_field : out field.object;field_name:in string; ok : out boolean) is
--begin
-- case item.kind is
-- when animate =>
-- field_array.get(item.animate_fields,a_field,field_name,ok);
-- when place =>
-- field_array.get(item.place_fields,a_field,field_name,ok);
-- when entity=>
-- field_array.get(item.entity_fields,a_field,field_name,ok);
-- when word | verb | unknown=>
-- ok := false;
-- end case;
--end;
procedure get_fields(item : in object;list : out field_list;ok : out boolean) is
begin
ok:=true;
case item.kind is
when animate =>
list := item.animate_fields;
when place =>
list := item.place_fields;
when entity=>
list := item.entity_fields;
when word | verb | unknown=>
ok := false;
end case;
end;
--procedure get_field(item : in object;a_field : out field.object;field_name: in string; ok : out boolean) is
procedure get_field(item : in object;a_field : out field.object;field_index: in positive; ok : out boolean) is
list : field_list;
local_ok : boolean;
begin
get_fields(item,list,local_ok);
if local_ok then
field_list.get(list,a_field,natural'image(field_index),ok);
else
ok:=false;
end if;
end;
procedure put_field(item : in object;a_field : out field.object) is
list : field_list;
local_ok : boolean;
begin
get_fields(item,list,local_ok);
if local_ok then
field_list.put(list,a_field);
end if;
end;
--procedure put_field(item : in out object;a_field : in field.object) is
--begin
-- case item.kind is
-- when animate =>
-- field_array.put(item.animate_fields,a_field);
-- when place =>
-- field_array.put(item.place_fields,a_field);
-- when entity=>
-- field_array.put(item.entity_fields,a_field);
-- when word | verb | unknown=>
-- null;
-- end case;
--end;
-- procedure create_number_field(item : out object;field_name: in string; ok : out boolean) is
procedure create_number_field(item : out object;field_index: in positive; ok : out boolean) is
a_field : field.object;
begin
-- if is_a_subject(item) and not field_exist(item,field_name) then
if is_a_subject(item) and not field_exist(item,field_index) then
-- field.create_number(a_field,field_name);
field.create_number(a_field,field_index);
put_field(item,a_field);
ok:=true;
else
ok:=false;
end if;
end;
-- procedure create_sentence_field(item : out object;field_name: in string; ok : out boolean);
procedure create_sentence_field(item : out object;field_index: in positive; ok : out boolean);
a_field : field.object;
begin
-- if is_a_subject(item) and not field_exist(item,field_name) then
if is_a_subject(item) and not field_exist(item,field_index) then
-- field.create_sentence(a_field,field_name);
field.create_sentence(a_field,field_index);
put_field(item,a_field);
ok:=true;
else
ok:=false;
end if;
end;
-- procedure create_enumerate_field(item : out object;field_name: in string; ok : out boolean);
procedure create_enumerate_field(item : out object;field_index: in positive; ok : out boolean);
a_field : field.object;
begin
-- if is_a_subject(item) and not field_exist(item,field_name) then
if is_a_subject(item) and not field_exist(item,field_name) then
-- field.create_enumerate(a_field,field_name);
field.create_enumerate(a_field,field_index);
put_field(item,a_field);
ok:=true;
else
ok:=false;
end if;
end;
-- procedure field_Put_number (Item : in out Object;field_name: in string;number : in integer; ok : out boolean);
procedure field_Put_number (Item : in out Object;field_index: in positive;number : in integer; ok : out boolean);
a_field : field.object;
local_ok : boolean;
begin
-- get_field(item,a_field,field_name,local_ok);
get_field(item,a_field,field_index,local_ok);
if local_ok then
field.put_number(a_field,number,local_ok);
if local_ok then
put_field(item,a_field);
end if;
end if;
ok:=local_ok;
end;
-- procedure field_Put_sentence (Item : in out Object;field_name: in string;sentence : in string; ok : out boolean);
procedure field_Put_sentence (Item : in out Object;field_index: in positive;sentence : in string; ok : out boolean);
a_field : field.object;
local_ok : boolean;
begin
-- get_field(item,a_field,field_name,local_ok);
get_field(item,a_field,field_index,local_ok);
if local_ok then
field.put_sentence(a_field,sentence,local_ok);
if local_ok then
put_field(item,a_field);
end if;
end if;
ok:=local_ok;
end;
-- procedure field_Put_enumerate (Item : in out Object;field_name: in string;enumeration,literal : in positive; ok : out boolean);
procedure field_Put_enumerate (Item : in out Object;field_index: in positive;enumeration,literal : in positive; ok : out boolean);
a_field : field.object;
local_ok : boolean;
begin
-- get_field(item,a_field,field_name,local_ok);
get_field(item,a_field,field_index,local_ok);
if local_ok then
field.put_enumerate(a_field,enumeration,literal,local_ok);
if local_ok then
put_field(item,a_field);
end if;
end if;
ok:=local_ok;
end;
procedure put_movement(item : in out object;place : in positive) is
begin
if item.kind = animate then
place_list.make(place,item.trip);
end if;
end;
procedure movement_init(item : in out object) is
-- utile ?? --
begin
if item.kind = animate then
place_list.init(item.trip_iterator,item.trip);
end if;
end;
procedure move(item : in out object) is
begin
if item.kind = animate then
if not place_list.done(item.trip_iterator);
item.animate_place:=place_list.value(item.trip_iterator);
place_list.next(item.trip_iterator);
else
place_list.init(item.trip_iterator,item.trip);
-- item.animate_place:=place_list.value(item.trip_iterator);
-- pb si liste vide !!
end if;
end if;
end;
function exit_exist(item: in object;direction : in positive) return boolean is
begin
if item.kind = place then
return link_list.belong(item.exits,positive'image(direction));
else
return false;
end if;
end;
function exits_exist(item : in object) return boolean is
begin
if item.kind = place then
return not link_list.is_empty(item.exits);
else
return false;
end if;
end;
procedure put_exit(item : in out object;name,start_place,start_direction,
next_place,next_direction : in positive;ok : out boolean) is
a_link : link.object;
local_ok : boolean;
begin
if not exit_exist (item,start_direction) then
link.put(a_link,name,start_place,start_direction,next_place,next_direction);
link_list.put(item.exits,a_link);
ok := true;
else
ok := false;
end if;
end;
--procedure put_exit(item : in out object;name,start_place,start_direction,
--next_place,next_direction : in positive;ok : out boolean);
--a_link : link.object;
--begin
-- if item.kind = place then
-- link.put_name(a_link,name);
-- link.put_start_escape(a_link,start_place,start_direction);
-- link.put_next_escape(a_link,next_place,next_direction);
-- link_list.put(item.exits,a_link,ok);
-- else
-- ok:=false;
-- end if;
--end;
--procedure exit_put_enumerate(item : in out object;direction,numeration,literal: in positive;ok : out boolean);
--a_link : link.object;
--local_ok : boolean;
--begin
-- found_link(item,a_link,direction,local_ok);
-- if local_ok then
-- link.put_enumerate(a_link,enumeration,literal);
-- link_list.put(item.exits,a_link);
-- ok:=true;
-- else
-- ok := false;
--end if;
--end;
function exit_enumeration(item : in out object;direction : in positive) return natural is
a_link : link.object;
local_ok : boolean;
begin
found_link(item,a_link,direction,local_ok);
if local_ok then
return link.enumeration(a_link);
else
return 0;
end if;
end;
function exit_literal(item : in out object;direction : in positive) return natural is
a_link : link.object;
local_ok : boolean;
begin
found_link(item,a_link,direction,local_ok);
if local_ok then
return link.literal(a_link);
else
return 0;
end if;
end;
function exit_name(item : in out object;direction : in positive) return natural is
a_link : link.object;
local_ok : boolean;
begin
if item.kind = place then
link_list.get(item.exits,a_link,positive'image(direction),local_ok);
if local_ok then
return link.name(a_link);
else
return 0;
end if;
return 0;
end if;
end;
function next_place(item : in out object;direction : in positive) return natural is
a_link : link.object;
local_ok : boolean;
begin
if item.kind = place then
link_list.get(item.exits,a_link,positive'image(direction),local_ok);
if local_ok then
return link.next_place(a_link);
end if;
end if;
return 0;
end;
function next_direction(item : in out object;direction : in positive) return natural is
a_link : link.object;
local_ok : boolean;
begin
if item.kind = place then
link_list.get(item.exits,a_link,positive'image(direction),local_ok);
if local_ok then
return link.direction_place(a_link);
else
end if;
end if;
return 0;
end;
procedure put_place(item : in out object;place : in natural;ok : out boolean) is
begin
if item.kind = animate then
item.animate_place:=place;
ok:= true;
elsif item.kind = entity then
item.entity_place:=place;
ok:=true;
else
ok := false;
end if;
end;
procedure show(item :in object) is
trip_iterator : place_list.iterator;
begin
text_io.put("Complement : Kind : " & complement_kind'image(item.kind));
case item.kind is
when animate =>
text_io.put_line (" Name : " & name(item) & " Place : " & natural'image(place(item));
field_list.show(item.animate_fields);
place_list.init(trip_iterator,item.trip);
while not place_list.done(trip_iterator) loop
put(positive'image(place_list.value(trip_iterator)) & ", ");
place_list.next(trip_iterator);
end loop;
new_line;
when place =>
text_io.put_line (" Name : " & name(item));
field_list.show(item.place_fields);
link_list.show(item.exits);
when entity =>
text_io.put_line (" Name : " & name(item) & " Place : " & natural'image(place(item));
field_list.show(item.entity_fields);
when word =>
text_io.put_line (" Name : " & name(item));
when verb =>
text_io.put_line(" Name : " & name(item) & " Number : " & natural'image(number(item));
when unknown =>
new_line;
end case;
end if;
end;
procedure list_exits_init(item : in out object) is
begin
if item.kind = place then
link_list.init(item.exits_iterator,item.exits);
end if;
end;
procedure list_exits_next(item : in out object) is
begin
if item.kind = place then
link_list.next(item.exits_iterator);
end if;
end;
function list_exits_name(item : in out object) return natural is
begin
if item.kind = place then
return link.name(link_list.value(item.exits_iterator));
else
return 0;
end if;
end;
function list_exits_done(item : in out object) return boolean is
begin
if item.kind = place then
return link_list.done(item.exits_iterator);
else
return true;
end if;
end;
-------------------------
procedure put(item : in out object;an_index : in positive;ok : out boolean) is
iterator : group_list.iterator;
an_index := group_index.object;
local_ok : boolean := false;
begin
group_index.put(an_index,group_index);
group_list.init(iterator,item.the_group_list); -- voir exclusive list
while not done(iterator) and not local_ok loop
local_ok := value(iterator) = an_index;
group_list.next(iterator);
end loop;
if not local_ok then
group_list.make(an_index,item.the_group_list); -- ???????????
end if;
ok:= not local_ok;
end;
procedure show is
begin
text_io.put_line("group List :");
group_list.show(item.the_group_list);
end;
procedure init is
begin
group_list.init(item.the_group_iterator,item.the_group_list); -- voir ordre
end;
procedure next is
begin
group_list.next(item.the_group_iterator);
end;
function value return positive is
begin
return group_list.value(item.the_group_iterator);
end;
function done return boolean is
begin
return group_list.done(the_iterator);
end;
----------------------------
--function field_is_a_number (item : in object;field_name : in string) return boolean is
function field_is_a_number (item : in object;field_index : in positive) return boolean is
a_field : field.object;
local_ok : boolean;
begin
-- get_field(item,a_field,field_name,local_ok);
get_field(item,a_field,field_index,local_ok);
if local_ok then
return field.is_a_number(a_field);
else
return false;
end if;
end;
--function field_is_a_sentence (item : in object;field_name : in string) return boolean is
function field_is_a_sentence (item : in object;field_index : in positive) return boolean is
a_field : field.object;
local_ok : boolean;
begin
-- get_field(item,a_field,field_name,local_ok);
get_field(item,a_field,field_index,local_ok);
if local_ok then
return field.is_a_sentence(a_field);
else
return false;
end if;
end;
--function field_is_an_enumerate (item : in object;field_name : in string) return boolean is
function field_is_an_enumerate (item : in object;field_index : in positive) return boolean is
a_field : field.object;
local_ok : boolean;
begin
-- get_field(item,a_field,field_name,local_ok);
get_field(item,a_field,field_index,local_ok);
if local_ok then
return field.is_an_enumerate(a_field);
else
return false;
end if;
end;
--function field_exist (item : in object;field_name : in string) return boolean is
--begin
-- case item.kind is
-- when animate =>
-- return field_array.belong(item.animate_fields,field_name);
-- when place =>
-- return field_array.belong(item.place_fields,field_name);
-- when entity=>
-- return field_array.belong(item.entity_fields,field_name);
-- when word | unknown=>
-- return false;
-- end case;
--end;
--function field_exist (item : in object;field_name : in string) return boolean is
function field_exist (item : in object;field_index : in natural) return boolean is
list : field_list;
local_ok : boolean;
begin
get_fields(item,list,local_ok);
if local_ok then
-- return field_list.belong(list,field_name);
return field_list.belong(list,natural'image(field_index));
else
return false;
end if;
end;
function is_a_subject(item : in object) return boolean is
begin
return item.kind = animate or item.kind = place or item.kind = entity;
end;
function is_an_animate(item : in object) return boolean is
begin
return item.kind = animate;
end;
function is_a_place(item : in object) return boolean is
begin
return item.kind = place;
end;
function is_an_entity(item : in object) return boolean is
begin
return item.kind = entity;
end;
function is_a_word(item : in object) return boolean;
begin
return item.kind = word;
end;
function is_a_verb(item : in object) return boolean;
begin
return item.kind = verb;
end;
function name (item : in object) return string is
begin
case item.kind is
when animate =>
return identifier.image(item.animate_name);
when place=>
return identifier.image(item.place_name);
when entity=>
return identifier.image(item.entity_name);
when word =>
return identifier.image(item.word_value);
when verb =>
return identifier.image(item.verb_name);
when unknown =>
return "";
end case;
end;
function place(item : in object) return natural is
begin
case item.kind is
when animate =>
return item.animate_place,
when entity =>
return item.entity_place;
when place|word|unknown =>
return 0;
end case;
end;
--function field_number (Item : in Object,field_name:in string) return Integer is
function field_number (Item : in Object,field_index:in positive) return Integer is
a_field : field.object;
local_ok boolean;
begin
-- get_field(item,a_field,field_name,local_ok);
get_field(item,a_field,field_index,local_ok);
if local_ok then
return field.number(a_field);
else
return 0;
end if;
end;
--function field_sentence (Item : in Object,field_name:in string) return String is
function field_sentence (Item : in Object,field_index:in positive) return String is
a_field : field.object;
local_ok : boolean;
begin
-- get_field(item,a_field,field_name,local_ok);
get_field(item,a_field,field_index,local_ok);
if local_ok then
return field.sentence(a_field);
else
return "";
end if;
end;
--function field_Enumeration (Item : in Object,field_name:in string) return Natural is
function field_Enumeration (Item : in Object,field_index:in string) return Natural is
a_field : field.object;
local_ok : boolean;
begin
-- get_field(item,a_field,field_name,local_ok);
get_field(item,a_field,field_index,local_ok);
if local_ok then
return field.enumeration(a_field);
else
return 0;
end if;
end;
--function field_Literal (Item : in Object,field_name:in string) return Natural is
function field_Literal (Item : in Object,field_index:in positive) return Natural is
a_field : field.object;
local_ok : boolean;
begin
-- get_field(item,a_field,field_name,local_ok);
get_field(item,a_field,field_index,local_ok);
if local_ok then
return field.literal(a_field);
else
return 0;
end if;
end;
function verb_number (item : in object) return natural is
begin
if item.kind = verb then
item.number;
else
return 0;
end if;
end;
local_ok : boolean;
begin
--create_sentence (animate_object,"nom",local_ok);
--put_sentence(animate_object,"nom","anime",local_ok);
create_sentence (animate_object,"description",local_ok);
put_sentence(animate_object,"description","Ca bouge !",local_ok);
--create_sentence (place_object,"nom",local_ok);
--put_sentence(place_object,"nom","lieu",local_ok);
create_sentence (place_object,"description",local_ok);
put_sentence(place_object,"description","C'est une piece !",local_ok);
--create_sentence (entity_object,"nom",local_ok);
--put_sentence(entity_object,"nom","entite",local_ok);
create_sentence (entity_object,"description",local_ok);
put_sentence(entity_object,"description","C'est un objet !",local_ok);
end;
end;
with idemtifer,complement;
package Complement_array is
max_element : constant positive;
procedure put(a_complement: in complement.object;name : in identifier.object; ok : out boolean);
procedure put_word(word : in identifier.object);
procedure put_verb(verb : in identifier.object;number : in positive);
--procedure create_number_field(subject_index : in natural;field_name: in string; ok : out boolean);
--procedure create_sentence_field(subject_index : in natural;field_name: in string; ok : out boolean);
--procedure create_enumerate_field(subject_index : in natural;field_name: in string; ok : out boolean);
--procedure field_Put_number (subject_index : in natural;field_name: in string;number : in integer; ok : out boolean);
--procedure field_Put_sentence (subject_index : in natural;field_name: in string;sentence : in string; ok : out boolean);
--procedure field_Put_enumerate (subject_index : in natural;field_name: in string;enumeration,literal : in positive; ok : out boolean);
procedure create_number_field(subject_index : in natural;field_index : in positive; ok : out boolean);
procedure create_sentence_field(subject_index : in natural;field_index : in positive; ok : out boolean);
procedure create_enumerate_field(subject_index : in natural;field_index : in positive; ok : out boolean);
procedure field_Put_number (subject_index : in natural;field_index : in positive;number : in integer; ok : out boolean);
procedure field_Put_sentence (subject_index : in natural;field_index : in positive;sentence : in string; ok : out boolean);
procedure field_Put_enumerate (subject_index : in natural;field_index : in positive;enumeration,literal : in positive; ok : out boolean);
procedure put_movement(animate_name: in string;place : in positive);
procedure movement_init(animate_index : in natural);
procedure move(animate_index : in natural);
procedure put_exit(place_index : in natural;name,start_place,start_direction,
next_place,next_direction: in positive;ok : out boolean);
--procedure put_exit(place_index : in natural;name,start_place,start_direction,
--next_place,nexde_ind