⟦34679feb3⟧

E3 Source Code



with Condition;
with Class_Id;
with Text_Io;
use Condition;
package body Fact is

    Max_Object_Count : constant := 100;
    Last_Object      : Name     := 0;

    subtype Object_Size is Natural range 0 .. Max_Slots;

    type Object (Size : Object_Size := 0) is
        record
            Valid : Boolean := False;
            Value : Frame (1 .. Size);
        end record;

    Null_Object : constant Object :=
       (Size => 0, Valid => False, Value => (others => 0));

    type Object_Collection is array (Name range <>) of Object;

    Working_Memory : Object_Collection (1 .. Max_Object_Count) :=
       (others => Null_Object);

    function Make_Object (F : Frame) return Object is
    begin
        return (Size => F'Length, Valid => True, Value => F);
    end Make_Object;

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



    function Match (Value : Frame; Against : Pattern) return Boolean is
    begin
        for I in Value'Range loop
            if not Match (Value (I), Against (I)) then
                return False;
            end if;
        end loop;
        return True;
    end Match;


    function Find (Filter : Pattern) return Name is
        Wm : Object_Collection renames Working_Memory;
    begin
        for I in Wm'First .. Last_Object loop
            if Wm (I).Valid and then  
               Match (Wm (I).Value, Against => Filter) then
                return I;
            end if;
        end loop;
        return Null_Name;
    end Find;

    function Find (Filter : Pattern) return Collection is
        Wm : Object_Collection renames Working_Memory;
        function Recursive_Find (Starting_At : Name) return Collection is
        begin
            for I in Starting_At .. Last_Object loop
                if Wm (I).Valid and then  
                   Match (Wm (I).Value, Against => Filter) then
                    return I & Recursive_Find (Starting_At => I + 1);
                end if;
            end loop;
            return Empty_Collection;
        end Recursive_Find;
    begin
        return Recursive_Find (Starting_At => Wm'First);
    end Find;


    function Retrieve (Filter : Join_Descriptor) return Collection is  
        Result : Collection (Filter'Range);
        Wm     : Object_Collection renames Working_Memory;

        function Recursive_Search (Search_Index : Positive) return Boolean is
        begin  
            if Search_Index > Filter'Last then
                return True;
            else
                case Filter (Search_Index).Kind is
                    when Find =>
                        for I in Wm'First .. Last_Object loop
                            if Wm (I).Valid and then
                               Match (Wm (I).Value,
                                      Filter (Search_Index).Value) then
                                if Recursive_Search (Search_Index + 1) then
                                    Result (Search_Index) := I;
                                    return True;
                                end if;
                            end if;
                        end loop;
                    when Check_No =>
                        for I in Wm'First .. Last_Object loop
                            if Wm (I).Valid and then
                               Match (Wm (I).Value,
                                      Filter (Search_Index).Value) then
                                return False;
                            end if;
                        end loop;
                        if Recursive_Search (Search_Index + 1) then
                            Result (Search_Index) := Null_Name;
                            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 Put (The_Fact : Name) is  
        First      : Boolean := True;
        The_Object : Object renames Working_Memory (The_Fact);
    begin
        if The_Object /= Null_Object then
            Text_Io.Put ("Class => " &
                         Class_Id.Image (The_Object.Value (1)) & ", ");
            for I in 2 .. The_Object.Value'Last loop
                if not First then
                    Text_Io.Put (", ");
                else
                    First := False;
                end if;
                Text_Io.Put ("Attribute" & Slot_Names'Image (I) & " => " &
                             Integer'Image (The_Object.Value (I)));
            end loop;
            Text_Io.New_Line;
        end if;
    end Put;

    procedure Put (The_Collection : Collection) is
    begin
        if The_Collection'Length /= 0 then
            for I in The_Collection'Range loop
                Put (The_Collection (I));
            end loop;
        end if;
    end Put;


    procedure Add (The_Fact : Frame) is
    begin
        for I in Working_Memory'Range loop
            if Working_Memory (I) = Null_Object then
                Working_Memory (I) := Make_Object (The_Fact);
                if I > Last_Object then
                    Last_Object := I;
                end if;
                return;
            end if;
        end loop;
        raise Overflow;
    end Add;

    procedure Delete (The_Fact : Name) is
    begin
        Working_Memory (The_Fact) := Null_Object;
        if Last_Object = The_Fact then  
            Last_Object := Last_Object - 1;
            for I in reverse 1 .. Last_Object loop
                exit when Working_Memory (I) /= Null_Object;
                Last_Object := I;
            end loop;
        end if;
    end Delete;

    procedure Change (The_Fact : Name; Value : Frame) is
    begin
        Working_Memory (The_Fact) := Make_Object (Value);
    end Change;

    procedure Change (The_Fact : Name;
                      The_Slot : Slot_Names;
                      To_Value : Integer) is  
    begin
        Working_Memory (The_Fact).Value (The_Slot) := To_Value;
    end Change;

    function Get (The_Fact : Name) return Frame is
    begin
        return Working_Memory (The_Fact).Value;
    end Get;

    function Get (The_Fact : Name; Slot : Slot_Names) return Integer is
    begin
        return Working_Memory (The_Fact).Value (Slot);
    end Get;
end Fact;
DataMuseum.dk

Rational R1000/400

⟦34679feb3⟧ Ada Source

Derivation

E3 Source Code

E3 Meta Data
