|
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: 103365 (0x193c5) 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« └─⟦074e106c0⟧ └─⟦this⟧
-- Index -- package 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_list; package body animate_list is the_list : index_list.object := index_list.null_object; procedure put(animate_index : in positive;ok : out boolean) is begin index_list.put(the_list,animate_index,ok); end; procedure show is begin text_io.put_line("Animate List :"); index_list.show(the_list); end; procedure init is begin index_list.init(the_list); end; procedure next is begin index_list.next(the_list); end; function value return positive is begin return index_list.value(the_list); end; function done return boolean is begin return index_list.done(the_list); end; end; -- Total Actions -- package total_actions is procedure add_one; procedure show; function number return natural; end; with text_io; package body total_actions is the_number_of_actions : natural := 0; procedure add_one is begin the_number_of_actions := the_number_of_actions + 1; end; procedure show is begin text_io.put_line("Total Actions : " & natural'image(the_number_of_actions)); end; function number return natural is begin return the_number_of_actions; end; -- the hero -- package the_hero is procedure put(entity_index: in positive); procedure show; function index return natural; end; with text_io; package body the_hero is the_hero_index : natural := 0; procedure put(entity_index: in positive) is begin the_hero_index := entity_index; end; procedure show is begin text_io.put_line("The Hero : " & natural'image(the_hero_index)); end; function index return natural is begin return the_hero_index; end; -- the place -- package the_place is procedure put(place_index: in positive); procedure show; function index return natural; end; with text_io; package body the_place is the_place_index : natural := 0; procedure put(place_index: in positive) is begin the_place_index := place_index; end; procedure show is begin text_io.put_line("The Place : " & natural'image(the_place_index)); end; function index return natural is begin return the_place_index; 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; -- enumeration -- with Identifier, Generic_String_Sort_Array; package Enumeration is type Object is private; procedure Put_name (item : in out Object; Name : in identifier.object); procedure Put_literal (item : in out Object;literal : in identifier.object;ok :out boolean); -- procedure Get_literal (item : in Object;literal : out identifier.object;key : in natural;ok :out boolean); procedure show (item : in Object); --procedure init(item : in out object); --procedure next(item : in out object); --function value(item : in object) return identifier; --function done(item : in object) return boolean; function Name (item : in Object) return String; function literal_image(item : in Object;literal_index : in positive) return string; function literal (item: in object; literal : in string) return natural; function Belong(item : in object;literal : in string) return boolean; Null_Object : constant Object; private package literal_Array is new Generic_String_Sort_Array (Element => Identifier.Object, Max_Element_Number => 20, Null_Element => Identifier.Null_Object, Get_Key => identifier.image, show_element => Identifier.show); type Object is record Name : Identifier.Object := Identifier.Null_Object; The_Array : literal_Array.Object := literal_Array.Null_Object; -- iterator : literal_array.iterator; -- end record; Null_Object : constant Object := (Name => Identifier.Null_Object, The_Array => literal_Array.Null_Object); -- iterator => literal_array.null_iterator); -- end Enumeration; package enumeration is procedure Put_name (item : in out Object; Name : in identifier.object) is begin item.name:=name; end; procedure Put_literal (item : in out Object;literal : in identifier.object;ok :out boolean) is begin literal_array.put(item.the_array,literal,ok); end; -- procedure Get_literal (item : in Object;literal : out identifier.object;key : in natural;ok :out boolean) is -- begin -- literal_array.get(item.the_array,literal,key,ok); -- end; procedure show (item : in Object)is begin text_io.put_line("Enumeration : Name : " & name(item)); literal_array.show(item.the_array); end; --procedure init(item : in out object) is --begin -- literal_array.init(item.iterator,item.the_array); --end; --procedure next(item : in out object) is --begin -- literal_array.next(item.iterator); --end; --function value(item : in object) return identifier is --begin --return literal_array.value(item.iterator); --end; --function done(item : in object) return boolean is --begin --return literal_array.done(item.iterator); --end; function Name (item : in Object) return String is begin return identifier.image(item.name); end; function literal(item : in Object;literal_index : in positive) return string; literal_identifier : identifier.object; exist : boolean; begin literal_array.get(item.the_array,literal_identifier,literal_index,exist); if exist then return identifier.image(literal_identifier); else return ""; end; end; function literal (item: in object;literal : in string) return natural is begin return literal_array.index(item.the_array,literal); end; function Belong(item : in object;literal : in string) return boolean is begin return literal_array.belong(item.the_array,literal); end; end; -- enumeration array -- -- with identifier; package Enumeration_Array is procedure Put_literal (enumeration_name,literal_name : in identifier.object;ok :out boolean); -- procedure Get_literal (enumeration_name: in string;literal : out identifier.object;key : in positive;ok :out boolean); -- procedure Get_literal (enumeration_index: in positive;literal : out identifier.object;key : in positive;ok :out boolean); procedure show; function literal_image(enumeration_index,literal_index : in positive) return string; function enumeration (enumeration_name : in string) return natural; function literal (enumeration_indexex : in natural;literal_name : in string) return natural; function enumeration_Belong (enumeration_name : in string) return boolean; function literal_Belong (enumeration_index : in natural;literal_name : in string) return boolean; end; with text_io,enumeration,generic_string_sort_array; package body enumeration_array is package enum_array is new Generic_String_Sort_Array (Element => Enumeration.Object, Max_Element_Number => 30, Null_Element => Enumeration.Null_Object, Get_Key => Enumeration.Name, show_Element => Enumeration.show); the_array : enum_array.object := enum_array.null_object; procedure Put_literal (enumeration_name,literal_name : in identifier.object;ok : out boolean) is an_enumeration: enumeration.object; begin enum_array.get(the_array,an_enumeration,identifier.image(enumeration_name),ok); if not ok then enumeration.put_name(an_enumeration,enumeration_name); end if; enumeration.put_literal(an_enumeration,literal_name,ok); if ok then enum_array.put(the_array,an_enumeration); end if; end; -- procedure Get_literal (enumeration_name : in string;literal : out identifier.object;key : in positive;ok : out boolean) is -- an_enumeration: enumeration.object; -- begin -- enum_array.get(the_array,an_enumeration,enumeration_name,ok); -- if ok then -- enumeration.get_literal(an_enumeration,literal,key,ok); -- end if; -- end; -- procedure Get_literal (enumeration_index: in positive;literal : out identifier.object;key : in positive;ok : out boolean) is -- an_enumeration: enumeration.object; -- begin -- enum_array.get(the_array,an_enumeration,enumeration_index,ok); -- if ok then -- enumeration.get_literal(an_enumeration,literal,key,ok); -- end if; -- end; procedure show is begin text_io.put_line("Enumeration Array :"); enum_array.show(the_array); end; function literal_image(enumeration_index,literal_index : in positive) return string is an_enumeration : enumeration.object; exist : boolean; begin enum_array.get(the_array,an_enumeration,enumeration_index,exist); if exist then return enumeration.literal_image(an_enumeration,literal_index); else return ""; end if; end; function enumeration (enumeration_name : in string) return natural is begin return enum_array.index(the_array,enumeration_name); end; function literal (enumeration_index : in natural;literal_name : in string) return natural is an_enumeration: enumeration.object; exist : boolean; begin enum_array.get(the_array,an_enumeration,enumeration_index,exist); if exist then return enumeration.literal (an_enumeration,literal_name); else return 0; end if; end; function enumeration_Belong (enumeration_name : in string) return boolean is begin return enum_array.belong(the_array,enumeration_name); end; function literal_Belong(enumeration_index : in natural;literal_name : in string) return boolean is an_enumeration: enumeration.object; exist : boolean; begin enum_array.get(the_array,an_enumeration,enumeration_index,exist); if exist then return enumeration.belong(an_enumeration,literal_name); else return false; end if; end; -- verb array -- package Verb_Array is procedure Put (verb_name : in identifier.object;number : in positive;ok :out boolean); procedure show; function number(verb_name : in string) return natural; end; with text_io,verb,generic_string_sort_array; package body verb_array is package v_array is new Generic_String_Sort_Array (Element => verb.Object, Max_Element_Number => 100, Null_Element => verb.Null_Object, Get_Key => verb.Name, show_element => verb.show; the_array : v_array.object := v_array.null_object; procedure Put (verb_name : in identifier.object;number : in positive;ok :out boolean) is begin v_array.put(the_array,verb_name,ok); end; procedure show is begin text_io.put_line("Verb Array :"); v_array.show(the_array); end; function number(verb_name : in string) return natural is begin return v_array.index(the_array,verb_name); 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; -- Escape -- package Escape is type Object is private; procedure Put (Item : out Object;place,direction : in positive); procedure Show (Item : in Object); function Place (Item : in Object) return Natural; function Direction (Item : in Object) return Natural; Null_Object : constant Object; private type Object is record Place : Natural := 0; Direction : Natural := 0; end record; Null_Object : constant Object := (place => 0, Direction => 0); end Escape; with text_io; package body escape is procedure Put (Item : out Object;place,direction : in positive) is begin item.place := place; item.direction := direction; end; procedure show (Item : in Object) is begin text_io.put_line("Escape : Place : " & natural'image(place(item)) & " Direction : " & natural'image(direction(item))); end; function place (Item : in Object) return Natural is begin return item.place; end; function Direction (Item : in Object) return Natural is begin return item.repeat; end; end; -- Link -- with escape; package link is type Object is private; procedure Put (Item : in out Object;name,start_place,start_direction, next_place,next_direction : in positive); -- procedure Put_enumerate (Item : in out Object;enumeration,literal : in positive); -- procedure Put_start_escape (Item : in out Object;place,direction : in positive); -- procedure Put_next_escape (Item : in out Object;place,direction : in positive); procedure show (Item : in Object); function key (Item : in Object) return string; function Name (Item : in Object) return Natural; -- function Enumeration (Item : in Object) return Natural; -- function Literal (Item : in Object) return Natural; function start_direction(item : in object) return natural; function next_direction(item : in object) return natural; function start_place(item : in object) return natural; function next_place(item : in object) return natural; Null_Object : constant Object; private type Object is record Name : Natural := 0; -- Enumeration : Natural := 0; -- Literal : Natural := 0; start_Escape : Escape.Object := Escape.Null_Object; next_Escape : Escape.Object := Escape.Null_Object); end record; Null_Object : constant Object := (Name => 0, -- Enumeration => 0, -- Literal => 0, start_Escape => Escape.Null_Object, next_Escape => Escape.Null_Object); end Link; with text_io; package body link is procedure Put (Item : in out Object;name,start_place,start_direction, next_place,next_direction : in positive) is begin item.name := name; escape.put_place(item.start_escape,start_place,start_direction); escape.put_place(item.next_escape,next_place,next_direction); end; -- procedure Put_enumerate (Item : in out Object;enumeration,literal : in positive) is -- begin -- item.enumeration := enumeration; -- item.literal := literal; -- end; procedure Put_start_escape (Item : in out Object;place,direction : in positive) is begin escape.put_place(item.start_escape,place,direction); end; procedure Put_next_escape (Item : in out Object;place,direction : in positive) is begin escape.put(item.next_escape,place,direction); end; procedure show (Item : in Object) is begin text_io.put_line ("Link : Name : " & natural'image(name(item)); -- " Enumeration : " & natural'image(enumeration(item)) & -- " Literal : " & natural'image(literal(item)); escape.show(item.start_escape); escape.show(item.next_escape); end; function key (Item : in Object) return string is begin return natural'image(start_direction); end; function Name (Item : in Object) return Natural is begin return item.name; end; -- function Enumeration (Item : in Object) return Natural is -- begin -- return item.enumeration; -- end; -- function Literal (Item : in Object) return Natural is -- begin -- return item.literal; -- end; function start_direction(item : in object) return natural is begin return escape.direction(item.start_escape); end; function next_direction(item : in object) return natural is begin return escape.direction(item.next_escape); end; function start_place(item : in object) return natural is begin return escape.place(item.start_escape); end; function next_place(item : in object) return natural is begin return escape.place(item.next_escape); end; end; -- Field -- with Identifier; package Field is type Field_kind is (Number, Sentence, Enumerate, Unknown); type Object (Kind : Field_kind := Unknown) is private; -- procedure create_number(item : out object;name: in string); -- procedure create_sentence(item : out object;name: in string); -- procedure create_enumerate(item : out object;name: in string); procedure create_number(item : out object;index: in positive); procedure create_sentence(item : out object;index: in positive); procedure create_enumerate(item : out object;index: in positive); procedure Put_number (Item : in out Object;number : in integer; ok : out boolean); procedure Put_sentence (Item : in out Object;sentence : in string; ok : out boolean); procedure Put_enumerate (Item : in out Object;enumeration,literal : in positive; ok : out boolean); procedure show (Item : in Object); function index (Item : in Object) return natural; function index (Item : in Object) return String; function field_is_a_number (item : in object) return boolean; function field_is_a_sentence (item : in object) return boolean; function field_is_an_enumerate (item : in object) return boolean; function number (Item : in Object) return Integer; function sentence (Item : in Object) return String; function Enumeration (Item : in Object) return Natural; function Literal (Item : in Object) return Natural; Null_Object : constant Object; private type Object (Kind : Field_Kind := Unknown) is record case Kind is when Number => -- Number_Name : Identifier.Object := Identifier.Null_Object; number_index: natural :=0; Number_Value : Integer := 0; when Sentence => -- Sentence_Name : Identifier.Object := Identifier.Null_Object; sentence_index:natural:=0; Sentence_Value : Identifier.Object := Identifier.Null_Object; when Enumerate => -- Enumerate_Name : Identifier.Object := -- Identifier.Null_Object; enumerate_index:natural:=0; Enumeration : Natural := 0; Literal : Natural := 0; when Unknown => null; end case; end record; Null_Object : constant Object := (Kind => Unknown); end Field; with text_io; package body field is -- procedure create_number(item : out object;name : in string) is -- begin -- item := (kind =>number,number_name=>identifier.from_string(name),number_value=>0); -- end; -- procedure create_sentence(item : out object;name: in string) is -- begin -- item := (kind =>sentence,sentence_name=>identifier.from_string(name),sentence_value=>identifier.null_object); -- end; -- procedure create_enumerate(item : out object;name: in string) is -- begin -- item:=(kind=>enumerate,enumerate_name=>identifier.from_string(name),enumeration=>0,literal=>0); -- end; procedure create_number(item : out object;index : in positive) is begin item := (kind =>number,number_index=>index,number_value=>0); end; procedure create_sentence(item : out object;index: in positive) is begin item := (kind =>sentence,sentence_index=>index,sentence_value=>identifier.null_object); end; procedure create_enumerate(item : out object;index: in positive) is begin item:=(kind=>enumerate,enumerate_index=>index,enumeration=>0,literal=>0); end; procedure Put_number (Item : in out Object;number : in integer; ok : out boolean) is begin if item.kind = number then item.number_value := number ok := true; else ok:=false; end if; end; procedure Put_sentence (Item : in out Object;sentence : in string; ok : out boolean) is begin if item.kind = sentence then identifier.put(item.sentence_value,sentence); ok := true; else ok:=false; end if; end; procedure Put_enumerate (Item : in out Object;enumeration,literal : in positive; ok : out boolean) is begin if item.kind = enumerate then item.enumeration := enumeration; item.literal := literal; ok := true; else ok:=false; end if; end; procedure show (Item : in Object) is begin text_io.put("Field : Kind : " & field_kind'image(item.kind)); case item.kindis when nunber => text_io.put_line(" Name : " & name(item) & " Value : " & integer'image(number(item))); when sentence => text_io.put_line(" Name : " & name(item) & " Value : " & sentence(item)); when enumerate => text_io.put_line(" Name : " & name(item) & " Enumeration : " & natural'image(enumeration(item)) & " Literal : " & natural'image(literal(item))); when unknown=> new_line; end case; end; function index(Item : in Object) return natural is begin case item.kind is when number => return number_index; when sentence => return sentence_index; when enumerate => return enumerate_index; when unknown => return 0; end case; end; function index (Item : in Object) return String is begin return natural'image(index(item)); end; function field_is_a_number (item : in object) return boolean is begin return item.kind = number; end; function field_is_a_sentence (item : in object) return boolean is begin return item.kind = sentence; end; function field_is_an_enumerate (item : in object) return boolean is begin return item.kind = enumerate; end; function number (Item : in Object) return Integer is begin if item.kind = number then return item.number_value; else return 0; end if; end; function sentence (Item : in Object) return String is begin if item.kind = sentence then return identifier.image(item.sentence_value); else return ""; end if; end; function Enumeration (Item : in Object) return Natural is begin if item.kind = enumerate then return item.enumeration; else return 0; end if; function literal (Item : in Object) return Natural is begin if item.kind = enumerate then return item.literal; else return 0; end if; 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; --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); package field_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; type object(kind : complement_kind := unknown) is record 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; number : natural :=0; 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; --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,next_direction: in positive;ok : out boolean); --procedure exit_put_enumerate(place_index : in natural;direction:in string;enumeration,literal : in positive; ok : out boolean); function exit_exist(place_index: in natural;direction : in positive) return boolean; function exits_exist(place_index : in natural) return boolean; --function exit_enumeration(place_index: in natural;direction : in positive) return natural; --function exit_literal(place_index: in natural;direction : in positive) return natural; function exit_name(place_index: in natural;direction : in positive) return string; function next_place(place_index : in natural;direction : in positive) return natural; procedure put_place(subject_index : in natural;place : in natural;ok : out boolean); procedure show; procedure list_exits_init(place_index : in natural); procedure list_exits_next(place_index : in natural); function list_exits_name(place_index : in natural) return string; function list_exits_done(place_index : in natural) return boolean; procedure list_complement_init; procedure list_complement_next; function list_complement_place return positive; function list_complement_name return string; function list_complement_done return boolean; --function field_is_a_number (subject_index : in natural;field_name : in string) return boolean; --function field_is_a_sentence (subject_index : in natural;field_name : in string) return boolean; --function field_is_an_enumerate (subject_index : in natural;field_name : in string) return boolean; --function field_exist (subject_name,field_name : in string) return boolean; --function field_exist (subject_index:in natural;field_name : in string) return boolean; function field_is_a_number (subject_index : in natural;field_index : in positive) return boolean; function field_is_a_sentence (subject_index : in natural;field_index : in positive) return boolean; function field_is_an_enumerate (subject_index : in natural;field_index : in positive) return boolean; function field_exist (subject_name,field_index : in positive) return boolean; function field_exist (subject_index:in natural;field_index : in positive) return boolean; function is_a_subject(complement_name: in string) return boolean; function is_an_animate(complement_name: in string) return boolean; function is_a_place(complement_name: in string) return boolean; function is_an_entity(complement_name: in string) return boolean; function is_a_word(complement_name: in string) return boolean; function is_a_verb(complement_name: in string) return boolean; function belong(complement_name: in string) return boolean; function name(subject_index: in natural) return string; function index(complement_name: in string) return natural; function place (subject_index: in natural) return natural; --function field_number (subject_index : in natural;field_name:in string) return Integer; --function field_sentence (subject_index : in natural;field_name:in string) return String; --function field_Enumeration (subject_index : in natural;field_name:in string) return Natural; --function field_Literal (subject_index : in natural;field_name:in string) return Natural; function field_number (subject_index : in natural;field_index : in positive) return Integer; function field_sentence (subject_index : in natural;field_index : in positive) return String; function field_Enumeration (subject_index : in natural;field_index : in positive) return Natural; function field_Literal (subject_index : in natural;field_index : in positive) return Natural; function verb_number (verb_index : in natural) return Integer; end; with text_io; package body Complement_array is max_element : constant positive := 200; package c_array is new Generic_String_Sort_Array (Element => complement.Object, Max_Element_Number => max_element, Null_Element => complement.Null_Object, Get_Key => complement.Name, show_element => complement.show; the_array : c_array.object := c_array.null_object; the_iterator : c_array.iterator := c_array.null_iterator; procedure put(old_subject: in complement.object;name : in identifier.object; ok : out boolean) is new_subject : complement.object; begin complement.copy(old_subject,new_subject); complement.put_name(new_subject,name); c_array.put(the_array,new_subject,ok); end; procedure put_word(word : in identifier.object) is new_word : complement.object; begin complement.put_word(new_word,word); c_array.put(the_array,new_word,ok); end; procedure put_verb(verb : in identifier.object;number : in positive) is new_verb : complement.object; begin complement.put_verb(new_verb,verb_name,number); c_array.put(the_array,new_verb,ok); end; --procedure create_number_field(subject_index : in natural;field_name: in string; ok : out boolean) is procedure create_number_field(subject_index : in natural;field_index: in positive; ok : out boolean) is a_subject : complement.object; local_ok : boolean; begin c_array.get(the_array,a_subject,subject_index,local_ok); if local_ok then -- complement.create_number_field(a_subject,field_name,number,ok); complement.create_number_field(a_subject,field_index,number,ok); else ok:=false; end if; end; --procedure create_sentence_field(subject_index : in natural;field_name: in string; ok : out boolean) is procedure create_sentence_field(subject_index : in natural;field_index: in positive; ok : out boolean) is a_subject : complement.object; local_ok : boolean; begin c_array.get(the_array,a_subject,subject_index,local_ok); if local_ok then -- complement.create_sentence_field(a_subject,field_name,number,ok); complement.create_sentence_field(a_subject,field_index,number,ok); else ok:=false; end if; end; --procedure create_enumerate_field(subject_index : in natural;field_name: in string; ok : out boolean) is procedure create_enumerate_field(subject_index : in natural;field_index: in string; ok : out boolean) is a_subject : complement.object; local_ok : boolean; begin c_array.get(the_array,a_subject,subject_index,local_ok); if local_ok then -- complement.create_enumerate_field(a_subject,field_name,number,ok); complement.create_enumerate_field(a_subject,field_index,number,ok); else ok:=false; end if; end; --procedure Put_number (subject_index : in natural;field_name: in string;number : in integer; ok : out boolean) is procedure Put_number (subject_index : in natural;field_index: in positive;number : in integer; ok : out boolean) is a_subject : complement.object; local_ok : boolean; begin c_array.get(the_array,a_subject,subject_index,local_ok); if local_ok then -- complement.put_number(a_subject,field_name,number,ok); complement.put_number(a_subject,field_index,number,ok); else ok:=false; end if; end; --procedure Put_sentence (subject_index : in natural;field_name: in string;sentence : in string; ok : out boolean) is procedure Put_sentence (subject_index : in natural;field_index: in positive;sentence : in string; ok : out boolean) is a_subject : complement.object; local_ok : boolean; begin c_array.get(the_array,a_subject,subject_index,local_ok); if local_ok then -- complement.put_sentence(a_subject,field_name,sentence,ok); complement.put_sentence(a_subject,field_index,sentence,ok); else ok:=false; end if; end; --procedure Put_enumerate (subject_index : in natural;field_name: in string;enumeration,literal : in positive; ok : out boolean) is procedure Put_enumerate (subject_index : in natural;field_index: in string;enumeration,literal : in positive; ok : out boolean) is a_subject : complement.object; other_direction : natural; other_place : natural; local_ok : boolean; begin c_array.get(the_array,a_subject,subject_index,local_ok); if local_ok then -- complement.put_enumerate(a_subject,field_name,enumeration,literal,local_ok); complement.put_enumerate(a_subject,field_index,enumeration,literal,local_ok); if local_ok and complement.exit_exist(a_subject,index(field_name)) then --other_direction :=complement.next_direction(a_subject,index(field_name)); --other_place :=complement.next_place(a_subject,index(field_name)); other_direction :=complement.next_direction(a_subject,field_index); other_place :=complement.next_place(a_subject,field_index); c_array.get(the_array,a_subject,other_place,local_ok); if local_ok then -- complement.put_enumerate(a_subject,name(others_direction),enumeration,literal,local_ok); complement.put_enumerate(a_subject,others_direction,enumeration,literal,local_ok); end if; end if; end if; ok:=local_ok; end; procedure put_movement(animate_name: in string;place : in positive) is an_animate : complement.object; local_ok : boolean; begin c_array.get(the_array,an_animate,animate_name,local_ok); if local_ok then complement.put_movement(a_subject,place); end if; end; procedure movement_init(animate_index : in natural) is an_animate : complement.object; local_ok : boolean; begin c_array.get(the_array,an_animate,animate_index,local_ok) is if local_ok then complement.movement_init(an_animate); end if; end; procedure move(animate_index : in natural) is an_animate : complement.object; local_ok : boolean; begin c_array.get(the_array,an_animate,animate_index,local_ok); if local_ok then complement.move(an_animate); end if; end; procedure put_exit(place_index : in natural;name,start_place,start_direction, next_place,next_direction: in positive;ok : out boolean) is a_place : complement.object; local_ok : boolean; begin c_array.get(the_array,a_place,place_index,local_ok); if local_ok then complement.put_exit(a_place,name,start_place,start_direction,next_place,next_direction,ok); else ok:=false; end if; end; --procedure put_exit(place_index : in natural;name,start_place,start_direction, --next_place,next_direction: in positive;ok : out boolean) is --a_place : complement.object; --local_ok : boolean; --begin -- c_array.get(the_array,a_place,place_index,local_ok); -- if local_ok then --complement.put_exit(a_place,name,start_place,start_direction, --next_place,next_direction,ok); -- else -- ok:=false; -- end if; --end; --procedure exit_put_enumerate(place_index : in natural;direction : in string;enumeration,literal : in positive; ok : out boolean) is --a_place : complement.object; --local_ok : boolean; --begin -- c_array.get(the_array,a_place,place_index,local_ok); -- if local_ok then --complement.exit_put_enumerate(a_place,index(direction),enumeration,literal,ok); -- else -- ok:=false; -- end if; --end; function exit_exist(place_index: in natural;direction : in positive) return boolean is a_place : complement.object; local_ok : boolean; begin c_array.get(the_array,a_place,place_index,local_ok); if local_ok then return complement.exit_exist(a_place,direction); else return false; end if; end; --function exit_exist(place_index: in natural;direction : in string) return boolean is --begin --return exit_exist(place_index,index(direction)); --end; function exits_exist(place_index : in natural) return boolean is a_place : complement.object; local_ok : boolean; begin c_array.get(the_array,a_place,place_index,local_ok); if local_ok then return complement.exits_exist(a_place); else return false; end if; end; --function exit_enumeration(place_index: in natural;direction : in positive) return natural is --a_place : complement.object; --local_ok : boolean; --begin -- c_array.get(the_array,a_place,place_index,local_ok); -- if local_ok then -- return complement.enumeration_exit(a_place,direction); -- else -- return 0; -- end if; --end; --function exit_literal(place_index: in natural;direction : in positive) return natural is --a_place : complement.object; --local_ok : boolean; --begin -- c_array.get(the_array,a_place,place_index,local_ok); -- if local_ok then -- return complement.literal_exit(a_place,direction); -- else -- return 0; -- end if; --end; function exit_name(place_index : in natural;direction : in positive) return string is a_place : complement.object; local_ok : boolean; begin c_array.get(the_array,a_place,place_index,local_ok); if local_ok then return name(complement.exit_name(a_place,direction)); else return ""; end if; end; function next_place(place_index : in natural;direction : in positive) return natural is a_place : complement.object; local_ok : boolean; begin c_array.get(the_array,a_place,place_index,local_ok); if local_ok then return complement.next_place(a_place,direction); else return 0; end if; end; procedure put_place(subject_index: in natural;place : in natural;ok : out boolean) is a_subject : complement.object; local_ok : boolean; begin c_array.get(the_array,a_subject,subject_index,local_ok); if local_ok then complement.put_place(a_subject,place,ok); else ok:=false; end if; end; procedure show; begin text_io.put_line("Complement Array :"); c_array.show(the_array); end; procedure list_exits_init(place_index : in natural) is a_place : complement.object; local_ok : boolean; begin c_array.get(the_array,a_place,place_index,local_ok); if local_ok then complement.list_exits_init(a_place); end if; end; procedure list_exits_next(place_index : in natural) is a_place : complement.object; local_ok : boolean; begin c_array.get(the_array,a_place,place_index,local_ok); if local_ok then complement.list_exits_next(a_place); end if; end; function list_exits_name(place_index : in natural) return string is a_place : complement.object; local_ok : boolean; begin c_array.get(the_array,a_place,place_index,local_ok); if local_ok then return name(complement.list_exits_name(a_place)); else return ""; end if; end; function list_exits_done(place_index : in natural) return boolean is a_place : complement.object; local_ok : boolean; begin c_array.get(the_array,a_place,place_index,local_ok); if local_ok then complement.list_exits_done(a_place); else return true; end if; end; procedure list_complement_init is begin c_array.list_init(the_array,the_iterator); end; procedure list_complement_next is begin c_array.list_next(the_iterator); end; function list_complement_place return positive is begin return complement.place(c_array.list_value(the_iterator)); end; function list_complement_name return string is begin return complement.name(c_array.list_value(the_iterator)); end; function list_complement_done return boolean is begin c_array.list_done(the_iterator); end; --function field_is_a_number (subject_index : in natural;field_name : in string) return boolean is function field_is_a_number (subject_index : in natural;field_index : in positive) return boolean is a_subject : complement.object; local_ok : boolean; begin c_array.get(the_array,a_subject,subject_index,local_ok); if local_ok then -- return complement.field_is_a_number(a_subject,field_name); return complement.field_is_a_number(a_subject,field_index); else return false; end if; end; --function field_is_a_sentence (subject_index : in natural;field_name : in string) return boolean is function field_is_a_sentence (subject_index : in natural;field_index : in positive) return boolean is a_subject : complement.object; local_ok : boolean; begin c_array.get(the_array,a_subject,subject_index,local_ok); if local_ok then -- return complement.field_is_a_sentence(a_subject,field_name); return complement.field_is_a_sentence(a_subject,field_index); else return false; end if; end; --function field_is_an_enumerate (subject_index : in natural;field_name : in string) return boolean is function field_is_an_enumerate (subject_index : in natural;field_index : in positive) return boolean is a_subject : complement.object; local_ok : boolean; begin c_array.get(the_array,a_subject,subject_index,local_ok); if local_ok then -- return complement.field_is_an_enumerate(a_subject,field_name); return complement.field_is_an_enumerate(a_subject,field_index); else return false; end if; end; --function field_exist (subject_name,field_name : in string) return boolean is function field_exist (subject_name,field_index: in positive) return boolean is a_subject : complement.object; local_ok : boolean; begin c_array.get(the_array,a_subject,subject_name,local_ok); if local_ok then -- return complement.field_exist(a_subject,field_name); return complement.field_exist(a_subject,field_index); else return false; end if; end; --function field_exist (subject_index:in natural;field_name : in string) return boolean is function field_exist (subject_index:in natural;field_index : in positive) return boolean is a_subject : complement.object; local_ok : boolean; begin c_array.get(the_array,a_subject,subject_index,local_ok); if local_ok then -- return complement.field_exist(a_subject,field_name); return complement.field_exist(a_subject,field_index); else return false; end if; end; function is_an_subject(complement_name: in string) return boolean is a_complement : complement.object; local_ok : boolean; begin c_array.get(the_array,a_complement,complement_name,local_ok); if local_ok then return complement.is_a_subject(a_complement); else return false; end if; end; function is_an_animate(complement_name: in string) return boolean is a_complement : complement.object; local_ok : boolean; begin c_array.get(the_array,a_complement,complement_name,local_ok); if local_ok then return complement.is_an_animate(a_complement); else return false; end if; end; function is_a_place(complement_name: in string) return boolean is a_complement : complement.object; local_ok : boolean; begin c_array.get(the_array,a_complement,complement_name,local_ok); if local_ok then return complement.is_a_place(a_complement); else return false; end if; end; function is_an_entity(complement_name: in string) return boolean is a_complement : complement.object; local_ok : boolean; begin c_array.get(the_array,a_complement,complement_name,local_ok); if local_ok then return complement.is_an_entity(a_complement); else return false; end if; end; function is_a_word(complement_name: in string) return boolean is a_complement: complement.object; local_ok : boolean; begin c_array.get(the_array,a_complement,complement_name,local_ok); if local_ok then return complement.is_a_word(a_complement); else return false; end if; end; function is_a_verb(complement_name: in string) return boolean is a_complement : complement.object; local_ok : boolean; begin c_array.get(the_array,a_complement,complement_name,local_ok); if local_ok then return complement.is_a_verb(a_complement); else return false; end if; end; function belong(complement_name: in string) return boolean is begin return c_array.belong(the_array,complement_name); end; function name(subject_index: in natural) return string is a_complement : complement.object; local_ok : boolean; begin c_array.get(the_array,a_complement,subject_index,local_ok); if local_ok then return complement.name(a_complement); else return ""; end if; end; function index(complement_name: in string) return natural is begin return c_array.index(the_array,complement_name); end; function place (subject_index: in natural) return natural is a_subject : complement.object; local_ok : boolean; begin c_array.get(the_array,a_subject,subject_index,local_ok); if local_ok then return complement.place(a_subject); else return 0; end if; end; --function field_number (subject_index : in natural;field_name:in string) return Integer is function field_number (subject_index : in natural;field_index:in positive) return Integer is a_subject : complement.object; local_ok : boolean; begin c_array.get(the_array,a_subject,subject_index,local_ok); if local_ok then -- return complement.field_number(a_subject,field_index); return complement.field_number(a_subject,field_name); else return 0; end if; end; --function field_sentence (subject_index : in natural;field_name:in string) return String is function field_sentence (subject_index : in natural;field_index:in positive) return String is a_subject : complement.object; local_ok : boolean; begin c_array.get(the_array,a_subject,subject_index,local_ok); if local_ok then -- return complement.field_sentence(a_subject,field_name); return complement.field_sentence(a_subject,field_index); else return ""; end if; end; --function field_Enumeration (subject_index : in natural;field_name:in string) return Natural is function field_Enumeration (subject_index : in natural;field_index:in index) return Natural is a_subject : complement.object; local_ok : boolean; begin c_array.get(the_array,a_subject,subject_index,local_ok); if local_ok then -- return complement.field_enumeration(a_subject,field_name); return complement.field_enumeration(a_subject,field_index); else return 0; end if; end; --function field_Literal (subject_index : in natural;field_name:in string) return Natural is function field_Literal (subject_index : in natural;field_index:in positive) return Natural is a_subject : complement.object; local_ok : boolean; begin c_array.get(the_array,a_subject,subject_index,local_ok); if local_ok then -- return complement.field_literal(a_subject,field_name); return complement.field_literal(a_subject,field_index); else return 0; end if; end; function verb_number (verb_index : in natural) return Integer is a_verb : complement.object; local_ok : boolean; begin c_array.get(the_array,a_verb,verb_index,local_ok); if local_ok then return complement.verb_number(a_verb); else return 0; end if; end; an_identifier : identifier.object; begin identifier.put(an_identifier,"ailleurs"); put_word(an_identifier); end; -- structure -- with complement,identifer; package structure is type object is private; procedure put_name(item : in out object;name : in identifier.object); --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 show(item : in object); function name(item : in object) return string; function subject(item : in object) return complement.object; null_object : constant object; animate_object : constant object; place_object : constant object; entity_object : constant object; private type object is record name : identifier.object := identifer.null_object; a_subject : complement.object := complement.null_object; end record; null_object := (name=>identifier.null_object,a_subject=>complement.null_object); animate_object := (name=>identifier.null_object,a_subject=>complement.animate_object); place_object := (name=>identifier.null_object,a_subject=>complement.place_object); entity_object := (name=>identifier.null_object,a_subject=>complement.entity_object); end; with text_io; package body structure is procedure put_name(item : in out object;name : in identifier.object) is begin item.name:=name; 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 begin -- complement.create_number_field(item.a_complement,field_name,ok) complement.create_number_field(item.a_complement,field_index,ok) end; -- procedure create_sentence_field(item : out object;field_name: in string; ok : out boolean) is procedure create_sentence_field(item : out object;field_index: in positive; ok : out boolean) is begin -- complement.create_sentence_field(item.a_complement,field_name,ok); complement.create_sentence_field(item.a_complement,field_index,ok); end; -- procedure create_enumerate_field(item : out object;field_name: in string; ok : out boolean) is procedure create_enumerate_field(item : out object;field_index: in positive; ok : out boolean) is begin -- complement.create_enumerate_field(item.a_complement,field_name,ok); complement.create_enumerate_field(item.a_complement,field_index,ok); end; -- procedure field_Put_number (Item : in out Object;field_name: in string;number : in integer; ok : out boolean) is procedure field_Put_number (Item : in out Object;field_index: in positive;number : in integer; ok : out boolean) is begin -- complement.field_Put_number (Item.a_complement,field_name,number,ok); complement.field_Put_number (Item.a_complement,field_index,number,ok); end; -- procedure field_Put_sentence (Item : in out Object;field_name: in string;sentence : in string; ok : out boolean) is procedure field_Put_sentence (Item : in out Object;field_index: in positive;sentence : in string; ok : out boolean) is begin -- complement.field_Put_sentence (Item.a_complement,field_name,sentence,ok); complement.field_Put_sentence (Item.a_complement,field_index,sentence,ok); end; -- procedure field_Put_enumerate (Item : in out Object;field_name: in string;enumeration,literal : in positive; ok : out boolean) is procedure field_Put_enumerate (Item : in out Object;field_index: in positive;enumeration,literal : in positive; ok : out boolean) is begin -- complement.field_Put_enumerate (Item.a_complement,field_name,enumeration,literal,ok); complement.field_Put_enumerate (Item.a_complement,field_index,enumeration,literal,ok); end; procedure show(item : in object) is begin text_io.put_line("Structure : Name : " & name(item)); complement.image(item.a_complement); end; function name(item : in object) return string is begin return identifier.image(item); end; function complement(item : in object) return complement.object is begin return item.a_complement; end; begin put_name(animate_object,"anime"); put_name(place_object,"lieu"); put_name(entity_object,"entite"); end; -- structure array -- with complement; package structure_array is max_element : constant positive; procedure put(old_name: in string;new_name : in identifier.object; ok : out boolean); --procedure create_number_field(structure_name: in string;item : out object;field_name: in string; ok : out boolean); --procedure create_sentence_field(structure_name: in string;item : out object;field_name: in string; ok : out boolean); --procedure create_enumeration_field(structure_name: in string;item : out object;field_name: in string; ok : out boolean); --procedure field_Put_number (structure_name: in string;Item : in out Object;field_name: in string;number : in integer; ok : out boolean); --procedure field_Put_sentence (structure_name: in string;Item : in out Object;field_name: in string;sentence : in string; ok : out boolean); --procedure field_Put_enumerate (structure_name: in string;Item : in out Object;field_name: in string;enumeration,literal : in positive; ok : out boolean); procedure create_number_field(structure_name: in identifier.object;item : out object;field_index : in positive; ok : out boolean); procedure create_sentence_field(structure_name: in identifier.object;item : out object;field_index : in positive; ok : out boolean); procedure create_enumeration_field(structure_name: in identifier.object;item : out object;field_index : in positive; ok : out boolean); procedure field_Put_number (structure_name: in identifier.object;Item : in out Object;field_index : in positive;number : in integer; ok : out boolean); procedure field_Put_sentence (structure_name: in identifier.object;Item : in out Object;field_index : in positive;sentence : in string; ok : out boolean); procedure field_Put_enumerate (structure_name: in identifier.object;Item : in out Object;field_index : in positive;enumeration,literal : in positive; ok : out boolean); procedure get_subject(structure_name: in string;subject : out complement.object;ok : out boolean); procedure show; function subject(structure_name: in string) return complement.object; function belong (structure_name: in string) return boolean; end; with text_io,structure; package body structure_array is max_element : constant positive := 200; package s_array is new Generic_String_Sort_Array (Element => structure.Object, Max_Element_Number => max_element, Null_Element => structure.Null_Object, Get_Key => structure.Name, show_element => structure.show; the_array : s_array.object := s_array.null_object; procedure put(old_name:in string;new_name : in identifier.object; ok : out boolean) is new_structure : structure.object; local_ok : boolean; begin s_array.get(the_array,new_structure,old_name,local_ok); if local_ok then structure.put_name(new_structure,new_name); s_array.put(the_array,new_structure,ok); else ok:=false; end if; end; -- procedure create_number_field(structure_name: in string;item : out object;field_name: in string; ok : out boolean) is procedure create_number_field(structure_name: in identifier.object;item : out object;field_index : in positive; ok : out boolean) is a_structure : structure.object; local_ok : boolean; begin s_array.get(the_array,a_structure,identifier.image(structure_name),local_ok); if local_ok then -- structure.create_number_field(a_structure,field_name,ok); structure.create_number_field(a_structure,field_index,ok); end if; end; -- procedure create_sentence_field(structure_name: in identifier.object;item : out object;field_name: in string; ok : out boolean) is procedure create_sentence_field(structure_name: in identifier.object;item : out object;field_index : in positive; ok : out boolean) is a_structure : structure.object; local_ok : boolean; begin s_array.get(the_array,a_structure,identifier.image(structure_name),local_ok); if local_ok then -- structure.create_sentence_field(a_structure,field_name,ok); structure.create_sentence_field(a_structure,field_index,ok); end if; end; -- procedure create_enumerate_field(structure_name: in identifier.object;item : out object;field_name: in string; ok : out boolean) is procedure create_enumerate_field(structure_name: in identifier.object;item : out object;field_index : in positive; ok : out boolean) is a_structure : structure.object; local_ok : boolean; begin s_array.get(the_array,a_structure,identifier.image(structure_name),local_ok); if local_ok then -- structure.create_enumerate_field(a_structure,field_name,ok); structure.create_enumerate_field(a_structure,field_index,ok); end if; end; -- procedure field_Put_number(structure_name: in identifier.object;Item : in out Object;field_name: in string;number : in integer; ok : out boolean) is procedure field_Put_number(structure_name: in identifier.object;Item : in out Object;field_index : in positive;number : in integer; ok : out boolean) is a_structure : structure.object; local_ok : boolean; begin s_array.get(the_array,a_structure,identifier.image(structure_name),local_ok); if local_ok then -- structure.field_put_number(a_structure,field_name,number,ok); structure.field_put_number(a_structure,field_index,number,ok); end if; end; -- procedure field_Put_sentence(structure_name: in identifier.object;Item : in out Object;field_name: in string;sentence : in string; ok : out boolean) is procedure field_Put_sentence(structure_name: in identifier.object;Item : in out Object;field_index : in positive;sentence : in identifier.object; ok : out boolean) is a_structure : structure.object; local_ok : boolean; begin s_array.get(the_array,a_structure,identifier.image(structure_name),local_ok); if local_ok then -- structure.field_put_sentence(a_structure,field_name,sentence,ok); structure.field_put_sentence(a_structure,field_index,sentence,ok); end if; end; -- procedure field_Put_enumerate (structure_name: in identifier.object;Item : in out Object;field_name: in string;enumeration,literal : in positive; ok : out boolean) is procedure field_Put_enumerate (structure_name: in identifier.object;Item : in out Object;field_index : in positive;enumeration,literal : in positive; ok : out boolean) is a_structure : structure.object; local_ok : boolean; begin s_array.get(the_array,a_structure,identifier.image(structure_name),local_ok); if local_ok then -- structure.field_put_enumerate(a_structure,field_name,enumeration,literal,ok); structure.field_put_enumerate(a_structure,field_index,enumeration,literal,ok); end if; end; procedure get_subject(structure_name: in string;subject : out complement.object;ok : out boolean) is a_structure : structure.object; begin s_array.get(the_array,a_structure,structure_name,ok); subject:=structure.subject(a_structure); end; procedure show; begin text_io.put_line("Structure Array :"); s_array.show(the_array); end; function subject(structure_name: in string) return complement.object is a_structure : structure.object; local_ok : boolean; begin s_array.get(the_array,a_structure,structure_name,local_ok); if local_ok then return structure.subject(a_structure); else return complement.null_object; end; function belong(structure_name : in string) return boolean is begin return s_array.belong(the_array,structure_name); end; begin s_array.put(the_array,structure.animate_object); s_array.put(the_array,strucure.place_object); s_array.put(the_array,structure.entity_object); end; -- order -- with moving_string; package order is subtype index; type index_array; type object is private; procedure put_complement(item : in out object; place : in moving_string.object; first_complement : in moving_string.object; second_complement : in moving_string.object; third_complement : in moving_string.object; fourth_complement : in moving_string.object); procedure put_redirection(item : in out object;redirection : in index_array); procedure make_redirection(item : in out object;complement : in string;position : in index); procedure free(item : in object); procedure show(item : in object); function image(item : in object) return string; function complement_position(item : in object;complement : in string) return natural; function contains_complement(item : in object;complement : in string) return boolean; function complement(item : in object;position : in index) return string; function redirection(item : in object) return index_array; null_object : constant object; null_index_array : constant index_array; private subtype index is positive 1..5; type index_array is array(index) of index; type moving_string_array is array(index) of moving_string.object; null_moving_array : constant moving_string_array :=( moving_string.null_object, moving_string.null_object, moving_string.null_object, moving_string.null_object, moving_string.null_object); null_index_array : constant index_array :=(0,0,0,0,0); type object is record the_order : moving_string_array := null_moving_string_array; redirection : index_array := null_index_array; end record; null_object : constant object := (the_order => null_moving_string_array, redirection => null_index_array); end; with text_io; use moving_string; package body order is procedure put_complement(item : in out object; place : in moving_string.object; first_complement : in moving_string.object; second_complement : in moving_string.object; third_complement : in moving_string.object; fourth_complement : in moving_string.object) is begin item.the_order(1):=place; item.the_order(2):=first_complement; item.the_order(3):=second_complement; item.the_order(4):=third_complement; item.the_order(5):=fourth_complement; end; procedure put_redirection(item : in out object;redirection : in index_array) is begin item.redirection := redirection; end; procedure free(item : in object) is begin for i in index'range loop moving_string.free(item.the_order(i)); end loop; end; procedure show(item : in object) is begin text_io.put("Order : " & image(item)); for i in index'range loop text_io.put(" " & index'image(item.redirection(i))); end loop; text_io.new_line; end; procedure make_redirection(item : in object;complement : in string;position : in index) is begin if contains_complement(item,complement) then item.redirection(position):=complement_position(item,complement); end if; end; function image(item : in object) return string is begin return moving_string.image (item.the_order(1) & " " & item.the_order(2) & " " & item.the_order(3) & " " & item.the_order(4) & " " & item.the_order(5)); end; function complement_position(item : in object;complement : in string) return natural is an_index : natural := 0; begin for i in index'range loop if moving_string.image(item.the_order(i)) := complement then an_index := i; end if; end loop; return an_index; end; function contains_complement(item : in object;complement : in string) return boolean is begin return complement_position(item,complement) /= 0; end; function complement(item : in object;position : in index) return string is begin return moving_string.image(item.the_order(item.the_index(position))); end; function redirection(item : in object) return index_array is begin return item.redirection; end; end; -- the order -- with order,moving_string; package the_order is procedure put_complement(place : in moving_string.object; first_complement : in moving_string.object; second_complement : in moving_string.object; third_complement : in moving_string.object; fourth_complement : in moving_string.object); procedure put_redirection(redirection : in index_array); procedure free; procedure show; function complement(position : in index) return natural; end; with text_io,complement_array; use moving_string; package body the_order is current_order : order.object := order.null_object; procedure put_complement(place : in moving_string.object; first_complement : in moving_string.object; second_complement : in moving_string.object; third_complement : in moving_string.object; fourth_complement : in moving_string.object) is begin order.put_complement(current_order,place,first_complement, second_complement,third_complement,fourth_complement); end; procedure put_redirection(redirection : in index_array) is begin order.put_redirection(current_order,redirection); end; procedure free is begin order.free(current_order); end; procedure show is begin text_io.put("The Order : "); order.show(current_order); end; function complement(position : in index) return natural is begin return complement_array.index(order.complement(current_order,position)); end; end; -- order list -- with order; package order_list is procedure put(an_order : in order.object;ok : out boolean); procedure make_redirection(complement : in string); procedure free; procedure show; function contains_complement(complement : in string) return boolean; procedure init; procedure next; function value return order.object; function done return boolean; end; with Text_Io,exclusive_generic_list; package body order_list is package o_list is new exclusive_generic_list (element => order.object, null_element => order.null_object, show_element => order.show, get_key => order.image); the_list : o_list.list := o_list.nil; the_iterator : o_list.iterator; procedure put(an_order : in order.object;ok : out boolean) is begin o_list.make(an_order,the_list,ok); end; procedure make_redirection(complement : in string) is an_iterator : o_list.iterator; position : order.index; begin if constains_complement(complement) then o_list.init(an_iterator,the_list); position := order.complement_position(o_list.value(an_iterator),complement); while not o_list.done(an_iterator) loop order.make_redirection(o_list.value(an_iterator),complement,position); o_list.next(an_iterator); end loop; end if; end; procedure free is an_iterator : o_list.iterator; begin o_list.init(an_iterator,the_list); while not o_list.done(an_iterator) loop order.free(value(an_iterator)); o_list.next(an_iterator); end loop; o_list.free(the_list); end; procedure show is begin text_io.put_line ("Order List :"); o_list.show(the_list); end; function contains_complement(complement : in string) return boolean is found : boolean; an_iterator : o_list.iterator; begin o_list.init(an_iterator,the_list); if not o_list.done(an_iterator) then found:=true; while not o_list.done(an_iterator) loop found := found & order.contains_complement(o_list.value(an_iterator),complement); o_list.next(an_iterator); end loop; else found:=false; end if; return found; end; procedure init is begin o_list.init(the_iterator,the_list); end; procedure next is begin o_list.next(the_iterator); end; function value return order.object; begin return o_list.value(the_iterator); end; function done return boolean; begin return o_list.done(the_iterator); end; end; -- coded_order -- with order,identifer,instruction_list; package coded_order is type object is private; procedure put(item : out object;an_order : in order.object;list : in instruction_list.object); procedure run(item : in object); procedure show(item : in object); 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; function key(item : in object) return string; null_object : constant object; private type object is record; key : identifier.object :=