|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 22568 (0x5828)
Types: TextFile
Names: »B«
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
└─ ⟦129cab021⟧ »DATA«
└─⟦this⟧
with List_Generic;
with Text_Io;
package body Bloc is
Maxi : constant := 255;
type Vue_Scene is
record
Nom : Symbole;
Vue : Pbloc := null;
end record;
type Vue_Bloc_Trie is
record
Offset_Global : Integer := -1;
Vue : Pbloc := null;
end record;
package Liste_Offset_Globaux is new List_Generic (Vue_Bloc_Trie);
package Liste_Offset_Trie is new List_Generic (Vue_Bloc_Trie);
La_Liste_Offset_Globaux : Liste_Offset_Globaux.List;
La_Liste_Offset_Trie : Liste_Offset_Trie.List;
Un_Iter_Prive : Liste_Offset_Globaux.Iterator;
Pere_Existe : Boolean := False;
Liste_Nombre : Boolean;
La_Liste_De_Nombre : Liste (False);
La_Liste_De_Symbole : Liste (True);
Compteur_Element : Integer;
Vue_Liste_Action : Pgrande_Liste := null;
Vue_Bloc_Pere : Pbloc := null;
Vue_Courante : Pbloc := null;
Memo_Bloc_Courant : array (1 .. Maxi) of Pbloc;
Table_Vue_Scene : array (1 .. Maxi) of Vue_Scene;
Index_Scene : Integer range 1 .. Maxi := 1;
Filtre : Symbole;
procedure Ajouter is
begin
La_Liste_Offset_Globaux :=
Liste_Offset_Globaux.Make
(Vue_Bloc_Trie'(Vue => Vue_Courante, Offset_Global => 0),
La_Liste_Offset_Globaux);
end Ajouter;
function Va_Bloc_Pere return Boolean is
begin
if Vue_Courante.Le_Pere /= null then
Vue_Courante := Vue_Courante.Le_Pere;
return True;
else
return False;
end if;
end Va_Bloc_Pere;
function Va_Bloc_Frere_Cadet return Boolean is
begin
if Vue_Courante.Le_Frere_Cadet /= null then
Vue_Courante := Vue_Courante.Le_Frere_Cadet;
return True;
else
return False;
end if;
end Va_Bloc_Frere_Cadet;
function Va_Bloc_Frere_Aine return Boolean is
begin
if Vue_Courante.Le_Frere_Aine /= null then
Vue_Courante := Vue_Courante.Le_Frere_Aine;
return True;
else
return False;
end if;
end Va_Bloc_Frere_Aine;
function Nouveau_Pere return Boolean is
begin
if Vue_Bloc_Pere = null then
Vue_Bloc_Pere := new Le_Bloc;
Vue_Bloc_Pere.Dernier_Bloc := False;
Vue_Courante := Vue_Bloc_Pere;
Liste_Offset_Globaux.Free (La_Liste_Offset_Globaux);
La_Liste_Offset_Globaux :=
Liste_Offset_Globaux.Make
(Vue_Bloc_Trie'(Vue => Vue_Courante, Offset_Global => 0),
La_Liste_Offset_Globaux);
return True;
else
return False;
end if;
end Nouveau_Pere;
function Nouveau_Bloc_Frere_Aine return Boolean is --ajout d'un aine
Ok : Boolean := False;
begin
if Vue_Courante.Le_Frere_Aine = null then
Vue_Courante.Dernier_Bloc := False;
Vue_Courante.Le_Frere_Aine := new Le_Bloc;
Vue_Courante.Le_Frere_Aine.Le_Pere := Vue_Courante.Le_Pere;
Vue_Courante.Le_Frere_Aine.Profondeur := Vue_Courante.Profondeur;
Vue_Courante.Le_Frere_Aine.Le_Frere_Cadet := Vue_Courante;
Ok := Va_Bloc_Frere_Aine;
Ajouter;
Ok := Va_Bloc_Frere_Cadet;
return True;
else
return False;
end if;
end Nouveau_Bloc_Frere_Aine;
function Nouveau_Bloc_Frere_Cadet return Boolean is --ajout d'un cadet
Ok : Boolean := False;
begin
if Vue_Courante.Le_Frere_Cadet = null then
Vue_Courante.Dernier_Bloc := False;
Vue_Courante.Le_Frere_Cadet := new Le_Bloc;
Vue_Courante.Le_Frere_Cadet.Le_Pere := Vue_Courante.Le_Pere;
Vue_Courante.Le_Frere_Cadet.Profondeur := Vue_Courante.Profondeur;
Vue_Courante.Le_Frere_Cadet.Le_Frere_Aine := Vue_Courante;
Ok := Va_Bloc_Frere_Cadet;
Ajouter;
Ok := Va_Bloc_Frere_Aine;
return True;
else
return False;
end if;
end Nouveau_Bloc_Frere_Cadet;
function Nouveau_Bloc_Fils
return Boolean is --attention un seul fils par bloc
Ok : Boolean := False;
begin
if Vue_Courante.Profondeur = 0 and then Vue_Courante.Le_Fils = null then
Vue_Courante.Le_Fils := new Le_Bloc;
Vue_Courante.Le_Fils.Le_Pere := Vue_Bloc_Pere;
Vue_Courante.Le_Fils.Profondeur := 1;
Ok := Va_Bloc_Fils;
Ajouter;
Ok := Va_Bloc_Pere;
return True;
elsif Vue_Courante.Le_Fils = null then
Vue_Courante.Dernier_Bloc := False;
Vue_Courante.Le_Fils := new Le_Bloc;
Vue_Courante.Le_Fils.Profondeur := Vue_Courante.Profondeur + 1;
Vue_Courante.Le_Fils.Le_Pere := Vue_Courante;
Ok := Va_Bloc_Fils;
Ajouter;
Ok := Va_Bloc_Pere;
return True;
else
return False;
end if;
end Nouveau_Bloc_Fils;
function Dernier_Bloc return Boolean is
begin
return Vue_Courante.Dernier_Bloc;
end Dernier_Bloc;
function Va_Bloc_Fils return Boolean is
begin
if Vue_Courante.Le_Fils /= null then
Vue_Courante := Vue_Courante.Le_Fils;
return True;
else
return False;
end if;
end Va_Bloc_Fils;
procedure Cherche_Case_Vide (P : in out Pgrande_Liste) is
begin
while P.Suivant /= null loop
P := P.Suivant;
end loop;
end Cherche_Case_Vide;
procedure Insere_Offset (Un_Temps : Integer) is
begin
Vue_Courante.Offset := Un_Temps;
end Insere_Offset;
function Donne_Offset return Integer is
begin
return Vue_Courante.Offset;
end Donne_Offset;
function Donne_Profondeur return Integer is
begin
return Vue_Courante.Profondeur;
end Donne_Profondeur;
function Scene_Existe (Un_Nom : Symbole) return Boolean is
begin
for I in Table_Vue_Scene'First .. Index_Scene loop
if Equal (Un_Nom, Table_Vue_Scene (I).Nom) then
return True;
end if;
end loop;
return False;
end Scene_Existe;
function Insere_Scene (Un_Nom : Symbole) return Boolean is
begin
if Index_Scene <= Table_Vue_Scene'Last then
Table_Vue_Scene (Index_Scene).Nom := Un_Nom;
Table_Vue_Scene (Index_Scene).Vue := Vue_Courante;
Index_Scene := Index_Scene + 1;
return True;
else
return False;
end if;
end Insere_Scene;
function Va_Scene (Un_Nom : Symbole) return Boolean is
Index : Integer;
Ok : Boolean := False;
begin
Index := 1;
while Index <= Maxi loop
if Equal (Table_Vue_Scene (Index).Nom, Un_Nom) then
Ok := True;
Vue_Courante := Table_Vue_Scene (Index).Vue;
exit;
end if;
Index := Index + 1;
end loop;
return Ok;
end Va_Scene;
procedure Insere_Type_Bloc (Un_Nom : Symbole) is
begin
Vue_Courante.Type_Bloc := Un_Nom;
end Insere_Type_Bloc;
function Donne_Type_Bloc return Symbole is
begin
return Vue_Courante.Type_Bloc;
end Donne_Type_Bloc;
function Donne_Nouvelle_Liste (Type_Liste : Boolean) return Pliste is
begin
return new Liste (Type_Liste);
end Donne_Nouvelle_Liste;
function Liste_Vide return Pliste is
begin
return null;
end Liste_Vide;
procedure Memorise_Bloc_Courant (I : Integer) is
begin
if I <= Maxi and I > 0 then
Memo_Bloc_Courant (I) := Vue_Courante;
end if;
end Memorise_Bloc_Courant;
procedure Retourne_Bloc_Memorise (I : Integer) is
begin
if I <= Maxi and I > 0 then
if Memo_Bloc_Courant (I) /= null then
Vue_Courante := Memo_Bloc_Courant (I);
end if;
end if;
end Retourne_Bloc_Memorise;
procedure Insere_Liste_Symbole
(Un_Element : Symbole; Une_Valeur : Integer) is
P : Pgrande_Liste := null;
begin
P := Vue_Courante.Liste_Symbole;
if P /= null then
Cherche_Case_Vide (P);
P.Suivant := new Grande_Liste (False);
if P.Precedent = null then
P.Suivant.Precedent := P;
P := P.Suivant;
else
P.Suivant.Precedent := P.Precedent.Suivant;
P := P.Suivant;
end if;
else
P := new Grande_Liste (False);
Vue_Courante.Liste_Symbole := P;
end if;
P.Index := new Liste'(False, null, null, Une_Valeur);
P.Contenu := Un_Element;
end Insere_Liste_Symbole;
procedure Insere_Liste (P : in out Pgrande_Liste;
Un_Element : Symbole;
Une_Liste : Liste) is
begin
P := Vue_Courante.Liste_Symbole;
if P /= null then
Cherche_Case_Vide (P);
P.Suivant := new Grande_Liste (False);
P.Suivant.Precedent := P;
P := P.Suivant;
else
P := new Grande_Liste (False);
Vue_Courante.Liste_Symbole := P;
end if;
P.Index := new Liste'(Une_Liste);
P.Contenu := Un_Element;
end Insere_Liste;
procedure Insere_Liste_Symbole (Un_Element : Symbole; Une_Liste : Liste) is
P : Pgrande_Liste := null;
begin
P := Vue_Courante.Liste_Symbole;
Insere_Liste (P, Un_Element, Une_Liste);
end Insere_Liste_Symbole;
procedure Insere_Liste_Action (Un_Element : Symbole; Une_Liste : Liste) is
P : Pgrande_Liste := null;
begin
P := Vue_Courante.Liste_Action;
Insere_Liste (P, Un_Element, Une_Liste);
end Insere_Liste_Action;
procedure Insere_Liste_Action (Une_Action : Symbole;
Un_Acteur : Symbole;
De : Integer;
Vers : Integer;
En : Integer) is
P : Pgrande_Liste := null;
begin
P := Vue_Courante.Liste_Action;
if P /= null then
Cherche_Case_Vide (P);
P.Suivant := new Grande_Liste (True);
P.Suivant.Precedent := P;
P := P.Suivant;
else
Vue_Courante.Liste_Action := new Grande_Liste (True);
P := Vue_Courante.Liste_Action;
end if;
P.Une_Action := Une_Action;
P.Un_Acteur := Un_Acteur;
P.De := De;
P.En := En;
P.Vers := Vers;
end Insere_Liste_Action;
function Qui_Es_Tu (Un_Element : Symbole) return Liste is
P : Pgrande_Liste := null;
P_Memo : Pbloc;
Ok : Boolean := False;
begin
P_Memo := Vue_Courante;
P := Vue_Courante.Liste_Symbole;
loop
if P /= null then
while P.Suivant /= null loop
P := P.Suivant;
end loop;
while (not Ok) and then (P.Precedent /= null) loop
if Equal (Un_Element, P.Contenu) then
Ok := True;
exit;
else
P := P.Precedent;
end if;
end loop;
if Equal (Un_Element, P.Contenu) then
Ok := True;
end if;
if Ok then
exit;
elsif Va_Bloc_Pere then
P := Vue_Courante.Liste_Symbole;
else
exit;
end if;
else
if Va_Bloc_Pere then
P := Vue_Courante.Liste_Symbole;
else
exit;
end if;
end if;
end loop;
Vue_Courante := P_Memo;
if Ok then
return P.Index.all;
else
return Liste'(Suivant => null,
Precedent => null,
Type_Cont => False,
Valeur => 0);
end if;
end Qui_Es_Tu;
procedure Liste_Action_Donne (Une_Action : out Symbole;
Un_Acteur : out Symbole;
De : out Integer;
Vers : out Integer;
En : out Integer) is
begin
Une_Action := Vue_Liste_Action.Une_Action;
Un_Acteur := Vue_Liste_Action.Un_Acteur;
De := Vue_Liste_Action.De;
Vers := Vue_Liste_Action.Vers;
En := Vue_Liste_Action.En;
end Liste_Action_Donne;
function Liste_Action_Suivante return Boolean is
begin
if Vue_Liste_Action.Suivant /= null then
Vue_Liste_Action := Vue_Liste_Action.Suivant;
return True;
else
return False;
end if;
end Liste_Action_Suivante;
function Liste_Action_Init return Boolean is
begin
if Vue_Courante.Liste_Action /= null then
Vue_Liste_Action := Vue_Courante.Liste_Action;
return True;
else
return False;
end if;
end Liste_Action_Init;
procedure Prend_Liste (Une_Liste : in Liste) is
begin --mise au debut de la liste
Compteur_Element := 0;
if Une_Liste.Type_Cont then
La_Liste_De_Symbole := Une_Liste;
while La_Liste_De_Symbole.Suivant /= null loop
La_Liste_De_Symbole := La_Liste_De_Symbole.Suivant.all;
end loop;
while La_Liste_De_Symbole.Precedent /= null loop
Compteur_Element := Compteur_Element + 1;
La_Liste_De_Symbole := La_Liste_De_Symbole.Precedent.all;
end loop;
Compteur_Element := Compteur_Element + 1;
Liste_Nombre := False;
else
La_Liste_De_Nombre := Une_Liste;
while La_Liste_De_Nombre.Suivant /= null loop
La_Liste_De_Nombre := La_Liste_De_Nombre.Suivant.all;
end loop;
while La_Liste_De_Nombre.Precedent /= null loop
Compteur_Element := Compteur_Element + 1;
La_Liste_De_Nombre := La_Liste_De_Nombre.Precedent.all;
end loop;
Compteur_Element := Compteur_Element + 1;
Liste_Nombre := True;
end if;
end Prend_Liste;
function Donne_Liste (Un_Pointeur : Pliste) return Liste is
begin
return Un_Pointeur.all;
end Donne_Liste;
function Donne_Type_Liste return Boolean is
begin
return not Liste_Nombre;
end Donne_Type_Liste;
function Suivant return Boolean is
begin
if Liste_Nombre then
return (La_Liste_De_Nombre.Suivant /= null);
else
return (La_Liste_De_Symbole.Suivant /= null);
end if;
end Suivant;
function Donne_Taille_Liste return Integer is
begin
return Compteur_Element;
end Donne_Taille_Liste;
function Donne_Element return Symbole is
begin
La_Liste_De_Symbole := La_Liste_De_Symbole.Suivant.all;
return La_Liste_De_Symbole.Contenu;
end Donne_Element;
function Donne_Element return Integer is
begin
return La_Liste_De_Nombre.Valeur;
end Donne_Element;
procedure Concate (Un_Element : Symbole; Une_Liste : in out Pliste) is
Memo : Pliste;
begin
Memo := Une_Liste;
if Memo /= null then
while Memo.Suivant /= null loop
Memo := Memo.Suivant;
end loop;
Memo.Suivant := new Liste'(True, null, null, Un_Element);
Memo.Suivant.Precedent := Memo;
else
Memo := new Liste'(True, null, null, Un_Element);
end if;
Une_Liste := Memo;
end Concate;
procedure Concate (Une_Valeur : Integer; Une_Liste : in out Pliste) is
Memo : Pliste;
begin
Memo := Une_Liste;
if Memo /= null then
while Memo.Suivant /= null loop
Memo := Une_Liste.Suivant;
end loop;
Memo.Suivant := new Liste'(False, null, null, Une_Valeur);
Memo.Suivant.Precedent := Memo;
else
Memo := new Liste'(False, null, null, Une_Valeur);
end if;
Une_Liste := Memo;
end Concate;
function Somme_Offset_Bloc (P : Vue_Bloc_Trie) return Integer is
Tmp : Integer;
begin
Vue_Courante := P.Vue;
Tmp := Vue_Courante.Offset;
while Va_Bloc_Pere loop
Tmp := Tmp + Vue_Courante.Offset;
end loop;
return Tmp;
end Somme_Offset_Bloc;
procedure Max (Ancien, Nouveau : Vue_Bloc_Trie;
Le_Max : out Vue_Bloc_Trie;
Ok : out Boolean) is
begin
if Ancien.Offset_Global <= Nouveau.Offset_Global then
Le_Max := Nouveau;
Ok := True;
else
Le_Max := Ancien;
Ok := False;
end if;
end Max;
procedure Trie_Liste_Offset is
type Maille;
type P_Maille is access Maille;
type Maille is
record
Element : Vue_Bloc_Trie;
Suivant : P_Maille;
end record;
Tete : P_Maille;
Est_Vide : Boolean := False;
Le_Max : Vue_Bloc_Trie;
procedure Extrait_Max (Une_Chaine : in out P_Maille;
Le_Max : out Vue_Bloc_Trie;
Est_Vide : in out Boolean) is
P_Local, P_Max : P_Maille := Une_Chaine;
Off_Max : Integer := 0;
Premier : Boolean := True;
begin
Est_Vide := True;
if P_Local /= null then
Off_Max := P_Local.Element.Offset_Global;
while P_Local.Suivant /= null loop
if P_Local.Suivant.Element.Offset_Global >= Off_Max then
Off_Max := P_Local.Suivant.Element.Offset_Global;
P_Max := P_Local;
Premier := False;
end if;
P_Local := P_Local.Suivant;
end loop;
if P_Max.Suivant /= null then
Est_Vide := False;
if Premier then
Le_Max := P_Max.Element;
Une_Chaine := Une_Chaine.Suivant;
else
Le_Max := P_Max.Suivant.Element;
P_Max.Suivant := P_Max.Suivant.Suivant;
end if;
else
Le_Max := P_Max.Element;
Une_Chaine := null;
end if;
end if;
end Extrait_Max;
procedure Copie (Une_Liste : Liste_Offset_Trie.List;
Une_Chaine : out P_Maille) is
Iter : Liste_Offset_Trie.Iterator;
Elem_Tempo : Vue_Bloc_Trie;
Tete : P_Maille := null;
begin
Liste_Offset_Trie.Init (Iter, Une_Liste);
while not Liste_Offset_Trie.Done (Iter) loop
Elem_Tempo := Liste_Offset_Trie.Value (Iter);
Tete := new Maille'(Element => Elem_Tempo, Suivant => Tete);
Liste_Offset_Trie.Next (Iter);
end loop;
Une_Chaine := Tete;
end Copie;
begin
Copie (La_Liste_Offset_Trie, Tete);
if Tete /= null then
while not Est_Vide loop
Extrait_Max (Tete, Le_Max, Est_Vide);
La_Liste_Offset_Globaux := Liste_Offset_Globaux.Make
(Le_Max, La_Liste_Offset_Globaux);
end loop;
end if;
end Trie_Liste_Offset;
procedure Construit_Liste_Offset is
Iter : Liste_Offset_Globaux.Iterator;
P : Vue_Bloc_Trie;
Offset_Global : Integer;
begin
Liste_Offset_Globaux.Init (Iter, La_Liste_Offset_Globaux);
while not Liste_Offset_Globaux.Done (Iter) loop
P := Liste_Offset_Globaux.Value (Iter);
Offset_Global := Somme_Offset_Bloc (P);
La_Liste_Offset_Trie :=
Liste_Offset_Trie.Make
(Vue_Bloc_Trie'(Vue => P.Vue, Offset_Global => Offset_Global),
La_Liste_Offset_Trie);
Liste_Offset_Globaux.Next (Iter);
end loop;
Liste_Offset_Globaux.Free (La_Liste_Offset_Globaux);
Trie_Liste_Offset;
end Construit_Liste_Offset;
function Init_Liste_Offset (Un_Nom : Symbole) return Boolean is
begin
if Scene_Existe (Un_Nom) then
Filtre := Un_Nom;
Liste_Offset_Globaux.Init (Un_Iter_Prive, La_Liste_Offset_Globaux);
return True;
else
return False;
end if;
end Init_Liste_Offset;
function Suivant_Liste_Offset_Est_Bloc_Courant return Boolean is
P : Vue_Bloc_Trie;
P_Memo : Pbloc;
Ok : Boolean := False;
begin
if not Liste_Offset_Globaux.Done (Un_Iter_Prive) then
while not Ok loop
P := Liste_Offset_Globaux.Value (Un_Iter_Prive);
Vue_Courante := P.Vue;
while (Vue_Courante.Profondeur > 1) and then (Va_Bloc_Pere) loop
null;
end loop;
P_Memo := Vue_Courante;
if Va_Scene (Filtre) then
if P_Memo = Vue_Courante then
Vue_Courante := P.Vue;
Vue_Courante.Offset := P.Offset_Global;
Ok := True;
end if;
end if;
Liste_Offset_Globaux.Next (Un_Iter_Prive);
if Liste_Offset_Globaux.Done (Un_Iter_Prive) then
return Ok;
end if;
end loop;
return True;
else
return False;
end if;
end Suivant_Liste_Offset_Est_Bloc_Courant;
end Bloc;