DataMuseum.dk

top - metrics - download

    Length: 6106 (0x17da)
    Types: TextFile
    Names: »B«

└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
    └─⟦129cab021⟧ »DATA« 
        └─⟦this⟧ 
└─⟦2f6cfab89⟧ Bits:30000547 8mm tape, Rational 1000, !projects 94-01-04
    └─⟦d65440be7⟧ »DATA« 
        └─⟦this⟧ 
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
    └─⟦129cab021⟧ »DATA« 
        └─⟦e24fb53b7⟧ 
            └─⟦this⟧ 

TextFile

package body Generic_Fact_Base is

    package Working_Memory is

        type Frame (Size : Value_Size := 0) is private;

        type Slots is array (Slot_Names range <>) of Integer;

        Null_Frame : constant Frame;

        function  Last return Object;  -- objects are from 1 to last
        procedure Make_Empty;

        function Make (The_Class : Class_Name; The_Slots : Slots) return Frame;

        function Get (The_Fact : Object)                    return Frame;
        function Get (The_Fact : Object; Slot : Slot_Names) return Integer;

        procedure Add    (The_Fact : Frame);
        procedure Delete (The_Fact : Object);
        procedure Change (The_Fact : Object; Value : Frame);
        procedure Change (The_Fact : Object;
                          The_Slot : Slot_Names;
                          To_Value : Integer);

        function Match (The_Element : Object; Against : Query) return Boolean;

        procedure Put (The_Fact : Object; Where : Output_Stream.Object);
        procedure Put (Where : Output_Stream.Object);  -- The working memory

    private

        type Frame (Size : Value_Size := 0) is
            record
                Class : Class_Name;
                Value : Slots (1 .. Size);
            end record;

        Null_Frame : constant Frame :=
           (Size => 0, Class => Null_Class_Name, Value => (others => 0));

    end Working_Memory;

    function Image (Of_Class : Class_Name) return String
        renames Constant_String.Image;


    function Empty_Collection return Collection is
    begin
        return (1 .. 0 => Null_Object);
    end Empty_Collection;


    function Null_Premiss return Queries is
    begin
        return Queries'(1 .. 0 => Null_Query);
    end Null_Premiss;


    function Retrieve (Filter : Queries) return Collection is  
        Result : Collection (Filter'Range);
        function Recursive_Search (Index : Positive) return Boolean is
            Filter_Class : Class_Name;
        begin  
            if Index > Filter'Last then
                return True;
            else
                Filter_Class := Filter (Index).Class;
                case Filter (Index).Kind is
                    when Find =>
                        for Element in 1 .. Working_Memory.Last loop
                            if Working_Memory.Match
                                  (Element, Against => Filter (Index)) then
                                if Recursive_Search (Index + 1) then
                                    Result (Index) := Element;
                                    return True;
                                end if;
                            end if;
                        end loop;
                    when Check_No =>
                        for Element in 1 .. Working_Memory.Last loop
                            if Working_Memory.Match
                                  (Element, Against => Filter (Index)) then
                                return False;
                            end if;
                        end loop;
                        if Recursive_Search (Index + 1) then
                            Result (Index) := Null_Object;
                            return True;
                        end if;
                end case;
                return False;
            end if;
        end Recursive_Search;
    begin
        if Filter'Length /= 0 and then Recursive_Search (Filter'First) then
            return Result;
        else
            return Empty_Collection;
        end if;  
    end Retrieve;


    -------------------------------------------------------------------------

    procedure Make_Empty is
    begin
        Working_Memory.Make_Empty;
    end Make_Empty;

    procedure Put (The_Patterns : Patterns;
                   Where        : Output_Stream.Object :=
                      Output_Stream.Standard_Output) is  
        First : Boolean := True;
        use Output_Stream;
    begin
        for I in The_Patterns'Range loop
            if not First then
                Put_Line (", ", Where);
            else
                First := False;
            end if;
            Put ("Slot" & Slot_Names'Image (I) & " => ", Where);
            Predicate_Put (The_Expression => The_Patterns (I), Where => Where);
        end loop;
    end Put;

    procedure Put (The_Query : Query; Where : Output_Stream.Object) is
        use Output_Stream;
    begin
        case The_Query.Kind is
            when Find =>
                Put_Line
                   ("Find_" & Image (The_Query.Class) & "_Such_As'(", Where);
            when Check_No =>
                Put_Line
                   ("Check_No_" & Image (The_Query.Class) & "_Has'(", Where);
        end case;
        Indent_Right (Where);
        Put (The_Patterns => The_Query.Value, Where => Where);
        Indent_Left (Where);
        Put_Line (")", Where);
    end Put;

    procedure Put (The_Queries : Queries; Where : Output_Stream.Object) is
        use Output_Stream;
    begin
        Put ("Premiss'(", Where);
        Indent_Right (Where);
        for I in The_Queries'Range loop
            Put (The_Queries (I), Where);
            New_Line (Where);
        end loop;
        Indent_Left (Where);
        Put_Line (")", Where);
    end Put;

    procedure Put (The_Fact : Object; Where : Output_Stream.Object) is
    begin
        Working_Memory.Put (The_Fact, Where);
    end Put;

    procedure Put (The_Collection : Collection; Where : Output_Stream.Object) is
        use Output_Stream;
    begin  
        Put_Line ("Fact_collection'(", Where);
        Indent_Right (Where);
        if The_Collection'Length /= 0 then
            for I in The_Collection'Range loop
                Put (The_Collection (I), Where);
            end loop;
        end if;
        Indent_Left (Where);
        New_Line (Where);
        Put_Line (")", Where);
    end Put;

    procedure Put (Where : Output_Stream.Object) is
    begin
        Working_Memory.Put (Where);
    end Put;

    package body Working_Memory is separate;
    package body Generic_Fact is separate;

end Generic_Fact_Base;