⟦52e9c7314⟧

TextFile

separate (Generic_Fact_Base)
package body Class is

    type Instance (Size : Instance_Size := 0) is
        record  
            Value : Slots (1 .. Size);
        end record;

    Null_Instance : constant Instance :=
       (Size => 0, Value => (others => Slot.Null_Object));

    type Instance_Collection is array (Instance_Name range <>) of Instance;

    type Slot_Images (Size : Instance_Size := 0) is
        record  
            Value : Slot_Names_Images (1 .. Size);
        end record;

    type Object_Structure (Class_Size : Instance_Name) is
        record
            Class_Name    : Class_Names;
            Last_Instance : Instance_Name := Null_Instance_Name;
            Instances     : Instance_Collection (1 .. Class_Size) :=
               (others => Null_Instance);  
            Images        : Slot_Images;
        end record;


    function As_Anonymous (The_Class : Object) return Natural is
    begin
        return Class_Names'Pos (Class_Name_Of (The_Class));
    end As_Anonymous;


    function As_Class_Name (Anonymous_Class : Natural) return Class_Names is
    begin
        return Class_Names'Val (Anonymous_Class);
    end As_Class_Name;


    function As_User_Object
                (The_Instance : Instance_Name; For_Class : Class.Object)
                return User_Object is
    begin
        return Fact_Reference.Value (C => As_Anonymous (For_Class),
                                     I => Natural (The_Instance));
    end As_User_Object;


    function As_User_Object (The_Slot : Slot.Object) return User_Object is
    begin
        return Slot.Get_Reference (The_Slot);
    end As_User_Object;


    function Class_Of (The_Object : User_Object) return Class.Object is
        use Fact_Reference;
    begin
        return Working_Memory.Get (As_Class_Name (Get_Class (The_Object)));
    end Class_Of;


    function Instance_Of (The_Object : User_Object) return Instance_Name is
    begin
        return Instance_Name (Fact_Reference.Get_Instance (The_Object));
    end Instance_Of;


    function Class_Name_Of (The_Object : Object) return Class_Names is
    begin  
        if The_Object /= Null_Class then
            return The_Object.Class_Name;  
        else
            return Null_Class_Name;
        end if;
    end Class_Name_Of;


    function Class_Name_Of (The_Object : User_Object) return Class_Names is
    begin  
        return As_Class_Name (Fact_Reference.Get_Class (The_Object));
    end Class_Name_Of;


    function Last_Instance (Of_Class : Object) return Instance_Name is
    begin
        return Of_Class.Last_Instance;
    end Last_Instance;


    function Is_Valid_Instance
                (The_Instance : Instance_Name; Of_Class : Class.Object)
                return Boolean is
    begin
        return Of_Class /= Null_Class and then
                  The_Instance /= Null_Instance_Name and then
                  The_Instance <= Of_Class.Last_Instance;
    end Is_Valid_Instance;


    function No_User_Objects return User_Objects is
    begin
        return (1 .. 0 => Null_User_Object);
    end No_User_Objects;


    function Make (Name       : Class_Names;
                   Class_Size : Natural;
                   Names      : Slot_Names_Images) return Object is
    begin
        return new Object_Structure'
                      (Class_Size    => Instance_Name (Class_Size),
                       Class_Name    => Name,
                       Last_Instance => 0,
                       Instances     => (others => Null_Instance),
                       Images        => (Size => Names'Length, Value => Names));
    end Make;


    procedure Make_Empty (The_Class : in out Class.Object) is
    begin
        The_Class.Last_Instance := Null_Instance_Name;  
        The_Class.Instances     := (others => Null_Instance);
    end Make_Empty;


    function Match (The_Slots : Slots; Against : Query.Patterns)
                   return Boolean is
    begin
        for I in The_Slots'Range loop  
            if not Predicate_Match (The_Slots (I), Against (I)) then  
                return False;
            end if;
        end loop;
        return True;
    end Match;


    function Match (The_Instance     : Instance_Name;
                    Against_Patterns : Query.Patterns;
                    Using_Class      : Class.Object) return Boolean is
        Instances : Instance_Collection renames Using_Class.Instances;
    begin
        return Instances (The_Instance).Size /= 0 and then
                  Match (The_Slots => Instances (The_Instance).Value,
                         Against   => Against_Patterns);
    end Match;


    function Slot_Name_Image (From_Class : Class.Object; For_Slot : Slot_Names)
                             return String is
        The_String_Object : Constant_String.Object;
    begin
        The_String_Object := From_Class.Images.Value (For_Slot);
        return Constant_String.Image (The_String_Object);
    end Slot_Name_Image;


    function Get (The_Object : User_Object) return Slots is
        The_Class    : Object        := Class_Of (The_Object);
        The_Instance : Instance_Name := Instance_Of (The_Object);
    begin
        return The_Class.Instances (The_Instance).Value;
    end Get;


    function Get (The_Object : User_Object; The_Slot : Slot_Names)
                 return Slot.Object is
        The_Class    : Object        := Class_Of (The_Object);  
        The_Instance : Instance_Name := Instance_Of (The_Object);
    begin
        return The_Class.Instances (The_Instance).Value (The_Slot);
    end Get;


    procedure Add (To_Class      :     Class.Object;
                   The_Instance  :     Slots;
                   Its_Reference : out Slot.Object) is
        Content       : Instance_Collection renames To_Class.Instances;
        Last_Instance : Instance_Name       renames To_Class.Last_Instance;
        Class         : Natural := Class_Names'Pos (Class_Name_Of (To_Class));
        Id            : Natural;
        The_Reference : Fact_Reference.Object;
    begin
        for I in Content'Range loop
            if Content (I) = Null_Instance then
                Content (I) := Instance'(Size  => The_Instance'Length,
                                         Value => The_Instance);
                Id          := Natural (I);
                if I > Last_Instance then
                    Last_Instance := I;
                end if;
                The_Reference := Fact_Reference.Value (Class, Id);
                Its_Reference := Slot.Reference_Value (The_Reference);
                return;
            end if;
        end loop;
        raise Overflow;
    end Add;


    procedure Delete (The_Object : User_Object) is
        The_Class     : Object        := Class_Of (The_Object);
        The_Instance  : Instance_Name := Instance_Of (The_Object);
        Content       : Instance_Collection renames The_Class.Instances;
        Last_Instance : Instance_Name       renames The_Class.Last_Instance;
    begin
        Content (The_Instance) := Null_Instance;
        if Last_Instance = The_Instance then  
            Last_Instance := Last_Instance - 1;
            for I in reverse 1 .. Last_Instance loop
                exit when Content (I) /= Null_Instance;
                Last_Instance := I;
            end loop;
        end if;
    end Delete;


    procedure Change (The_Object : User_Object; To_Value : Slots) is
        The_Class    : Object        := Class_Of (The_Object);
        The_Instance : Instance_Name := Instance_Of (The_Object);
    begin
        The_Class.Instances (The_Instance) :=
           Instance'(Size => To_Value'Length, Value => To_Value);
    end Change;


    procedure Change (The_Object : User_Object;
                      The_Slot   : Slot_Names;
                      To_Value   : Slot.Object) is
        The_Class    : Object        := Class_Of (The_Object);
        The_Instance : Instance_Name := Instance_Of (The_Object);
    begin
        The_Class.Instances (The_Instance).Value (The_Slot) := To_Value;
    end Change;


    procedure Put_Slot (The_Slot : Slot.Object; Where : Output_Stream.Object) is
        The_Instance : User_Object;
    begin
        if Slot.Is_A_Reference (The_Slot) then
            The_Instance := As_User_Object (The_Slot);
            Default_Put (The_Instance, Where);
        else
            Slot.Put (The_Slot, Where);
        end if;
    end Put_Slot;


    procedure Put_Slots (The_Slots  : Slots;
                         The_Images : Slot_Names_Images;
                         Where      : Output_Stream.Object :=
                            Output_Stream.Standard_Output) is
        First : Boolean := True;
        use Output_Stream;
    begin
        for I in The_Slots'Range loop
            if First then
                First := False;
            else
                Put_Line (",", Where);
            end if;
            Put (Constant_String.Image (The_Images (I)) & " => ", Where);
            Put_Slot (The_Slots (I), Where);
        end loop;
    end Put_Slots;


    procedure Put_Instance (The_Class    : Class.Object;
                            The_Instance : Instance;
                            Where        : Output_Stream.Object) is
        use Output_Stream;
    begin
        if The_Instance /= Null_Instance then
            Put_Line (Class_Names'Image (The_Class.Class_Name) & "'(", Where);
            Indent_Right (Where);
            Put_Slots (The_Slots  => The_Instance.Value,
                       The_Images => The_Class.Images.Value,
                       Where      => Where);
            Indent_Left (Where);
            Put_Line (")", Where);
        end if;
    end Put_Instance;


    procedure Default_Put (The_Object : User_Object;
                           Where      : Output_Stream.Object) is  
        The_Instance : Instance_Name := Instance_Of (The_Object);
        The_Class    : Class.Object  := Class_Of (The_Object);
        use Output_Stream;
    begin
        if Is_Valid_Instance (The_Instance, The_Class) then
            Put_Line (Class_Names'Image (The_Class.Class_Name) & "'(", Where);
            Indent_Right (Where);
            Put_Slots (The_Slots  => The_Class.Instances (The_Instance).Value,
                       The_Images => The_Class.Images.Value,
                       Where      => Where);
            Indent_Left (Where);
            Put_Line (")", Where);
        else
            Put_Line ("null_object", Where);
        end if;
    end Default_Put;


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


    procedure Generic_Put (The_Class : Class.Object;
                           Where     : Output_Stream.Object) is
        use Output_Stream;
    begin
        if The_Class /= Null_Class then
            Put_Line ("Class'(", Where);
            Indent_Right (Where);
            Put_Line
               ("Kind      => " & Class_Names'Image (The_Class.Class_Name),
                Where);
            Put_Line
               ("Size      => " & Instance_Name'Image (The_Class.Last_Instance),
                Where);

            Put_Line ("Instances => Collection'(", Where);
            Indent_Right (Where);
            for I in 1 .. Last_Instance (The_Class) loop
                Put (Integer (I), Where);
                Put (" => ", Where);
                Put (As_User_Object (I, The_Class), Where);
            end loop;
            Indent_Left (Where);
            Put_Line (")", Where);
            Indent_Left (Where);
            Put_Line (")", Where);
        end if;
    end Generic_Put;

    procedure Default_Put (The_Class : Class.Object;
                           Where     : Output_Stream.Object) is
        procedure Default_Class_Put is new Generic_Put;
    begin
        Default_Class_Put (The_Class, Where);
    end Default_Put;

end Class;
DataMuseum.dk

Rational R1000/400 Tapes

⟦52e9c7314⟧ TextFile

Derivation

TextFile
