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

⟦4f22127b2⟧ TextFile

    Length: 7105 (0x1bc1)
    Types: TextFile
    Names: »B«

Derivation

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

TextFile

with Text_Io;
package body Sfam is
    type Pattern_Array is
        record
            Normal : Raw_Input_Pattern;
            Complement : Raw_Input_Pattern;
        end record;

    type Activation is delta Sfam_Units.Pattern'Delta range 0.0 .. 100.0;

    type Node;
    type Node_Ptr is access Node;
    type Node is
        record
            Cat : Category;
            Act : Activation;
            W : Pattern_Array;
        end record;

    type Link;
    type Link_Ptr is access Link;
    type Link is
        record
            Node : Node_Ptr;
            Next : Link_Ptr;
        end record;

    Output_Nodes : Link_Ptr := null;
    Sorted_Nodes : Link_Ptr := null;

    function Create_Pattern_Array
                (Normal : Raw_Input_Pattern) return Pattern_Array is
        P : Pattern_Array;
    begin
        P.Normal := Normal;
        for I in Normal'Range loop
            P.Complement (I) := Sfam_Units.Complement (P.Normal (I));
        end loop;
        return P;
    end Create_Pattern_Array;

    function And_Pattern_Array (P1, P2 : Pattern_Array) return Pattern_Array is
        R : Pattern_Array;

        function Min (P1, P2 : Sfam_Units.Pattern) return Sfam_Units.Pattern is
            use Sfam_Units;
        begin
            if P1 < P2 then
                return P1;
            else
                return P2;
            end if;
        end Min;

    begin
        for I in R.Normal'Range loop
            R.Normal (I) := Min (P1.Normal (I), P2.Normal (I));
        end loop;
        for I in R.Complement'Range loop
            R.Complement (I) := Min (P1.Complement (I), P2.Complement (I));
        end loop;  
        return R;
    end And_Pattern_Array;

    function Norm_Of_Pattern_Array (P : Pattern_Array) return Activation is
        Norm : Activation := 0.0;
    begin
        for I in P.Normal'Range loop
            Norm := Norm + Activation (P.Normal (I));
        end loop;
        for I in P.Complement'Range loop
            Norm := Norm + Activation (P.Complement (I));
        end loop;
        return Norm;
    end Norm_Of_Pattern_Array;

    function Create_Node (Its_Category : Category; Its_Pattern : Pattern_Array)
                         return Node_Ptr is
    begin
        return new Node'(Its_Category, 0.0, Its_Pattern);
    end Create_Node;

    procedure Display_Node (N : Node_Ptr) is
        package Fio is new Text_Io.Fixed_Io (Activation);
        package Pio is new Text_Io.Fixed_Io (Sfam_Units.Pattern);
    begin
        Text_Io.Put ("Node : ");
        Text_Io.Put (Image (N.Cat));
        Text_Io.Put (" T = ");
        Fio.Put (N.Act);
        for I in N.W.Normal'Range loop
            Text_Io.Put (" n ");
            Pio.Put (N.W.Normal (I));
        end loop;
        for I in N.W.Complement'Range loop
            Text_Io.Put (" c ");
            Pio.Put (N.W.Complement (I));
        end loop;
        Text_Io.Put_Line ("");
    end Display_Node;

    function Category_Is_Known (A_Category : Category) return Boolean is
        N : Link_Ptr := Output_Nodes;
    begin
        while N /= null loop
            if N.Node.Cat = A_Category then
                return True;
            end if;
            N := N.Next;
        end loop;
        return False;
    end Category_Is_Known;

    procedure Evaluate_Activation (N : Node_Ptr; I : Pattern_Array) is
        Alpha : constant Activation := 0.000_000_1;
    begin
        N.Act := Activation (Norm_Of_Pattern_Array
                                (And_Pattern_Array (I, N.W)) /
                             (Alpha + Norm_Of_Pattern_Array (N.W)));
    end Evaluate_Activation;

    procedure Sort_Nodes is
        Sorted : Link_Ptr := null;
        L : Link_Ptr;

        procedure Insert (N : Node_Ptr) is
            P, Q : Link_Ptr;
        begin  
            if Sorted = null then
                Sorted := new Link'(Node => N, Next => null);
            elsif N.Act > Sorted.Node.Act then
                Sorted := new Link'(Node => N, Next => Sorted);
            else
                Q := Sorted;
                P := Sorted.Next;
                while P /= null loop
                    if N.Act > P.Node.Act then
                        Q.Next := new Link'(Node => N, Next => P);
                        return;
                    end if;
                    Q := P;
                    P := P.Next;
                end loop;
                Q.Next := new Link'(Node => N, Next => null);
            end if;
        end Insert;
    begin
        L := Output_Nodes;
        while L /= null loop
            Insert (L.Node);
            L := L.Next;
        end loop;
        Sorted_Nodes := Sorted;
    end Sort_Nodes;

    procedure Treat_Labeled_Pattern (Its_Category : Category;
                                     Its_Pattern : Raw_Input_Pattern) is
        use Sfam_Units;
        N : Node_Ptr;
        L : Link_Ptr;
        Vigilance : Sfam_Units.Pattern;
        Match_Value : Sfam_Units.Pattern;
        Input : Pattern_Array;
        Mismatch : Boolean := False;
    begin
        Input := Create_Pattern_Array (Its_Pattern);
        if not Category_Is_Known (Its_Category) then
            N := Create_Node (Its_Category, Input);
            Output_Nodes := new Link'(Node => N, Next => Output_Nodes);
        else
            Vigilance := Base_Vigilance;
            L := Output_Nodes;
            while L /= null loop
                Evaluate_Activation (L.Node, Input);
                L := L.Next;
            end loop;
            Sort_Nodes;  
            L1:
                while Sorted_Nodes /= null loop
                    Match_Value := Pattern
                                      (Norm_Of_Pattern_Array
                                          (And_Pattern_Array
                                              (Input, Sorted_Nodes.Node.W)) /
                                       Its_Pattern'Length);
                    if Match_Value < Vigilance then
                        Sorted_Nodes.Node.Act := 0.0;
                        Mismatch := True;
                    else
                        if Sorted_Nodes.Node.Cat = Its_Category then
                            Sorted_Nodes.Node.W :=
                               And_Pattern_Array (Input, Sorted_Nodes.Node.W);
                            Mismatch := False;
                            exit L1;
                        else
                            Vigilance := Pattern (Match_Value + 0.000_000_1);
                            Sorted_Nodes.Node.Act := 0.0;
                            Mismatch := True;
                        end if;
                    end if;
                    Sorted_Nodes := Sorted_Nodes.Next;
                end loop L1;

            if Mismatch then
                N := Create_Node (Its_Category, Input);
                Output_Nodes := new Link'(Node => N, Next => Output_Nodes);
            end if;
        end if;
        Text_Io.Put_Line ("----------");
        L := Output_Nodes;
        while L /= null loop
            Display_Node (L.Node);
            L := L.Next;
        end loop;

    end Treat_Labeled_Pattern;

end Sfam;