DataMuseum.dk

Presents historical artifacts from the history of:

Rational R1000/400

This is an automatic "excavation" of a thematic subset of
artifacts from Datamuseum.dk's BitArchive.

See our Wiki for more about Rational R1000/400

Excavated with: AutoArchaeologist - Free & Open Source Software.


top - download

⟦2c4aaa166⟧ Ada Source

    Length: 29696 (0x7400)
    Types: Ada Source
    Notes: 03_class, FILE, R1k_Segment, e3_tag, generic, package Generic_Fact_Base, seg_03c051

Derivation

└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
    └─ ⟦cfc2e13cd⟧ »Space Info Vol 2« 
        └─⟦this⟧ 

E3 Source Code



with Alias;
with Constant_String;
with Output_Stream;
with Fact_Reference;
with Slot;
generic

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


    type User_Defined_Operators is (<>);
    with function User_Defined_Unary_Match
                     (Using_Operator : User_Defined_Operators;
                      Value          : Slot.Object) return Boolean is <>;
    with function User_Defined_Binary_Match
                     (Using_Operator : User_Defined_Operators;
                      Value, Against : Slot.Object) return Boolean is <>;
    with function User_Defined_Image
                     (Op : User_Defined_Operators)  return String  is
       User_Defined_Operators'Image;


    type Expression_Object is private;
    with function  Slot_Object_Expression
                     (For_Object : Slot.Object)       return Expression_Object;
    with function  Alias_Expression
                     (For_Alias : Alias.Name)         return Expression_Object;
    with function  Expression_Evaluate
                     (The_Object : Expression_Object) return Slot.Object;
    with procedure Expression_Put (The_Object : Expression_Object;
                                   Where      : Output_Stream.Object);


package Generic_Fact_Base is

    package Predicate is

        type Object is private;
        Null_Predicate : constant Object;  
        type Objects is array (Natural range <>) of Object;

        function Define_As  (The_Alias : Alias.Name) return Object;
        function "and"      (Left, Right : Object)   return Object;
        function Collection (Of_Objects : Objects)   return Object;

        -- user defined predicates

        generic
            Operator : User_Defined_Operators;
        function Unary_User_Predicate return Object;

        generic
            Operator : User_Defined_Operators;
        function Binary_User_Predicate
                    (Using_Value : Expression_Object) return Object;

        function  Match (Value : Slot.Object; Against : Object) return Boolean;
        procedure Put   (The_Object : Object; Where : Output_Stream.Object);

        package System_Defined_Predicate is

            function Is_Equal   (The_Object : Expression_Object) return Object;
            function Is_Less    (The_Object : Expression_Object) return Object;
            function Is_Less_Or_Equal
                        (The_Object : Expression_Object) return Object;
            function Is_Greater (The_Object : Expression_Object) return Object;
            function Is_Greater_Or_Equal
                        (The_Object : Expression_Object) return Object;
            function Is_Different
                        (The_Object : Expression_Object) return Object;
            function Is_Any return Object;
            function Is_Undefined return Object;
            function Is_Defined return Object;

            -- Slot value predicates

            function Is_Equal         (The_Value : Slot.Object) return Object;
            function Is_Less          (The_Value : Slot.Object) return Object;
            function Is_Less_Or_Equal (The_Value : Slot.Object) return Object;
            function Is_Greater       (The_Value : Slot.Object) return Object;
            function Is_Greater_Or_Equal
                        (The_Value : Slot.Object)               return Object;
            function Is_Different     (The_Value : Slot.Object) return Object;

            -- Integer value predicate shortcuts

            function Is_Equal            (The_Value : Integer) return Object;
            function Is_Less             (The_Value : Integer) return Object;
            function Is_Less_Or_Equal    (The_Value : Integer) return Object;
            function Is_Greater          (The_Value : Integer) return Object;
            function Is_Greater_Or_Equal (The_Value : Integer) return Object;
            function Is_Different        (The_Value : Integer) return Object;

            -- Boolean value predicate shortcuts

            function Is_Equal     (The_Value : Boolean) return Object;
            function Is_Different (The_Value : Boolean) return Object;

            -- Float value predicate shortcuts

            function Is_Equal            (The_Value : Float) return Object;
            function Is_Less             (The_Value : Float) return Object;
            function Is_Less_Or_Equal    (The_Value : Float) return Object;
            function Is_Greater          (The_Value : Float) return Object;
            function Is_Greater_Or_Equal (The_Value : Float) return Object;
            function Is_Different        (The_Value : Float) return Object;

            -- Duration value predicate shortcuts

            function Is_Equal            (The_Value : Duration) return Object;
            function Is_Less             (The_Value : Duration) return Object;
            function Is_Less_Or_Equal    (The_Value : Duration) return Object;
            function Is_Greater          (The_Value : Duration) return Object;
            function Is_Greater_Or_Equal (The_Value : Duration) return Object;
            function Is_Different        (The_Value : Duration) return Object;

            -- Character value predicate shortcuts

            function Is_Equal            (The_Value : Character) return Object;
            function Is_Less             (The_Value : Character) return Object;
            function Is_Less_Or_Equal    (The_Value : Character) return Object;
            function Is_Greater          (The_Value : Character) return Object;
            function Is_Greater_Or_Equal (The_Value : Character) return Object;
            function Is_Different        (The_Value : Character) return Object;

            -- String value predicate shortcuts

            function Is_Equal            (The_Value : String) return Object;
            function Is_Less             (The_Value : String) return Object;
            function Is_Less_Or_Equal    (The_Value : String) return Object;
            function Is_Greater          (The_Value : String) return Object;
            function Is_Greater_Or_Equal (The_Value : String) return Object;
            function Is_Different        (The_Value : String) return Object;

            -- Alias predicate shortcuts

            function Is_Equal            (The_Alias : Alias.Name) return Object;
            function Is_Less             (The_Alias : Alias.Name) return Object;
            function Is_Less_Or_Equal    (The_Alias : Alias.Name) return Object;
            function Is_Greater          (The_Alias : Alias.Name) return Object;
            function Is_Greater_Or_Equal (The_Alias : Alias.Name) return Object;
            function Is_Different        (The_Alias : Alias.Name) return Object;

        end System_Defined_Predicate;

        Illegal_Operation : exception;
    private

        type Sub_Classes is (Primary, Unary, Binary, Undefined);
        type Object_Structure (Sub_Class : Sub_Classes);
        type Object      is access Object_Structure;
        Null_Predicate  : constant Object           := null;
        Null_Predicates : constant Objects (1 .. 0) :=
           (others => Null_Predicate);

    end Predicate;


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

        subtype Slot_Names is Query_Size range 1 .. Max_Slots;
        subtype Patterns   is Predicate.Objects;

        type Object (Size : Query_Size := 0; Kind : Query_Qualifier := Find) is
            record
                case Kind is
                    when Find | Check_No =>
                        Class : Class_Names;
                        Value : Patterns (1 .. Size);
                    when Evaluate =>
                        The_Expression : Expression_Object;
                        The_Predicate  : Predicate.Object;
                end case;
            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 => Predicate.Null_Predicate));
        Null_Queries : constant Objects := (1 .. 0 => Null_Query);

        package Operators is  
            function Match (The_Expression : Expression_Object;
                            The_Predicate  : Predicate.Object) return Boolean;

            function Satisfying (E : Expression_Object; P : Predicate.Object)
                                return Object;
            function Satisfying (The_Slot : Slot.Object; P : Predicate.Object)
                                return Object;
            function Satisfying (The_Alias : Alias.Name; P : Predicate.Object)
                                return Object;
            function Satisfying (The_Integer : Integer; P : Predicate.Object)
                                return Object;
            function Satisfying (The_Float : Float; P : Predicate.Object)  
                                return Object;
            function Satisfying (The_Boolean : Boolean; P : Predicate.Object)
                                return Object;
            function Satisfying
                        (The_Character : Character; P : Predicate.Object)
                        return Object;
            function Satisfying (The_String : String; P : Predicate.Object)
                                return Object;
            function Satisfying (The_Duration : Duration; P : Predicate.Object)
                                return Object;

        end Operators;

        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;

        subtype User_Object is Fact_Reference.Object;
        Null_User_Object : constant User_Object := Fact_Reference.Null_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 Slot.Object;
        type    Slot_Names_Images is
              array (Slot_Names range <>) of Constant_String.Object;

        function "="      (Left, Right : User_Object) return Standard.Boolean
            renames Fact_Reference."=";  
        function Is_Equal (Left, Right : Slot.Object) return Boolean;

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


        function Class_Of      (The_Object : User_Object) return Class.Object;
        function Instance_Of   (The_Object : User_Object) return Instance_Name;
        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; The_Slot : Slot_Names)
                     return Slot.Object;

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

        procedure Delete (The_Object : User_Object);

        procedure Change (The_Object : User_Object; To_Value : Slots);
        procedure Change (The_Object : User_Object;
                          The_Slot   : Slot_Names;
                          To_Value   : Slot.Object);

        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;
    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 Slot.Object;
        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 Such_As (What : Patterns) return Predicate.Object;


        function Get (The_Fact : Class.User_Object) return Slots;
        function Get (The_Fact : Class.User_Object; The_Slot : Slot_Names)
                     return Slot.Object;
        function Get (The_Fact : Class.User_Object; The_Slot : Slot_Names)
                     return Class.User_Object;
        function Get (The_Object : Class.User_Object; The_Slot : Slot_Names)
                     return Integer;
        function Get (The_Object : Class.User_Object; The_Slot : Slot_Names)
                     return Boolean;
        function Get (The_Object : Class.User_Object; The_Slot : Slot_Names)
                     return Float;
        function Get (The_Object : Class.User_Object; The_Slot : Slot_Names)
                     return Character;
        function Get (The_Object : Class.User_Object; The_Slot : Slot_Names)
                     return Duration;
        function Get (The_Object : Class.User_Object; The_Slot : Slot_Names)
                     return String;

        procedure Add    (The_Fact : Slots; Its_Reference : out Slot.Object);
        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 : Slot.Object);
        procedure Change (The_Fact : Class.User_Object;
                          The_Slot : Slot_Names;
                          To_Value : Integer);

        procedure Change (The_Fact : Class.User_Object;
                          The_Slot : Slot_Names;
                          To_Value : Boolean);

        procedure Change (The_Fact : Class.User_Object;
                          The_Slot : Slot_Names;
                          To_Value : Float);

        procedure Change (The_Fact : Class.User_Object;
                          The_Slot : Slot_Names;
                          To_Value : Character);

        procedure Change (The_Fact : Class.User_Object;
                          The_Slot : Slot_Names;
                          To_Value : Duration);

        procedure Change (The_Fact : Class.User_Object;
                          The_Slot : Slot_Names;
                          To_Value : String);

        generic
            with function Image (For_Slot : Slot_Names; Value : Slot.Object)
                                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;

        generic
            type Rule_Id         is private;
            type Instance_Object is private;
            with function  Instance_Value      (The_Rule  : Rule_Id;
                                                The_Facts : Class.User_Objects)
                                         return Instance_Object;
            with procedure Add_To_Conflict_Set (The_Instance : Instance_Object);
        procedure Retrieve_With_Conflict_Set
                     (The_Rule : Rule_Id; Filter : Query.Objects);

        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;

E3 Meta Data

    nblk1=1c
    nid=0
    hdr6=38
        [0x00] rec0=1d rec1=00 rec2=01 rec3=038
        [0x01] rec0=01 rec1=00 rec2=1b rec3=010
        [0x02] rec0=1b rec1=00 rec2=0f rec3=030
        [0x03] rec0=0e rec1=00 rec2=1a rec3=078
        [0x04] rec0=14 rec1=00 rec2=13 rec3=04a
        [0x05] rec0=01 rec1=00 rec2=19 rec3=030
        [0x06] rec0=11 rec1=00 rec2=18 rec3=092
        [0x07] rec0=04 rec1=00 rec2=0b rec3=004
        [0x08] rec0=0e rec1=00 rec2=17 rec3=080
        [0x09] rec0=04 rec1=00 rec2=0d rec3=014
        [0x0a] rec0=10 rec1=00 rec2=16 rec3=006
        [0x0b] rec0=1b rec1=00 rec2=14 rec3=056
        [0x0c] rec0=16 rec1=00 rec2=12 rec3=09c
        [0x0d] rec0=01 rec1=00 rec2=11 rec3=006
        [0x0e] rec0=13 rec1=00 rec2=0e rec3=020
        [0x0f] rec0=19 rec1=00 rec2=09 rec3=00a
        [0x10] rec0=00 rec1=00 rec2=0a rec3=010
        [0x11] rec0=14 rec1=00 rec2=15 rec3=006
        [0x12] rec0=00 rec1=00 rec2=02 rec3=034
        [0x13] rec0=17 rec1=00 rec2=10 rec3=05e
        [0x14] rec0=1a rec1=00 rec2=04 rec3=00a
        [0x15] rec0=15 rec1=00 rec2=07 rec3=03c
        [0x16] rec0=02 rec1=00 rec2=03 rec3=06c
        [0x17] rec0=14 rec1=00 rec2=0c rec3=01a
        [0x18] rec0=00 rec1=00 rec2=06 rec3=00c
        [0x19] rec0=18 rec1=00 rec2=08 rec3=02c
        [0x1a] rec0=1a rec1=00 rec2=05 rec3=07a
        [0x1b] rec0=09 rec1=00 rec2=1c rec3=000
    tail 0x21739dc788570810c02ac 0x42a00088462063c03