DataMuseum.dk

top - download

    Length: 6619 (0x19db)
    Types: TextFile
    Names: »B«

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

TextFile

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

    type Frame_Collection is array (Name range <>) of Frame;

    Null_Object : constant Frame := (others => Dummy);

    Working_Memory : Frame_Collection (1 .. 20) :=
       (Frame'(Class => Robot, Size => Dummy, Colour => Green, State => Free),  
        Frame'(Class => Robot, Size => Dummy, Colour => Red, State => Busy),
        Frame'(Class => Ball, Size => 50, Colour => Blue, State => On_Heap),
        Frame'(Class => Ball, Size => 75, Colour => Green, State => On_Heap),
        Frame'(Class => Ball, Size => 95, Colour => Red, State => On_Heap),
        Frame'(Class => Ball, Size => 100, Colour => Blue, State => On_Heap),
        Frame'(Class => Box, Size => 750, Colour => Red, State => Free),
        Frame'(Class => Box, Size => 10000, Colour => Green, State => Free),
        Frame'(Class => Box, Size => 150, Colour => Red, State => Busy),
        others => Null_Object);

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

    function Attribute_Image (Attribute : Integer) return String is
    begin
        case Attribute is
            when Dummy =>
                return "Dummy";
            when Robot =>
                return "Robot";
            when Ball =>
                return "Ball";
            when Box =>
                return "Box";
            when Busy =>
                return "Busy";
            when Free =>
                return "Free";
            when On_Heap =>
                return "On_Heap";
            when In_Box =>
                return "In_Box";
            when Red =>
                return "Red";
            when Blue =>
                return "Blue";
            when Green =>
                return "Green";
            when others =>
                return Integer'Image (Attribute);
        end case;
    end Attribute_Image;

    procedure Put (The_Fact : Name) is  
        First      : Boolean := True;
        The_Object : Frame renames Working_Memory (The_Fact);
    begin
        if The_Object /= Null_Object then
            for I in The_Object'Range loop
                if not First then
                    Text_Io.Put (", ");
                else
                    First := False;
                end if;
                Text_Io.Put (Slot_Name'Image (I) & " => " &
                             Attribute_Image (The_Object (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;
        else
            Text_Io.Put_Line ("no match !!!");
        end if;
    end Put;

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


    function Find (Filter : Pattern) return Name is
    begin
        for I in Working_Memory'Range loop
            if Match (Working_Memory (I), Against => Filter) then
                return I;
            end if;
        end loop;
        return Null_Name;
    end Find;

    -- procedure Solve_1 (Filter : Query) is
    --     Result : Object;
    -- begin
    --     Result := Find (Filter.Value);
    --     if Result /= Null_Object then
    --         case Filter.Kind is
    --             when Find =>
    --                 null;
    --             when Check_No =>
    --                 Text_Io.Put ("Failed : ");
    --         end case;
    --         Put (Result);
    --     else
    --         Text_Io.Put_Line ("no match !!!");
    --     end if;
    -- end Solve_1;


    function Retrieve (Filter : Join_Descriptor) return Collection is  
        Result : Collection (Filter'Range);
        Wm     : Frame_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'Range loop
                            if Match (Wm (I), 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'Range loop
                            if Match (Wm (I), 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 Solve (Filter : Join_Descriptor) is
    -- begin
    --     Put (Retrieve (Filter));
    -- end Solve;

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

    procedure Delete (The_Fact : Name) is
    begin
        Working_Memory (The_Fact) := Null_Object;
    end Delete;

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

    procedure Change (The_Fact : Name;
                      The_Slot : Slot_Name;
                      To_Value : Integer) is  
        The_Frame : Frame renames Working_Memory (The_Fact);
    begin
        The_Frame (The_Slot) := To_Value;
    end Change;
end Fact;