⟦9560c0730⟧

E3 Source Code



with Constant_String;
with Output_Stream;
generic

    type Class_Names is (<>);
    Null_Class_Name : Class_Names := Class_Names'Last;

    Max_Slots : Natural := 20;

    type Predicate_Object is private;
    Null_Predicate : Predicate_Object;

    with function Predicate_Match (Value : Integer; Against : Predicate_Object)
                                  return Boolean is <>;

    with procedure Predicate_Put (The_Expression : Predicate_Object;
                                  Where          : Output_Stream.Object) is <>;

package Generic_Fact_Base is

    package Query is
        subtype Query_Size      is Natural range 0 .. Max_Slots;
        type    Query_Qualifier is (Find, Check_No);

        subtype Slot_Names is Query_Size range 1 .. Max_Slots;
        type    Patterns   is array (Slot_Names range <>) of Predicate_Object;

        type Object (Size : Query_Size := 0) is
            record
                Kind  : Query_Qualifier;
                Class : Class_Names;
                Value : Patterns (1 .. Size);
            end record;

        type Objects is array (Positive range <>) of Object;

        Null_Query   : constant Object  :=
           Query.Object'(Size  => 0,
                         Kind  => Find,
                         Class => Null_Class_Name,
                         Value => (1 .. 0 => Null_Predicate));
        Null_Queries : constant Objects := (1 .. 0 => Null_Query);

        procedure Put (The_Query : Object; Where : Output_Stream.Object);
        procedure Put (The_Queries : Objects; Where : Output_Stream.Object);
    end Query;


    package Class is

        type Object is private;
        Null_Class : constant Object;

        type User_Object is private;
        Null_User_Object : constant User_Object;

        type User_Objects is array (Positive range <>) of User_Object;
        function No_User_Objects return User_Objects;

        type    Instance_Name     is new Natural;
        subtype Instance_Size     is Natural range 0 .. Max_Slots;
        subtype Slot_Names        is Instance_Size range 1 .. Max_Slots;
        type    Slots             is array (Slot_Names range <>) of Integer;
        type    Slot_Names_Images is
              array (Slot_Names range <>) of Constant_String.Object;

        function As_User_Object
                    (The_Instance : Instance_Name; For_Class : Class.Object)
                    return User_Object;

        function Class_Of      (The_Object : User_Object) return Class.Object;
        function Class_Name_Of (The_Object : User_Object) return Class_Names;
        function Class_Name_Of (The_Object : Object)      return Class_Names;
        function Last_Instance (Of_Class : Object)        return Instance_Name;

        function  Make       (Name       : Class_Names;
                              Class_Size : Natural;
                              Names      : Slot_Names_Images) return Object;
        procedure Make_Empty (The_Class : in out Class.Object);

        function Slot_Name_Image
                    (From_Class : Class.Object; For_Slot : Slot_Names)
                    return String;
        function Match (The_Instance     : Instance_Name;
                        Against_Patterns : Query.Patterns;
                        Using_Class      : Class.Object) return Boolean;

        function Get (The_Object : User_Object) return Slots;
        function Get (The_Object : User_Object; Slot : Slot_Names)
                     return Integer;

        procedure Add (To_Class : Class.Object; The_Instance : Slots);

        procedure Delete (The_Object : User_Object);

        procedure Change (The_Object : User_Object; To_Value : Slots);
        procedure Change (The_Object : User_Object;
                          Slot       : Slot_Names;
                          To_Value   : Integer);

        procedure Default_Put (The_Object : User_Object;
                               Where      : Output_Stream.Object);  
        procedure Default_Put (The_Collection : User_Objects;
                               Where          : Output_Stream.Object);
        procedure Default_Put (The_Class : Class.Object;
                               Where     : Output_Stream.Object);
        generic
            with procedure Put (The_Object : User_Object;
                                Where : Output_Stream.Object) is Default_Put;
        procedure Generic_Put (The_Class : Class.Object;
                               Where     : Output_Stream.Object);
        Overflow : exception;

    private

        Null_Instance_Name : constant Instance_Name := 0;

        type Object_Structure (Class_Size : Instance_Name);
        type Object is access Object_Structure;
        Null_Class : constant Object := null;
        type User_Object is
            record
                Isa  : Class.Object        := Class.Null_Class;
                Name : Class.Instance_Name := Class.Null_Instance_Name;
            end record;

        Null_User_Object : constant User_Object :=
           (Isa => Class.Null_Class, Name => Class.Null_Instance_Name);
    end Class;


    generic
        Class_Name : Class_Names;
        Class_Size : Natural;
        type Slot_Names is (<>);
    package Generic_Class is

        type Slots    is array (Slot_Names) of Integer;
        type Patterns is array (Slot_Names) of Predicate_Object;

        function Class_Object              return Class.Object;
        function Exist   (What : Patterns) return Query.Object;
        function Not_Any (What : Patterns) return Query.Object;
        function Absent  (What : Patterns) return Query.Object renames Not_Any;

        function Get (The_Fact : Class.User_Object) return Slots;
        function Get (The_Fact : Class.User_Object; Slot : Slot_Names)
                     return Integer;

        procedure Add    (The_Fact : Slots);
        procedure Delete (The_Fact : Class.User_Object);
        procedure Change (The_Fact : Class.User_Object; Value : Slots);
        procedure Change (The_Fact : Class.User_Object;
                          The_Slot : Slot_Names;
                          To_Value : Integer);
        generic
            with function Image (For_Slot : Slot_Names; Value : Integer)
                                return String;
        procedure Generic_Put (The_Fact : Class.User_Object;
                               Where    : Output_Stream.Object);

        Illegal_Access : exception;
    end Generic_Class;


    package Working_Memory is

        procedure Make_Empty;

        procedure Register (The_Class : Class.Object);
        function  Get      (Using : Class_Names)    return Class.Object;
        function  Retrieve (Filter : Query.Objects) return Class.User_Objects;

        generic
            with procedure Put (The_Fact : Class.User_Object;
                                Where    : Output_Stream.Object) is
               Class.Default_Put;
        procedure Generic_Put (Where : Output_Stream.Object);

        procedure Default_Put (Where : Output_Stream.Object);

    end Working_Memory;
end Generic_Fact_Base;
DataMuseum.dk

Rational R1000/400

⟦9560c0730⟧ Ada Source

Derivation

E3 Source Code

E3 Meta Data
