DataMuseum.dk

Presents historical artifacts from the history of:

Rational R1000/400 Tapes

This is an automatic "excavation" of a thematic subset of
artifacts from Datamuseum.dk's BitArchive.

See our Wiki for more about Rational R1000/400 Tapes

Excavated with: AutoArchaeologist - Free & Open Source Software.


top - download
Index: ┃ B T

⟦6aa73b433⟧ TextFile

    Length: 22568 (0x5828)
    Types: TextFile
    Names: »B«

Derivation

└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
    └─ ⟦129cab021⟧ »DATA« 
        └─⟦this⟧ 

TextFile

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;