Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/ai/alsptype.src

Text File | 1988-05-03 | 209.8 KB | 6,279 lines

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--aitypesspc.ada
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
---------------------------------------------------------------------------

-- AI_Data_Types package specification

-- The following specification describes a set of packages which provide
-- facilities necessary to emulate the capabilities which are commonly used
-- in Artificial Intelligence (AI) applications, but not directly supported
-- in Ada.

-- These facilities are:
--
--    (1) Definitions of the primary data object to be used throughout
--        this package, the symbolic expression.
--
--    (2) Symbolic expression operators.  These include functions and
--        procedures for the creation, selection, manipulation and
--        destruction of symbolic expressions.
--
--    (3) Packages which define generic AI Objects generally found
--        useful in AI applications: patterns, rules and rulebases.

-- Developing Organization:  Software Architecture & Engineering
--                           1600 Wilson Boulevard, Suite 500
--                           Arlington, VA  22209
--
-- Contact:  Michael A. Jaskowiak

---------------------------------------------------------------------------

with Text_Io; use Text_Io;
generic

   type Atomic_Literal is private;

   with function Is_Equal (Literal_Arg1, Literal_Arg2 : in Atomic_Literal)
      return Boolean;

   Lookahead : in out Character;

   with procedure Get (Input_File : in File_Type;
               Literal_Result : in out Atomic_Literal);

   with procedure Put (Output_File : in File_Type;
               Literal_Arg : in Atomic_Literal);

package AI_Data_Types is

   package Symbolic_Expressions is

      type S_Expr is private;

      Null_S_Expr : constant S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Is_Null
      --    Description:  Determines if S_Expr_Arg = Null_S_Expr.
      --    Exceptions Raised:  None.

      function Is_Null (S_Expr_Arg : in S_Expr) return Boolean;

      -------------------------------------------------------------------------

      --    Function:     Is_Atomic
      --    Description:  Determines if S_Expr_Arg is null or if it
      --                  contains a atomic variable or user-defined literal.
      --    Exceptions Raised:  None.

      function Is_Atomic (S_Expr_Arg : in S_Expr) return Boolean;

      -------------------------------------------------------------------------

      --    Function:     Is_Non_Atomic
      --    Description:  Determines if S_Expr_Arg is a null or
      --                  non-atomic expression.
      --    Exceptions Raised:  None.

      function Is_Non_Atomic (S_Expr_Arg : in S_Expr) return Boolean;

      -------------------------------------------------------------------------

      --    Function:     Is_Variable
      --    Description:  Determines if S_Expr_Arg is an non-null
      --                  atomic expression containing a variable.
      --    Exceptions Raised:  None.

      function Is_Variable (S_Expr_Arg : in S_Expr) return Boolean;

      -------------------------------------------------------------------------

      --    Function:     Is_Equal
      --    Description:  Determines if two symbolic expressions are equivalent.
      --    Exceptions Raised:  None.

      function Is_Equal (S_Expr_Arg1, S_Expr_Arg2 : in S_Expr) return Boolean;

      -------------------------------------------------------------------------

      --    Function:     Is_Member
      --    Description:  Determines if the S_Expr_Arg is a top-level member
      --                  of the given Non_Atomic_Arg.
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.

      function Is_Member (S_Expr_Arg, Non_Atomic_Arg : in S_Expr) return Boolean;
      -------------------------------------------------------------------------

      --    Function:     Create_Atomic_Literal
      --    Description:  Returns an atomic expression containing
      --                  the given Literal_Arg.
      --    Exceptions Raised:  None.

      function Create_Atomic_Literal (Literal_Arg : in Atomic_Literal)
     return S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Create_Atomic_Variable
      --    Description:  Creates an atomic variable with the given
      --                  name and with its tag initialized to 0.
      --    Exceptions Raised:  None.

      function Create_Atomic_Variable (Name : in String) return S_Expr;

      -------------------------------------------------------------------------

      --    Procedure:    Set_Variable_Tag
      --    Description:  Set the tag of the given variable to the given number.
      --    Exceptions Raised:  Non_Atomic_Expression - if Atomic_Arg is nonatomic.
      --                        Not_A_Variable
      --                            - if the argument does not contain an atomic
      --                              variable.

      procedure Set_Variable_Tag (Atomic_Arg : in S_Expr; New_Tag : in Natural);

      -------------------------------------------------------------------------

      --    Function:     Return_Atomic_Literal
      --    Description:  Returns the atomic literal contained within the
      --                  given expression.
      --    Exceptions Raised:   Non_Atomic_Expression
      --                            -- if the argument is non-atomic.
      --                         Not_A_Literal
      --                            -- if the argument does not contain an atomic
      --                               literal.

      function Return_Atomic_Literal (Atomic_Arg : in S_Expr)
     return Atomic_Literal;

      -------------------------------------------------------------------------

      --    Function:     Return_Variable_Tag
      --    Description:  Get the tag of the given variable.
      --    Exceptions Raised:  Non_Atomic_Expression - if Atomic_Arg is nonatomic.
      --                        Not_A_Variable
      --                            - if the argument does not contain an atomic
      --                              variable.

      function Return_Variable_Tag (Atomic_Arg : in S_Expr) return Natural;

      -------------------------------------------------------------------------

      --    Function:     Return_Variable_Name
      --    Description:  Returns the name of the variable contained within the
      --                  argument (concatenated with its tag, if non-zero.)
      --    Exceptions Raised:  Non_Atomic_Expression - if Atomic_Arg is nonatomic.
      --                        Not_A_Variable
      --                            - if the argument does not contain an atomic
      --                              variable.

      function Return_Variable_Name (Atomic_Arg : in S_Expr) return String;

      -------------------------------------------------------------------------

      --    Procedure:    Free
      --    Description:  Frees the given symbolic expression.
      --    Exceptions Raised:  None.

      procedure Free (S_Expr_Arg : in out S_Expr);

      -------------------------------------------------------------------------

      --    Function:     Return_And_Free
      --    Description:  Provides a way for decrementing the ref-count of a
      --                  symbolic expression bound to a local variable being
      --                  returned from a function.
      --    Exceptions Raised:  None.

      function Return_And_Free (S_Expr_Arg : in S_Expr) return S_Expr;

      -------------------------------------------------------------------------

      --    Procedure:    Bind
      --    Description:  Sets the value of Current_Value to New_Value.
      --    Exceptions Raised:  None.

      procedure Bind (Current_Value : in out S_Expr; New_Value : in S_Expr);

      -------------------------------------------------------------------------

      --    Procedure:    Get
      --    Description:  Read a symbolic expression from the given file.
      --    Exceptions Raised: Extra_Separator, Missing_Separator,
      --                       Improper_Input, Invalid_Variable_Name.

      procedure Get (Input_File : in File_Type; S_Expr_Result : in out S_Expr);

      -------------------------------------------------------------------------

      --    Procedure:    Get
      --    Description:  Read a symbolic expression from
      --                  the current input file.
      --    Exceptions Raised: Extra_Separator, Missing_Separator,
      --                       Improper_Input, Invalid_Variable_Name.

      procedure Get (S_Expr_Result : in out S_Expr);

      -------------------------------------------------------------------------

      --    Procedure:    Put
      --    Description:  Print the structure of the input symbolic expression
      --                  to the specified output file.
      --    Exceptions Raised: None.

      procedure Put (Output_File : in File_Type; S_Expr_Arg : in S_Expr);

      -------------------------------------------------------------------------

      --    Procedure:    Put
      --    Description:  Print the structure of the input symbolic expression
      --                  to the current default output file.
      --    Exceptions Raised: None.

      procedure Put (S_Expr_Arg : in S_Expr);

      -------------------------------------------------------------------------

      --    Function:     Prefix
      --    Description:  If the second argument is atomic, Prefix returns
      --                  an expression, X, such that First(X)=First_Value
      --                  and First (Rest (X)) = Rest_Value.  Otherwise, it returns
      --                  an expression, Y, such that First(Y) = First_Value and
      --                  Rest(Y) = Rest_Value.
      --    Exceptions Raised: None.

      function Prefix (First_Value : in S_Expr;
               Rest_Value  : in S_Expr := Null_S_Expr) return S_Expr;

      -------------------------------------------------------------------------

      --    Function:     "&"
      --    Description:  Returns a symbolic expression composed of the elements
      --                  of each of the input arguments.
      --    Exceptions Raised:  None.

      function "&" (S_Expr_Arg1, S_Expr_Arg2 : in S_Expr) return S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Length
      --    Description:  Returns 0 for atomic expressions or the number of
      --                  top level components for non-atomic expressions.
      --    Exceptions Raised:  None.

      function Length (S_Expr_Arg : in S_Expr) return Natural;

      -------------------------------------------------------------------------

      --    Function:     First
      --    Description:  Returns the first component of the non-null,
      --                  non-atomic input argument.
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.

      function First (Non_Atomic_Arg : in S_Expr) return S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Rest
      --    Description:  Returns all components of the non-null, non-atomic
      --                  input argument except the first.
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.

      function Rest (Non_Atomic_Arg : in S_Expr) return S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Last
      --    Description:  Returns the last component of the non-null,
      --                  non-atomic input argument.
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.

      function Last (Non_Atomic_Arg : in S_Expr) return S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Nth
      --    Description:  Returns the position-th component of the non-null,
      --                  non-atomic input argument.
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.
      --                        Invalid_Position - if Position > # of components

      function Nth (Non_Atomic_Arg : in S_Expr;
            Position : in Positive) return S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Nth_First
      --    Description:  Returns the result of calling the function First n
      --                  times, each time using the result of the previous call
      --                  as the argument for the new iteration.
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.
      --                        Invalid_Repetitions - if Repetitions > maximum
      --                                              depth of the expression.

      function Nth_First (Non_Atomic_Arg : in S_Expr;
              Repetitions : in Positive) return S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Nth_Rest
      --    Description:  Returns the result of calling the function Rest n
      --                  times, each time using the result of the previous call
      --                  as the argument for the new iteration.
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.
      --                        Invalid_Repetitions - if Repetitions > maximum
      --                                              length of the expression.

      function Nth_Rest (Non_Atomic_Arg : in S_Expr;
             Repetitions : in Positive) return S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Reverse_S_Expr
      --    Description:  Returns a non-atomic symbolic expression with the
      --                  components of the given argument in reverse order.
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.

      function Reverse_S_Expr (Non_Atomic_Arg : in S_Expr) return S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Delete
      --    Description:  Deletes all top level occurences of the first argument
      --                  from the second.
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.

      function Delete (S_Expr_Arg, Non_Atomic_Arg : in S_Expr) return S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Replace
      --    Description:  Replaces all top level occurences of the first
      --                  argument in the third with the second.
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.

      function Replace (S_Expr_Arg1, S_Expr_Arg2, Non_Atomic_Arg : in S_Expr)
     return S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Flatten
      --    Description:  Returns a non-atomic expression which has as component
      --                  all atomic components and all atomic components of all
      --                  the non-atomic expressions within the given argument.
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.

      function Flatten (Non_Atomic_Arg : in S_Expr) return S_Expr;

      -------------------------------------------------------------------------

      --    Function:     "And"
      --    Description:  Returns a non-atomic expression which contains as
      --                  components all components which are both in the first
      --                  argument AND in the second argument with no duplicates
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg1 or
      --                                            Non_Atomic_Arg2 is
      --                                            non-null atomic.

      function "And" (Non_Atomic_Arg1, Non_Atomic_Arg2 : in S_Expr)
     return S_Expr;

      -------------------------------------------------------------------------

      --    Function:     "Or"
      --    Description:  Returns a non-atomic expression which contains as
      --                  components all components which are either in the 1st
      --                  argument OR in the second argument with no duplicates.
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg1 or
      --                                            Non_Atomic_Arg2 is
      --                                            non-null atomic.

      function "Or" (Non_Atomic_Arg1, Non_Atomic_Arg2 : in S_Expr)
     return S_Expr;

      -------------------------------------------------------------------------

      --    Function:     "-"
      --    Description:  Returns a non-atomic expression which contains as
      --                  components all those components of the first argument
      --                  which are not contained within the second with no
      --                  duplicates.
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg1 or
      --                                            Non_Atomic_Arg2 is
      --                                            non-null atomic.

      function "-" (Non_Atomic_Arg1, Non_Atomic_Arg2 : in S_Expr) return S_Expr;

      -------------------------------------------------------------------------

      --    Function:     "Xor"
      --    Description:  Returns a non-atomic expression which contains as
      --                  components all those components of the first argument
      --                  which are not components of the second and all those
      --                  components of the second argument which are not
      --                  components of the first with no duplicates.
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg1 or
      --                                            Non_Atomic_Arg2 is
      --                                            non-null atomic.

      function "Xor" (Non_Atomic_Arg1, Non_Atomic_Arg2 : in S_Expr)
     return S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Associate
      --    Description:  Returns the first component of A_Table whose
      --                  Search_Position-th component is equivalent to the Key.
      --    Exceptions Raised:  Atomic_Expression - if A_Table is atomic.

      function Associate (Key, A_Table : in S_Expr;
              Search_Position : Positive := 1) return S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Associate_All
      --    Description:  Returns a non-atomic expression containing ALL the
      --                  components of A_Table whose Search_Position-th
      --                  component is equivalent to the Key.
      --    Exceptions Raised:  Atomic_Expression - if A_Table is atomic.

      function Associate_All (Key, A_Table : in S_Expr;
                  Search_Position : Positive := 1) return S_Expr;

      Atomic_Expression, Non_Atomic_Expression, Invalid_Position,
      Missing_Separator, Extra_Separator, Improper_Input,
      Invalid_Variable_Name, Not_A_Literal, Not_A_Variable,
      Invalid_Repetitions : exception;

   private

      type Atomic_Expr_Kind is (Literal, Variable);

      type Var_Kind is (Var1,  Var2,  Var3,  Var4,  Var5,
            Var6,  Var7,  Var8,  Var9,  Var10,
            Var11, Var12, Var13, Var14, Var15);

      type Atomic_Variable (Kind : Var_Kind := Var1) is
     record
        Tag  : Natural;
        case Kind is
           when Var1  => Var1  : String (1 .. 1);
           when Var2  => Var2  : String (1 .. 2);
           when Var3  => Var3  : String (1 .. 3);
           when Var4  => Var4  : String (1 .. 4);
           when Var5  => Var5  : String (1 .. 5);
           when Var6  => Var6  : String (1 .. 6);
           when Var7  => Var7  : String (1 .. 7);
           when Var8  => Var8  : String (1 .. 8);
           when Var9  => Var9  : String (1 .. 9);
           when Var10 => Var10 : String (1 .. 10);
           when Var11 => Var11 : String (1 .. 11);
           when Var12 => Var12 : String (1 .. 12);
           when Var13 => Var13 : String (1 .. 13);
           when Var14 => Var14 : String (1 .. 14);
           when Var15 => Var15 : String (1 .. 15);
        end case;
     end record;

      type Atomic_Expr (Kind : Atomic_Expr_Kind := Literal) is
     record
        case Kind is
           when Literal  => Literal : Atomic_Literal;
           when Variable => Variable : Atomic_Variable;
        end case;
     end record;

      type Node_Category is (Atomic, Non_Atomic);

      type Node (Category : Node_Category);

      type S_Expr is access Node;

      Null_S_Expr : constant S_Expr := null;

      type Node (Category : Node_Category) is
     record
        Ref_Count : Natural;
        case Category is
           when Atomic     => Value : Atomic_Expr;
                  Next_Free : S_Expr;
           when Non_Atomic => First, Rest : S_Expr;
        end case;
     end record;

   end Symbolic_Expressions;

   package Patterns is

      package SE renames Symbolic_Expressions;

      subtype Pattern is SE.S_Expr;
      Null_Pattern : Pattern renames SE.Null_S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Is_Null
      --    Description:  Determines if Pattern_Arg = Null_Pattern.
      --    Exceptions Raised:  None.

      function Is_Null (Pattern_Arg : in Pattern) return Boolean;

      -------------------------------------------------------------------------

      --    Function:     Is_Equal
      --    Description:  Determines if two patterns are equal by determining
      --                  if their instantiations are equal.
      --    Exceptions Raised:  None.

      function Is_Equal (Pattern1, Pattern2 : in Pattern) return Boolean;

      -------------------------------------------------------------------------

      --    Function:     Create_Pattern
      --    Description:  Creates a pattern. The symbolic expression forms the
      --                  pattern's template and the pattern's variable binding
      --                  context is set to null.
      --    Exceptions Raised:  None.

      function Create_Pattern (Template : in SE.S_Expr;
                   Bindings : in SE.S_Expr:= SE.Null_S_Expr)
     return Pattern;

      ----------------------------------------------------------------------

      --    Function:     Tag_Variables
      --    Description:  Tags all variables within a pattern with the same
      --                  tag.  This can be used to make a particular pattern
      --                  unique with respect to other patterns.
      --    Exceptions Raised:  None.

      procedure Tag_Variables (Pattern_Arg : in Pattern; Tag : in Natural);

      -------------------------------------------------------------------------

      --    Function:     Get_Template
      --    Description:  Returns the template portion of the given pattern.
      --    Exceptions Raised:  None.

      function Get_Template (Pattern_Arg : in Pattern) return SE.S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Instantiate
      --    Description:  Returns a symbolic expression created by replacing
      --                  all variables in the pattern argument's template with
      --                  their current bindings (found in the variable binding
      --                  context).
      --    Exceptions Raised:  None.

      function Instantiate (Pattern_Arg : in Pattern) return SE.S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Get_Bindings
      --    Description:  Returns a symbolic expression representing the current
      --                  bindings of the variables found in the pattern
      --                  argument's template.
      --    Exceptions Raised:  None.

      function Get_Bindings (Pattern_Arg : in Pattern) return SE.S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Set_Bindings
      --    Description:  Sets the variable binding context for the pattern
      --                  to the specified context.  NOTE: This function can
      --                  also be used to erase the current context by setting
      --                  the bindings to null.
      --    Exceptions Raised:  None.

      function Set_Bindings (Pattern_Arg : in Pattern;
                 Bindings : in SE.S_Expr) return Pattern;

      procedure Bind (Current_Value : in out Pattern;  New_Value : in Pattern)
     renames SE.Bind;

      procedure Free (Pattern_Arg : in out Pattern) renames SE.Free;

      function Return_And_Free (Pattern_Arg : in Pattern) return Pattern
     renames SE.Return_And_Free;

      -------------------------------------------------------------------------

      --    Function:     First
      --    Description:  Returns a pattern whose template consists of the
      --                  first component of the argument.  The variable binding
      --                  context of the new pattern is the same as that of the
      --                  argument.
      --    Exceptions Raised:  Atomic_Template -- if the pattern template
      --                                           is an atomic expression.

      function First (Pattern_Arg : in Pattern) return Pattern;

      -------------------------------------------------------------------------

      --    Function:     Rest
      --    Description:  Returns a pattern whose template consists of the all
      --                  but the first component of the argument.  The variable
      --                  binding context of the new pattern is the same as that
      --                  of the argument.
      --    Exceptions Raised:  Atomic_Template -- if the pattern template
      --                                           is an atomic expression.

      function Rest (Pattern_Arg : in Pattern) return Pattern;

      -------------------------------------------------------------------------

      --    Function:     Match
      --    Description:  If the two pattern arguments can be made identical by
      --                  variable substitution, Is_Match will be set to True
      --                  and the variable binding contexts of Pattern1 and
      --                  Pattern2 will contain the particular set of bindings
      --                  which made the patterns identical.  Otherwise,Is_Match
      --                  will be False and the variable binding contexts for
      --                  the two patterns will remain unchanged.
      --    References:   The pattern matching algorithms used are based upon
      --                  those found in the following reference:
      --
      --                  Wilensky, Robert.  LISPCRAFT.
      --                  New York: W. W. Norton & Co., Inc., 1984.
      --    Exceptions Raised:  None.

      procedure Match (Pattern1, Pattern2 : in out Pattern;
               Is_Match : out Boolean);

      -------------------------------------------------------------------------

      --    Procedure:    Get
      --    Description:  Read a pattern from the specified input file.
      --    Exceptions Raised: None.

      procedure Get (Input_File : in File_Type;
             Pattern_Result : in out Pattern);

      -------------------------------------------------------------------------

      --    Procedure:    Get
      --    Description:  Read a pattern from the current default input file.
      --    Exceptions Raised: None.

      procedure Get (Pattern_Result : in out Pattern);

      -------------------------------------------------------------------------

      --    Procedure:    Put
      --    Description:  Print the structure of the input pattern
      --                  to the specified output file.
      --    Exceptions Raised:  None.

      procedure Put (Output_File : in File_Type; Pattern_Arg : in Pattern);

      -------------------------------------------------------------------------

      --    Procedure:    Put
      --    Description:  Print the structure of the input pattern
      --                  to the current default output file.
      --    Exceptions Raised: None.

      procedure Put (Pattern_Arg : in Pattern);

      Atomic_Template : exception;

   end Patterns;


   package Rules is
      package SE renames Symbolic_Expressions;
      package PAT renames Patterns;

      subtype Rule is PAT.Pattern;
      Null_Rule : Rule renames PAT.Null_Pattern;

      -------------------------------------------------------------------------

      --    Function:     Create_Rule
      --    Description:  Creates a rule. The symbolic expressions form the
      --                  rule's template and the rule's variable binding
      --                  context is set to null.
      --    Exceptions Raised:  None.

      function Create_Rule (Antecedent,
                Consequent,
                Bindings : in SE.S_Expr := SE.Null_S_Expr)
     return Rule;

      procedure Tag_Variables (Rule_Arg : in Rule; Tag : in Natural)
     renames PAT.Tag_Variables;

      -------------------------------------------------------------------------

      --    Function:     Antecedent
      --    Description:  Returns the antecedent of the given rule.
      --    Exceptions Raised:  None.

      function Antecedent (Rule_Arg : in Rule) return PAT.Pattern;

      -------------------------------------------------------------------------

      --    Function:     Consequent
      --    Description:  Returns the consequent of the given rule.
      --    Exceptions Raised:  None.

      function Consequent (Rule_Arg : in Rule) return PAT.Pattern;

      -------------------------------------------------------------------------

      --    Function:     Is_Query
      --    Description:  Determines if the rule is a query.
      --                  A query is a rule which has only a antecedent.
      --    Exceptions Raised:  None.

      function Is_Query (Rule_Arg : in Rule) return Boolean;

      -------------------------------------------------------------------------

      --    Function:     Is_Fact
      --    Description:  Determines if the rule is a fact.
      --                  A fact is a rule which has only a consequent.
      --    Exceptions Raised:  None.

      function Is_Fact (Rule_Arg : in Rule) return Boolean;

      -------------------------------------------------------------------------

      --    Function:     Is_Rule
      --    Description:  Determines if the given rule contains
      --                  both a antecedent and a consequent.
      --    Exceptions Raised:  None.

      function Is_Rule (Rule_Arg : in Rule) return Boolean;

      function Is_Null (Rule_Arg : in Rule) return Boolean
     renames PAT.Is_Null;

      function Is_Equal (Rule1, Rule2 : in Rule) return Boolean
     renames PAT.Is_Equal;

      function Get_Template (Rule_Arg : in Rule) return SE.S_Expr
     renames PAT.Get_Template;

      function Instantiate (Rule_Arg : in Rule) return SE.S_Expr
     renames PAT.Instantiate;

      function Get_Bindings (Rule_Arg : in Rule) return SE.S_Expr
     renames PAT.Get_Bindings;

      function Set_Bindings (Rule_Arg : in Rule;
                 Bindings : in SE.S_Expr) return Rule
     renames PAT.Set_Bindings;

      procedure Bind (Current_Value : in out Rule;  New_Value : in Rule)
     renames PAT.Bind;

      procedure Free (Rule_Arg : in out Rule) renames PAT.Free;

      function Return_And_Free (Rule_Arg : in Rule) return Rule
     renames PAT.Return_And_Free;

      procedure Match (Rule1, Rule2 : in out Rule; Is_Match : out Boolean)
     renames PAT.Match;

      -------------------------------------------------------------------------

      --    Procedure:    Get
      --    Description:  Read a rule from the specified input file.
      --    Exceptions Raised: Invalid_Rule_Format - if the input does not
      --                                             contain both an antecedent
      --                                             and consequent.

      procedure Get (Input_File : in File_Type; Rule_Result : in out Rule);

      -------------------------------------------------------------------------

      --    Procedure:    Get
      --    Description:  Read a rule from the current default input file.
      --    Exceptions Raised: None.

      procedure Get (Rule_Result : in out Rule);

      procedure Put (Rule_Arg : in Rule)
     renames PAT.Put;

      procedure Put (Output_File : in File_Type; Rule_Arg : in Rule)
     renames PAT.Put;

      Atomic_Template : exception renames PAT.Atomic_Template;
      Invalid_Rule_Format : exception;
   end Rules;


   generic

      type Index is ( <> );

      with function Key (Rule_Arg : in Rules.Rule) return Index;

   package Rulebases is
      package SE renames Symbolic_Expressions;
      package PAT renames Patterns;
      package RUL renames Rules;

      type Rulebase is private;
      Null_Rulebase : constant Rulebase;

      -------------------------------------------------------------------------

      --    Function:     Is_Null
      --    Description:  Determines if Rulebase_Arg is empty.
      --    Exceptions Raised:  None.

      function Is_Null (Rulebase_Arg : in Rulebase) return Boolean;

      -------------------------------------------------------------------------

      --    Function:     Is_Equal
      --    Description:  Determines if Rulebase_Arg1 is equivalent
      --                  to Rulebase_Arg2.
      --    Exceptions Raised:  None.

      function Is_Equal (Rulebase_Arg1, Rulebase_Arg2 : in Rulebase)
     return Boolean;

      -------------------------------------------------------------------------

      --    Function:     Create_Rulebase
      --    Description:  Creates a rulebase from the given symbolic expression.
      --    Exceptions Raised:  None.

      function Create_Rulebase (Template : in SE.S_Expr) return Rulebase;

      -------------------------------------------------------------------------

      --    Function:     Get_Template
      --    Description:  Returns a symbolic expression representing the
      --                  template for the given rulebase.
      --    Exceptions Raised:  None.

      function Get_Template (Rulebase_Arg : in Rulebase) return SE.S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Assert
      --    Description:  Adds the given rule to the specified rulebase.
      --    Exceptions Raised:  None.

      procedure Assert (Rule_Arg : in RUL.Rule; Rulebase_Arg : in out Rulebase);

      -------------------------------------------------------------------------

      --    Function:     Retract
      --    Description:  Removes all occurrences of the given rule from the
      --                  specified rulebase.
      --    Exceptions Raised:  None.

      procedure Retract (Rule_Arg : in RUL.Rule;
             Rulebase_Arg : in out Rulebase);

      -------------------------------------------------------------------------

      --    Function:     Retrieve
      --    Description:  Returns a symbolic expression containing instantiated
      --                  versions of all rules which matched the input query.
      --    Exceptions Raised:  None.

      function Retrieve (Rule_Arg : in RUL.Rule;
             Rulebase_Arg : in Rulebase) return SE.S_Expr;

      -------------------------------------------------------------------------

      --    Function:     "And" (Intersection)
      --    Description:  Returns a rulebase containing all those rules
      --                  which are both in Rulebase1 AND Rulebase2.
      --    Exceptions Raised:  None.

      function "And" (Rulebase1, Rulebase2 : in Rulebase) return Rulebase;

      -------------------------------------------------------------------------

      --    Function:     "Or" (Union)
      --    Description:  Returns a rulebase containing all those rules
      --                  which are either in Rulebase1 OR Rulebase2.
      --    Exceptions Raised:  None.

      function "Or" (Rulebase1, Rulebase2 : in Rulebase) return Rulebase;

      -------------------------------------------------------------------------

      --    Function:     "-" (Difference)
      --    Description:  Returns a rulebase containing all those rules
      --                  which are in Rulebase1 but NOT in Rulebase2.
      --    Exceptions Raised:  None.

      function "-" (Rulebase1, Rulebase2 : in Rulebase) return Rulebase;

      -------------------------------------------------------------------------

      --    Function:     "Xor" (Exclusive Or)
      --    Description:  Returns a rulebase containing all those rules
      --                  which are in Rulebase1 but NOT Rulebase2 AND
      --                  all those rules which are in Rulebase2 but NOT
      --                  in Rulebase1.
      --    Exceptions Raised:  None.

      function "Xor" (Rulebase1, Rulebase2 : in Rulebase) return Rulebase;

      -------------------------------------------------------------------------

      --    Function:     Bind
      --    Description:  Assigns the value of New_Value to Current_Value after
      --                  freeing the value of Current_Value.
      --    Exceptions Raised:  None.

      procedure Bind (Current_Value : in out Rulebase;
              New_Value : in Rulebase);

      -------------------------------------------------------------------------

      --    Function:     Free
      --    Description:  Frees the given rulebase.
      --    Exceptions Raised:  None.

      procedure Free (Rulebase_Arg : in out Rulebase);

      -------------------------------------------------------------------------

      --    Function:     Return_And_Free
      --    Description:  Provides a way for decrementing the ref-count of a
      --                  rulebase bound to a local variable being returned
      --                  from a function.
      --    Exceptions Raised:  None.

      function Return_And_Free (Rulebase_Arg : in Rulebase) return Rulebase;

      -------------------------------------------------------------------------

      --    Procedure:    Get
      --    Description:  Reads a rulebase from the given input file.
      --    Exceptions Raised:  None.

      procedure Get (Input_File : in File_Type;
             Rulebase_Result : in out Rulebase);

      -------------------------------------------------------------------------

      --    Procedure:    Get
      --    Description:  Reads a rulebase from the current default input file.
      --    Exceptions Raised:  None.

      procedure Get (Rulebase_Result : in out Rulebase);

      -------------------------------------------------------------------------

      --    Procedure:    Put
      --    Description:  Prints the contents of a rulebase to the given
      --                  output file.
      --    Exceptions Raised:  None.

      procedure Put (Output_File : in File_Type;
             Rulebase_Arg : in Rulebase);

      -------------------------------------------------------------------------

      --    Procedure:    Put
      --    Description:  Prints the contents of a rulebase to the current
      --                  default output file.
      --    Exceptions Raised:  None.

      procedure Put (Rulebase_Arg : in Rulebase);

      Invalid_Rulebase_Format : exception;

  private

      type Rulebase_Node;

      type Rulebase is access Rulebase_Node;

      Null_Rulebase : constant Rulebase := null;

      type Rule_Array is array (Index) of RUL.Rule;

      type Rulebase_Node is
       record
          Ref_Count : Natural;
          Next_Free : Rulebase;
          Rules     : Rule_Array;
       end record;

   end Rulebases;

end AI_Data_Types;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--aitypesimp.ada
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
---------------------------------------------------------------------------

-- AI_Data_Types package implementation

-- The following implementation describes a set of packages which provide
-- facilities necessary to emulate the capabilities which are commonly used
-- in Artificial Intelligence (AI) applications, but not directly supported
-- in Ada.

-- These facilities are:
--
--    (1) Definitions of the primary data object to be used throughout
--        this package, the symbolic expression.
--
--    (2) Symbolic expression operators.  These include functions and
--        procedures for the creation, selection, manipulation and
--        destruction of symbolic expressions.
--
--    (3) Packages which define generic AI Objects generally found
--        useful in AI applications: patterns, rules and rulebases.

-- Developing Organization:  Software Architecture & Engineering
--                           1600 Wilson Boulevard, Suite 500
--                           Arlington, VA  22209
--
-- Contact:  Michael A. Jaskowiak

---------------------------------------------------------------------------

with Integer_Text_Io;
package body AI_Data_Types is

   package body Symbolic_Expressions is

      use Integer_Text_Io;

      Atomic_Free_List, Non_Atomic_Free_List : S_Expr := Null_S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Is_Null
      --    Visibility:   Exported.
      --    Description:  Determines if S_Expr_Arg = Null_S_Expr.
      --
      --    Exceptions Raised:  None.

      function Is_Null (S_Expr_Arg : in S_Expr) return Boolean is
      begin
     return S_Expr_Arg = Null_S_Expr;
      end Is_Null;

      -------------------------------------------------------------------------

      --    Function:     Is_Atomic
      --    Visibility:   Exported.
      --    Description:  Determines if S_Expr_Arg is null or if it
      --                  contains a atomic variable or user-defined literal.
      --
      --    Exceptions Raised:  None.

      function Is_Atomic (S_Expr_Arg : in S_Expr) return Boolean is
      begin
     return Is_Null (S_Expr_Arg) or else S_Expr_Arg.Category = Atomic;
      end Is_Atomic;

      -------------------------------------------------------------------------

      --    Function:     Is_Variable
      --    Visibility:   Exported.
      --    Description:  Determines if S_Expr_Arg is an non-null
      --                  atomic expression containing a variable.
      --
      --    Exceptions Raised:  None.

      function Is_Variable (S_Expr_Arg : in S_Expr) return Boolean is
      begin
     return not Is_Null(S_Expr_Arg) and then
        S_Expr_Arg.Category = Atomic and then
        S_Expr_Arg.Value.Kind = Variable;
      end Is_Variable;

      -------------------------------------------------------------------------

      --    Function:     Is_Non_Atomic
      --    Visibility:   Exported.
      --    Description:  Determines if S_Expr_Arg is a null or
      --                  non-atomic expression.
      --
      --    Exceptions Raised:  None.

      function Is_Non_Atomic (S_Expr_Arg : in S_Expr) return Boolean is
      begin
     return Is_Null(S_Expr_Arg) or else S_Expr_Arg.Category = Non_Atomic;
      end Is_Non_Atomic;

      -------------------------------------------------------------------------

      --    Function:     Create_Atomic_Node
      --    Visibility:   Internal.
      --    Description:  Returns an atomic expression containing the given value.
      --
      --    Exceptions Raised:  None.

      function Create_Atomic_Node (Value_Of_Node : in Atomic_Expr) return S_Expr is
     New_Node : S_Expr := Null_S_Expr;
      begin

     -- If the atomic free list is empty, allocate a new node.
     -- Otherwise, retrieve a node from the free list.

     if Is_Null (Atomic_Free_List) then
        New_Node := new Node (Atomic);
     else
        New_Node := Atomic_Free_List;
        Atomic_Free_List := Atomic_Free_List.Next_Free;
     end if;

     -- Initialize the node's reference counter, free list pointer and value.

     New_Node.Ref_Count := 0;
     New_Node.Next_Free := Null_S_Expr;
     New_Node.Value     := Value_Of_Node;

     return New_Node;
      end Create_Atomic_Node;

      -------------------------------------------------------------------------

      --    Function:     Create_Atomic_Literal
      --    Visibility:   Exported.
      --    Description:  Returns an atomic expression containing
      --                  the given Literal_Arg.
      --
      --    Exceptions Raised:  None.

      function Create_Atomic_Literal (Literal_Arg : in Atomic_Literal)
     return S_Expr is
     Atomic_Value : Atomic_Expr (Kind => Literal);
      begin
     Atomic_Value.Literal := Literal_Arg;
     return Create_Atomic_Node (Value_Of_Node => Atomic_Value);
      end Create_Atomic_Literal;

      -------------------------------------------------------------------------

      --    Function:     Create_Atomic_Variable
      --    Visibility:   Exported.
      --    Description:  Creates an atomic variable with the given
      --                  name and with its tag initialized to 0.
      --
      --    Exceptions Raised:  None.

      function Create_Atomic_Variable (Name : in String) return S_Expr is
     Var_Name     : String (1 .. Name'Length) := Name;
     Var_Value    : Atomic_Variable;
     Atomic_Value : Atomic_Expr (Kind => Variable);
      begin
     case Var_Name'Length is
        when 1  => Var_Value := (Kind => Var1, Tag => 0, Var1  => Var_Name);
        when 2  => Var_Value := (Kind => Var2, Tag => 0, Var2  => Var_Name);
        when 3  => Var_Value := (Kind => Var3, Tag => 0, Var3  => Var_Name);
        when 4  => Var_Value := (Kind => Var4, Tag => 0, Var4  => Var_Name);
        when 5  => Var_Value := (Kind => Var5, Tag => 0, Var5  => Var_Name);
        when 6  => Var_Value := (Kind => Var6, Tag => 0, Var6  => Var_Name);
        when 7  => Var_Value := (Kind => Var7, Tag => 0, Var7  => Var_Name);
        when 8  => Var_Value := (Kind => Var8, Tag => 0, Var8  => Var_Name);
        when 9  => Var_Value := (Kind => Var9, Tag => 0, Var9  => Var_Name);
        when 10 => Var_Value := (Kind => Var10,Tag => 0, Var10 => Var_Name);
        when 11 => Var_Value := (Kind => Var11,Tag => 0, Var11 => Var_Name);
        when 12 => Var_Value := (Kind => Var12,Tag => 0, Var12 => Var_Name);
        when 13 => Var_Value := (Kind => Var13,Tag => 0, Var13 => Var_Name);
        when 14 => Var_Value := (Kind => Var14,Tag => 0, Var14 => Var_Name);
        when 15 => Var_Value := (Kind => Var15,Tag => 0, Var15 => Var_Name);
        when others => raise Constraint_Error;
     end case;

     Atomic_Value.Variable := Var_Value;
     return Create_Atomic_Node (Value_Of_Node => Atomic_Value);
      end Create_Atomic_Variable;

      -------------------------------------------------------------------------

      --    Procedure:    Set_Variable_Tag
      --    Visibility:   Exported.
      --    Description:  Set the tag of the given variable to the given number.
      --
      --    Exceptions Raised:  Non_Atomic_Expression - if Atomic_Arg is nonatomic.
      --                        Not_A_Variable
      --                            - if the argument does not contain an atomic
      --                              variable.

      procedure Set_Variable_Tag (Atomic_Arg : in S_Expr; New_Tag : in Natural) is
      begin
     if Is_Non_Atomic (Atomic_Arg) then
        raise Non_Atomic_Expression;
     end if;

     -- If the expression does not contain an atomic variable, complain.
     -- Otherwise, set the variable's tag value to the value of the new tag.

     if Atomic_Arg.Value.Kind /= Variable then
        raise Not_A_Variable;
     else
        Atomic_Arg.Value.Variable.Tag := New_Tag;
     end if;
      end Set_Variable_Tag;

      -------------------------------------------------------------------------

      --    Function:     Create_Non_Atomic_Node
      --    Visibility:   Internal.
      --    Description:  Creates a non_atomic expression with the values of
      --                  its First and Rest fields set accordingly.
      --
      --    Exceptions Raised:   None.

      function Create_Non_Atomic_Node (Value_Of_First,
                       Value_Of_Rest : in S_Expr := Null_S_Expr)
     return S_Expr is
     New_Node : S_Expr := Null_S_Expr;
      begin

     -- Adjust the reference count of the value assigned to the First field.

     if not Is_Null(Value_Of_First) then
        Value_Of_First.Ref_Count := Value_Of_First.Ref_Count + 1;
     end if;

     -- Adjust the reference count of the value assigned to the Rest field.

     if not Is_Null(Value_Of_Rest) then
        Value_Of_Rest.Ref_Count := Value_Of_Rest.Ref_Count + 1;
     end if;

     -- If the non-atomic node free list is empty, allocate a new node.
     -- Otherwise, retrieve a node from the free list.

     if Is_Null (Non_Atomic_Free_List) then
        New_Node := new Node (Non_Atomic);
     else
        New_Node := Non_Atomic_Free_List;
        Non_Atomic_Free_List := Non_Atomic_Free_List.Rest;
     end if;

     -- Initialize the node's reference counter, first and rest field values.

     New_Node.Ref_Count := 0;
     New_Node.First     := Value_Of_First;
     New_Node.Rest      := Value_Of_Rest;

     return New_Node;
      end Create_Non_Atomic_Node;

      -------------------------------------------------------------------------

      --    Function:     Return_Atomic_Literal
      --    Visibility:   Exported.
      --    Description:  Returns the atomic literal contained within the
      --                  given expression.
      --
      --    Exceptions Raised:   Non_Atomic_Expression
      --                            -- if the argument is non-atomic.
      --                         Not_A_Literal
      --                            -- if the argument does not contain an atomic
      --                               literal.

      function Return_Atomic_Literal (Atomic_Arg : in S_Expr)
     return Atomic_Literal is
      begin
     if Is_Non_Atomic (Atomic_Arg) then
        raise Non_Atomic_Expression;
     end if;

     -- If the expression does not contain an atomic literal, complain.
     -- Otherwise, return the literal contained within the expression.

     if Atomic_Arg.Value.Kind /= Literal then
        raise Not_A_Literal;
     else
        return Atomic_Arg.Value.Literal;
     end if;
      end Return_Atomic_Literal;

      -------------------------------------------------------------------------

      --    Function:     Return_Variable_Name
      --    Visibility:   Exported.
      --    Description:  Returns the name of the variable contained within the
      --                  argument (concatenated with its tag, if non-zero.)
      --
      --    Exceptions Raised:  Non_Atomic_Expression - if Atomic_Arg is nonatomic.
      --                        Not_A_Variable
      --                            - if the argument does not contain an atomic
      --                              variable.

      function Return_Variable_Name (Atomic_Arg : in S_Expr) return String is
      begin
     if Is_Non_Atomic (Atomic_Arg) then
        raise Non_Atomic_Expression;
     end if;

     -- If the expression does not contain an atomic variable, complain.
     -- Otherwise, return the name of the variable contained within the
     -- argument (concatenated with its tag if non-zero).

     if Atomic_Arg.Value.Kind /= Variable then
        raise Not_A_Variable;
     elsif Atomic_Arg.Value.Variable.Tag = 0 then
        case Atomic_Arg.Value.Variable.Kind is
           when Var1  => return Atomic_Arg.Value.Variable.Var1;
           when Var2  => return Atomic_Arg.Value.Variable.Var2;
           when Var3  => return Atomic_Arg.Value.Variable.Var3;
           when Var4  => return Atomic_Arg.Value.Variable.Var4;
           when Var5  => return Atomic_Arg.Value.Variable.Var5;
           when Var6  => return Atomic_Arg.Value.Variable.Var6;
           when Var7  => return Atomic_Arg.Value.Variable.Var7;
           when Var8  => return Atomic_Arg.Value.Variable.Var8;
           when Var9  => return Atomic_Arg.Value.Variable.Var9;
           when Var10 => return Atomic_Arg.Value.Variable.Var10;
           when Var11 => return Atomic_Arg.Value.Variable.Var11;
           when Var12 => return Atomic_Arg.Value.Variable.Var12;
           when Var13 => return Atomic_Arg.Value.Variable.Var13;
           when Var14 => return Atomic_Arg.Value.Variable.Var14;
           when Var15 => return Atomic_Arg.Value.Variable.Var15;
        end case;
     else
        declare
           Tag_Image : constant String
                  := Natural'Image(Atomic_Arg.Value.Variable.Tag);
           Tag_Rep : constant String := Tag_Image (2 .. Tag_Image'Last);
        begin
           case Atomic_Arg.Value.Variable.Kind is
          when Var1  => return Atomic_Arg.Value.Variable.Var1 & Tag_Rep;
          when Var2  => return Atomic_Arg.Value.Variable.Var2 & Tag_Rep;
          when Var3  => return Atomic_Arg.Value.Variable.Var3 & Tag_Rep;
          when Var4  => return Atomic_Arg.Value.Variable.Var4 & Tag_Rep;
          when Var5  => return Atomic_Arg.Value.Variable.Var5 & Tag_Rep;
          when Var6  => return Atomic_Arg.Value.Variable.Var6 & Tag_Rep;
          when Var7  => return Atomic_Arg.Value.Variable.Var7 & Tag_Rep;
          when Var8  => return Atomic_Arg.Value.Variable.Var8 & Tag_Rep;
          when Var9  => return Atomic_Arg.Value.Variable.Var9 & Tag_Rep;
          when Var10 => return Atomic_Arg.Value.Variable.Var10 & Tag_Rep;
          when Var11 => return Atomic_Arg.Value.Variable.Var11 & Tag_Rep;
          when Var12 => return Atomic_Arg.Value.Variable.Var12 & Tag_Rep;
          when Var13 => return Atomic_Arg.Value.Variable.Var13 & Tag_Rep;
          when Var14 => return Atomic_Arg.Value.Variable.Var14 & Tag_Rep;
          when Var15 => return Atomic_Arg.Value.Variable.Var15 & Tag_Rep;
           end case;
        end;
     end if;
      end Return_Variable_Name;

      -------------------------------------------------------------------------

      --    Function:     Return_Variable_Tag
      --    Visibility:   Exported.
      --    Description:  Get the tag of the given variable.
      --
      --    Exceptions Raised:  Non_Atomic_Expression - if Atomic_Arg is nonatomic.
      --                        Not_A_Variable
      --                            - if the argument does not contain an atomic
      --                              variable.

      function Return_Variable_Tag (Atomic_Arg : in S_Expr) return Natural is
      begin
     if Is_Non_Atomic (Atomic_Arg) then
        raise Non_Atomic_Expression;
     end if;

     -- If the expression does not contain an atomic variable, complain.
     -- Otherwise, return the value of the variable's tag.

     if Atomic_Arg.Value.Kind /= Variable then
        raise Not_A_Variable;
     else
        return Atomic_Arg.Value.Variable.Tag;
     end if;
      end Return_Variable_Tag;

      -------------------------------------------------------------------------

      --    Function:     Compare_Variables
      --    Visibility:   Internal.
      --    Description:  Determines if two variables are equivalent.
      --
      --    Exceptions Raised:  None.

      function Compare_Variables (S_Expr_Arg1, S_Expr_Arg2 : in S_Expr)
     return Boolean is
      begin
     return Return_Variable_Name (S_Expr_Arg1)
           = Return_Variable_Name (S_Expr_Arg2);
      end Compare_Variables;

      -------------------------------------------------------------------------

      --    Procedure:    Push
      --    Visibility:   Internal.
      --    Description:  Adds the given Element to the top of the given Stack.
      --
      --    Exceptions Raised:  None.

      procedure Push (Element : in S_Expr;
              Stack   : in out S_Expr) is
     Temp : S_Expr := Null_S_Expr;
      begin
     Temp := Create_Non_Atomic_Node;
     Temp.First := Element;
     Temp.Rest := Stack;
     Stack := Temp;
      end Push;

      -------------------------------------------------------------------------

      --    Procedure:    Pop
      --    Visibility:   Internal.
      --    Description:  Retrieves an element from the top of the given Stack.
      --
      --    Exceptions Raised: None.

      procedure Pop (Stack : in out S_Expr;
             Pop_Result : out S_Expr) is
     Temp : S_Expr := Null_S_Expr;
      begin
     if Is_Null (Stack.First) then
        Temp := Stack;
        Stack := Stack.Rest;
        Temp.Rest := Non_Atomic_Free_List;
        Non_Atomic_Free_List := Temp;
        Pop_Result := Null_S_Expr;
     else
        Pop_Result := Stack.First.First;
        Stack.First := Stack.First.Rest;
     end if;
      end Pop;

      -------------------------------------------------------------------------

      --    Function:     Is_Equal
      --    Visibility:   Exported.
      --    Description:  Determines if two symbolic expressions are equivalent.
      --
      --    Exceptions Raised:  None.

      function Is_Equal (S_Expr_Arg1, S_Expr_Arg2 : in S_Expr) return Boolean is
      begin

     -- If the two pointers are equivalent, so are the expressions.
     if S_Expr_Arg1 = S_Expr_Arg2 then
        return True;

     -- Otherwise, determine if the expressions are equal by determining
     -- if they have the same structure and contents.

     else
        declare
           Equal_Arg1     : S_Expr := S_Expr_Arg1;
           Equal_Arg2     : S_Expr := S_Expr_Arg2;
           Equal_Result   : Boolean;
           Stack1, Stack2 : S_Expr := Null_S_Expr;
        begin

           -- Loop until it is determined that the two expressions are
           -- not equal, or either of the stacks containing sub-expressions
           -- to be compared are empty.

           loop

          -- Break the expressions to be compared into sub-expressions
          -- by pushing the contents of the Rest field of each non-atomic
          -- expression onto separate stacks and setting each expression
          -- to the contents of its First field until either of the
          -- expressions remaining is atomic.

          while not Is_Atomic (Equal_Arg1) and then
            not Is_Atomic (Equal_Arg2) loop
             Push (Equal_Arg1.Rest, Stack1);
             Push (Equal_Arg2.Rest, Stack2);
             Equal_Arg1 := Equal_Arg1.First;
             Equal_Arg2 := Equal_Arg2.First;
          end loop;

          -- Compare the expressions resulting from the previous breakdown.
          -- If either expression is null, both must be.

          if Is_Null (Equal_Arg1) or else
             Is_Null (Equal_Arg2) then
             Equal_Result := Equal_Arg1 = Equal_Arg2;

          -- The categories (Atomic, Non_Atomic) of each
          -- of the expressions must match.

          elsif Equal_Arg1.Category /= Equal_Arg2.Category then
             Equal_Result := False;

          -- At this point, we know both expressions are non-null atomics.

          else

             -- The atomic expressions must both be of the same kind
             -- (Literal or Variable).

             if Equal_Arg1.Value.Kind /= Equal_Arg2.Value.Kind then
            Equal_Result := False;

             -- If both are literals, compare them as such.

             elsif Equal_Arg1.Value.Kind = Literal then
            Equal_Result := Is_Equal (Equal_Arg1.Value.Literal,
                          Equal_Arg2.Value.Literal);

             -- Otherwise, compare them as variables.

             else
            Equal_Result := Compare_Variables (Equal_Arg1, Equal_Arg2);
             end if;
          end if;

          exit when not Equal_Result or else
                Is_Null (Stack1) or else
                Is_Null (Stack2);

          -- We haven't exited the loop, so the expressions must be
          -- equivalent thus far and there must be sub-expressions
          -- remaining to be compared.  Get the next set of
          -- sub-expressions and continue the comparison.

          Pop (Stack1, Equal_Arg1);
          Pop (Stack2, Equal_Arg2);
           end loop;

           return Equal_Result;
        end;
     end if;
      end Is_Equal;

      -------------------------------------------------------------------------

      --    Function:     Is_Member
      --    Visibility:   Exported.
      --    Description:  Determines if the S_Expr_Arg is a top-level member
      --                  of the given Non_Atomic_Arg.
      --
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.

      function Is_Member (S_Expr_Arg, Non_Atomic_Arg : in S_Expr) return Boolean is
      begin

     -- Nothing is a member of Null_S_Expr.

     if Is_Null (Non_Atomic_Arg) then
        return False;

     -- Non_Atomic_Arg must be non-atomic.

     elsif Is_Atomic (Non_Atomic_Arg) then
        raise Atomic_Expression;

     -- Continue the search.

     else
        declare
           Member_Arg    : S_Expr := Non_Atomic_Arg;
           Member_Result : Boolean;
        begin

           -- Member_Arg is a pointer to the first component of the
           -- symbolic expression. Loop until we have found a component
           -- which matches S_Expr_Arg (in which case, Is_Member returns
           -- True) or until there are no components left with which to
           -- compare it (in which case, Is_Member returns false).
           loop
          Member_Result := Is_Equal (S_Expr_Arg, Member_Arg.First);
          Member_Arg := Member_Arg.Rest;

          exit when Member_Result or else Is_Null (Member_Arg);
           end loop;
           return Member_Result;
        end;
     end if;
      end Is_Member;

      -------------------------------------------------------------------------

      --    Procedure:    Free
      --    Visibility:   Exported.
      --    Description:  Frees the given symbolic expression.
      --
      --    Exceptions Raised:  None.

      procedure Free (S_Expr_Arg : in out S_Expr) is
     Stack, Temp : S_Expr := Null_S_Expr;
      begin
     -- Loop until the stack is empty.
     loop

        -- Only non-null symbolic expressions need to be freed.
        while not Is_Null (S_Expr_Arg) loop

           -- If the reference count of the symbolic expression is
           -- greater than one (there is more than one variable of type
           -- S_Expr which refers to this structure), we don't want to
           -- return its storage to the free lists.  Just decrement the
           -- reference counter.

           if S_Expr_Arg.Ref_Count > 1 then
          S_Expr_Arg.Ref_Count := S_Expr_Arg.Ref_Count - 1;
          S_Expr_Arg := Null_S_Expr;

           -- If the symbolic expression is non-atomic,
           -- process its first field, and set the expression to the
           -- contents of its rest field freeing the non-atomic node
           -- in the process.

           elsif Is_Non_Atomic (S_Expr_Arg) then
          -- Only non-null components have to freed.

          if not Is_Null (S_Expr_Arg.First) then

             -- If more than one variable still refers to the
             -- component being examined, decrement the ref count.

             if S_Expr_Arg.First.Ref_Count > 1 then
            S_Expr_Arg.First.Ref_Count :=
                S_Expr_Arg.First.Ref_Count - 1;

             -- If the component is atomic, add it to the
             -- atomic free list.

             elsif Is_Atomic (S_Expr_Arg.First) then
            S_Expr_Arg.First.Next_Free := Atomic_Free_List;
            Atomic_Free_List := S_Expr_Arg.First;

             -- Otherwise, push the non-atomic component
             -- onto the stack.

             else
            Push (S_Expr_Arg.First, Stack);
             end if;
          end if;

          -- Set a pointer to the first non-atomic node in the
          -- current expression. Make the remaining components
          -- (the contents of the Rest field) the new current
          -- expression. Push the non-atomic node onto the non-
          -- atomic free list by setting the First field of the
          -- non-atomic node to null, the Rest field to the head
          -- pointer of the non-atomic free list and the head pointer
          -- of the non-atomic free list to the new non-atomic node.

          Temp := S_Expr_Arg;
          S_Expr_Arg := S_Expr_Arg.Rest;
          Temp.First := Null_S_Expr;
          Temp.Rest := Non_Atomic_Free_List;
          Non_Atomic_Free_List := Temp;

           -- Otherwise, we have an atomic expression to be freed.

           else
          S_Expr_Arg.Next_Free := Atomic_Free_List;
          Atomic_Free_List := S_Expr_Arg;
          S_Expr_Arg := Null_S_Expr;
           end if;
        end loop;

        exit when Is_Null (Stack);

        -- If we haven't exited, there must be more non-atomic
        -- components to be freed.  Get a new current expression
        -- off the stack and free up the stack node which was
        -- holding it.

        S_Expr_Arg := Stack.First;
        Temp := Stack;
        Stack := Stack.Rest;
        Temp.First := Null_S_Expr;
        Temp.Rest := Non_Atomic_Free_List;
        Non_Atomic_Free_List := Temp;
     end loop;
      end Free;

      -------------------------------------------------------------------------

      --    Function:     Return_And_Free
      --    Visibility:   Exported.
      --    Description:  Provides a way for decrementing the ref-count of a
      --                  symbolic expression bound to a local variable being
      --                  returned from a function.
      --
      --    Exceptions Raised:  None.

      function Return_And_Free (S_Expr_Arg : in S_Expr) return S_Expr is
      begin
     if not Is_Null(S_Expr_Arg) and then
        S_Expr_Arg.Ref_Count > 0 then
        S_Expr_Arg.Ref_Count := S_Expr_Arg.Ref_Count - 1;
     end if;

     return S_Expr_Arg;
      end Return_And_Free;

      -------------------------------------------------------------------------

      --    Procedure:    Bind
      --    Visibility:   Exported.
      --    Description:  Sets the value of Current_Value to New_Value.
      --
      --    Exceptions Raised:  None.

      procedure Bind (Current_Value : in out S_Expr; New_Value : in S_Expr) is
     Temp_Value : S_Expr := Current_Value;
      begin

     -- Ignore cases of Bind (X, X).

     if Current_Value /= New_Value then
        Current_Value := New_Value;

        -- Increment the ref-count.

        if not Is_Null (Current_Value) then
           Current_Value.Ref_Count := Current_Value.Ref_Count + 1;
        end if;

        -- Free the original symbolic expression.

        if not Is_Null (Temp_Value) then
           Free (Temp_Value);
        end if;
     end if;
      end Bind;

      -------------------------------------------------------------------------

      --    Procedure:    Print_Non_Atomic_Fl
      --    Visibility:   Internal.
      --    Description:  Diagnostic function to print the current contents of
      --                  the non-atomic free list.
      --
      --    Exceptions Raised: None.

      procedure Print_Non_Atomic_Fl is
     Temp : S_Expr := Non_Atomic_Free_List;
      begin
     Put ("( ");

     -- Loop until all nodes have been examined.

     while not Is_Null (Temp) loop

        -- Make sure that only empty non-atomic nodes are on the
        -- non-atomic free list by printing "()" if the First field
        -- of the node is null, "X" if not.

        if Is_Null (Temp.First) then
           Put ("() ");
        else
           Put ("X ");
        end if;

        -- Set the current pointer to next node in the free list.

        Temp := Temp.Rest;
     end loop;

     Put (")");
      end Print_Non_Atomic_Fl;

      -------------------------------------------------------------------------

      --    Procedure:    Print_Atomic_Fl
      --    Visibility:   Internal.
      --    Description:  Diagnostic function to print the contents of the
      --                  atomic free list.
      --
      --    Exceptions Raised:  None.

      procedure Print_Atomic_Fl is
     Temp : S_Expr := Atomic_Free_List;
      begin
     Put ("( ");

     -- Loop until all nodes in the atomic free list have been examined.

     while not Is_Null (Temp) loop

        -- If the node on the free list is a variable, print the variable
        -- prefix and the variable name.

        if Is_Variable (Temp) then
           Put ("?");
           Put (Return_Variable_Name (Temp));
           Put (" ");

        -- If the node is an atomic literal, print it out.

        elsif not Is_Non_Atomic (Temp) then
           Put (Current_Output, Return_Atomic_Literal (Temp));
           Put (" ");

        -- Otherwise, indicate that something's wrong by printing an "X".

        else
           Put ("X ");
        end if;

        Temp := Temp.Next_Free;
     end loop;

     Put (")");
      end Print_Atomic_Fl;

      -------------------------------------------------------------------------

      --    Procedure:    Get
      --    Visibility:   Exported.
      --    Description:  Read a symbolic expression from the given file.
      --
      --    Exceptions Raised: Extra_Separator,, Missing_Separator
      --                       Impromper_Input, Invalid_Varable_Name.

      procedure Get (Input_File : in File_Type;
             S_Expr_Result : in out S_Expr) is
     Input_Char        : Character;
     Non_Atomic_Prefix : constant Character := '(';
     Non_Atomic_Suffix : constant Character := ')';
     Variable_Prefix   : constant Character := '?';
     Separator         : constant Character := ',';
     Literal_Value     : Atomic_Literal;

     ----------------------------------------------------------------------

     --    Procedure:    Get_Next_Char
     --    Visibility:   Internal.
     --    Description:  Return the next character to be processed.
     --
     --    Exceptions Raised: None.

     procedure Get_Next_Char is
     begin

        -- If we've looked at a character previously without
        -- processing it, make it the next character to be processed.

        if Lookahead /= ' ' then
           Input_Char := Lookahead;
           Lookahead := ' ';

        -- Otherwise, read the next non-blank character from the file.

        else
           loop
          Get (Input_File, Input_Char);
          exit when Input_Char /= ' ';
           end loop;
        end if;
     end Get_Next_Char;

     ----------------------------------------------------------------------

     --    Function:     Get_Variable_Rep
     --    Visibility:   Internal.
     --    Description:  Returns a string containing the character
     --                  representation of the next atomic expression
     --                  to be processed.
     --
     --    Exceptions Raised: None.

     function Get_Variable_Rep return String is
        Max_Buffer_Length : constant Natural := 255;
        Position          : Natural range 0 .. Max_Buffer_Length := 0;
        Atom_Buffer       : String (1 .. Max_Buffer_Length);
     begin

        -- Read characters from the file and put them in a
        -- buffer until finding a separator, blank, non-atomic suffix
        -- or the end of the line.

        while Input_Char /= Separator and then
          Input_Char /= ' ' and then
          Input_Char /= Non_Atomic_Suffix loop
           Position := Position + 1;
           Atom_Buffer (Position) := Input_Char;

           exit when End_Of_Line (Input_File);

           Get (Input_File, Input_Char);
        end loop;

        if Input_Char = Separator or else
           Input_Char = Non_Atomic_Suffix then
           Lookahead := Input_Char;
        end if;

        return Atom_Buffer (1 .. Position);
     end Get_Variable_Rep;

     ----------------------------------------------------------------------

     --    Procedure:    Check_For_Separator
     --    Visibility:   Internal.
     --    Description:  Determines if there are separator characters
     --                  where they're supposed to be.
     --
     --    Exceptions Raised: None.

         procedure Check_For_Separator is
        Original : Character := Input_Char;
     begin
        Get_Next_Char;

        -- Non_Atomic_Suffixes should not have Separators in front of them.

        if Input_Char = Non_Atomic_Suffix then
           Lookahead := Non_Atomic_Suffix;

        -- If we find a Separator ...
        elsif Input_Char = Separator then

           -- Get the next character.   If it's a Non_Atomic_Suffix
           -- or another Separator, there's an extra Separator character.
           -- Otherwise, just push back the character.

           Get_Next_Char;
           if Input_Char = Non_Atomic_Suffix or else
          Input_Char = Separator then
          raise Extra_Separator;
           else
          Lookahead := Input_Char;
           end if;

        -- If we find any other character, we're missing a separator.

        else
           raise Missing_Separator;
        end if;

        Input_Char := Original;
     end Check_For_Separator;

      begin
     -- Free any previous value.

     if not Is_Null (S_Expr_Result) then
        Free (S_Expr_Result);
     end if;

     Get_Next_Char;

     case Input_Char is

        -- Can't start off with a suffix or separator.

        when Non_Atomic_Suffix | Separator =>
           raise Improper_Input;

        -- If there's a non-atomic prefix, build a non-atomic expression.

        when Non_Atomic_Prefix =>
           Get_Next_Char;

           -- If we find a non-atomic suffix right after a non-atomic prefix
           -- return a null.  Otherwise, continue processing the expression.

           if Input_Char = Non_Atomic_Suffix then
          S_Expr_Result := Null_S_Expr;

           -- Can't have a separator character after a prefix.

           elsif Input_Char = Separator then
          raise Extra_Separator;
           else

          -- Create the first non-atomic node and set a pointer to it.

          S_Expr_Result := Create_Non_Atomic_Node;
          declare
             Current : S_Expr := S_Expr_Result;     -- Roving pointer.
             Temp_Current : S_Expr := Null_S_Expr;  -- Temp pointer.
             Dont_Move : Boolean := False;          -- Flag.
          begin
             loop
            case Input_Char is

               -- If we find a non-atomic suffix, check for a
               -- separator, then terminate the rest field with
               -- a null and follow the pointer in the rest field
               -- (which was placed there on the way down)
               -- up to the next higher level.

               when Non_Atomic_Suffix =>
                  Temp_Current := Current.Rest;
                  Current.Rest := Null_S_Expr;
                  Current := Temp_Current;

                  -- Make sure this isn't the last suffix
                  -- then check for a separator.
                  if not Is_Null (Current) then
                 Check_For_Separator;
                  end if;

               -- If we find a prefix, create a non-atomic component

               when Non_Atomic_Prefix =>

                  -- While we keep finding non-atomic prefixes,
                  -- check for separators (there shouldn't be any)
                  -- and non-atomic suffixes (for nulls).
                  -- If there are none, create another non-atomic
                  -- node, add it to the first field and set the
                  -- rest field to point to the node we've just
                  -- added it to.

                  loop
                 Get_Next_Char;

                 if Input_Char = Separator then
                    raise Extra_Separator;
                 elsif Input_Char = Non_Atomic_Suffix then
                    -- Look for separator.
                    Check_For_Separator;
                 else

                    -- NOTE: If we don't find a non-atomic
                    -- suffix or prefix, we have to add
                    -- something to the first field.  So,
                    -- make it the next character to be
                    -- processed and don't add a non-atomic
                    -- node to the rest field at the bottom of
                    -- the loop.

                    if Input_Char /= Non_Atomic_Prefix then
                       Lookahead := Input_Char;
                       Dont_Move := True;
                    end if;
                    Bind (Current.First, Create_Non_Atomic_Node);
                    Current.First.Rest := Current;
                    Current := Current.First;
                 end if;
                 exit when Input_Char /= Non_Atomic_Prefix;
                  end loop;

               -- If we find a variable prefix, check for a valid
               -- (non-null) variable name, create a variable
               -- and check for a separator.

               when Variable_Prefix =>
                  Get_Next_Char;
                  if Input_Char = Separator or else
                 Input_Char = Non_Atomic_Prefix or else
                 Input_Char = Non_Atomic_Suffix then
                 raise Invalid_Variable_Name;
                  end if;
                  Bind (Current.First,
                    Create_Atomic_Variable (Get_Variable_Rep));
                  Check_For_Separator;

               -- Otherwise, create a literal.

               when others =>
                  Lookahead := Input_Char;
                  Get (Input_File, Literal_Value);
                  Bind (Current.First,
                    Create_Atomic_Literal (Literal_Value));
                  Check_For_Separator;
            end case;

            exit when Is_Null (Current);

            Get_Next_Char;

            -- Determine if a non-atomic node has to be added to
            -- the rest field of the node currently being processed.

            -- If we still have to add something to the current node
            -- or we want to terminate the node, don't add anything.
            -- Otherwise, add a non-atomic node.

            if Dont_Move or else
               Input_Char = Non_Atomic_Suffix then
               Dont_Move := False;
            else
               Temp_Current := Create_Non_Atomic_Node;
               Temp_Current.Rest := Current.Rest;
               Current.Rest := Null_S_Expr;
               Bind (Current.Rest, Temp_Current);
               Current := Current.Rest;
            end if;
             end loop;
          end;
           end if;

        -- If there's a variable prefix, build a variable after
        -- checking for a valid name.

        when Variable_Prefix =>
           Get_Next_Char;
           if Input_Char = Separator or else
          Input_Char = Non_Atomic_Prefix or else
          Input_Char = Non_Atomic_Suffix then
          raise Invalid_Variable_Name;
           end if;
           S_Expr_Result := Create_Atomic_Variable (Get_Variable_Rep);

        -- Otherwise, build an atomic literal.

        when others =>
           Lookahead := Input_Char;
           Get (Input_File, Literal_Value);
           S_Expr_Result := Create_Atomic_Literal (Literal_Value);
     end case;

     -- Set the ref-count and return the pointer
     -- to the beginning of the structure created.

     if not Is_Null (S_Expr_Result) then
        S_Expr_Result.Ref_Count := 1;
     end if;

     exception
        when others =>
           Lookahead := ' ';
           raise;
      end Get;

      -------------------------------------------------------------------------

      --    Procedure:    Get
      --    Visibility:   Exported.
      --    Description:  Read a symbolic expression from
      --                  the current input file.
      --
      --    Exceptions Raised: None.

      procedure Get (S_Expr_Result : in out S_Expr) is
      begin
     Get (Current_Input, S_Expr_Result);
      end Get;

      -------------------------------------------------------------------------

      --    Procedure:    Put
      --    Visibility:   Exported.
      --    Description:  Print the structure of the input symbolic expression
      --                  to the specified output file.
      --
      --    Exceptions Raised: None.

      procedure Put (Output_File : in File_Type; S_Expr_Arg : in S_Expr) is
     Non_Atomic_Prefix : constant Character := '(';
     Non_Atomic_Suffix : constant Character := ')';
     Variable_Prefix   : constant Character := '?';
     Separator         : constant String := ", ";

     Separator_Needed  : Boolean := False;
     Stack             : S_Expr  := Null_S_Expr;
     S_Expr_Ref        : S_Expr  := S_Expr_Arg;
      begin

     -- If null, print representation of null: a non-atomic prefix followed
     -- by a non-atomic suffix.

     if Is_Null (S_Expr_Ref) then
        Put (Output_File, Non_Atomic_Prefix);
        Put (Output_File, Non_Atomic_Suffix);
     else

        -- Loop until the symbolic expression has been printed in its entirety.

        loop

           -- If the current expression is non-atomic ...
           if not Is_Atomic (S_Expr_Ref) then
          if Separator_Needed then
             Put (Output_File, Separator);
             Separator_Needed := False;
          end if;

          -- Do a depth-first traversal of the current symbolic expression.
          -- For each non-atomic node, print a non-atomic prefix,
          -- push the contents of the Rest field onto a stack and
          -- set the current symbolic expression to the contents of
          -- the First field. Continue until the current symbolic
          -- expression is atomic.

          loop
             Put (Output_File, Non_Atomic_Prefix);
             Push (S_Expr_Ref.Rest, Stack);
             S_Expr_Ref := S_Expr_Ref.First;
             exit when Is_Atomic (S_Expr_Ref);
          end loop;

          -- If the current symbolic expression is null, print a prefix.

          if Is_Null (S_Expr_Ref) then
             Put (Output_File, Non_Atomic_Prefix);
          end if;
           end if;

           -- If the current symbolic expression is null, print a suffix,
           -- pop the next expression to be printed (if there is one)
           -- off the stack and print any necessary separators.

           if Is_Null (S_Expr_Ref) then
          Put (Output_File, Non_Atomic_Suffix);

          if not Is_Null (Stack) then
             if not Is_Null (Stack.First) then
            Put (Output_File, Separator);
             end if;
          end if;

          Separator_Needed := False;

           -- If the current symbolic expression is a variable, print
           -- any necessary separators, the variable prefix and the
           -- name of the variable.

           elsif Is_Variable (S_Expr_Ref) then
          if Separator_Needed then
             Put (Output_File, Separator);
          else
             Separator_Needed := True;
          end if;

          Put (Output_File, Variable_Prefix);
          Put (Output_File, Return_Variable_Name (Atomic_Arg => S_Expr_Ref));

           -- If the current symbolic expression is atomic, print
           -- any necessary separators and the representation of the literal.

           elsif Is_Atomic (S_Expr_Ref) then
          if Separator_Needed then
             Put (Output_File, Separator);
          else
             Separator_Needed := True;
          end if;

          Put (Output_File, Return_Atomic_Literal (Atomic_Arg => S_Expr_Ref));
           end if;

           exit when Is_Null (Stack);

           -- We haven't exited, so there must be more sub-expressions
           -- to print.

           -- If the contents of the first expression on the stack is
           -- not null ...

           if not Is_Null (Stack.First) then

          -- If the contents of the first component of the first
          -- expression on the stack is null, print any necessary
          -- separators and a non-atomic prefix.

          if Is_Null (Stack.First.First) then
             if Separator_Needed then
            Put (Output_File, Separator);
            Separator_Needed := False;
             end if;
             Put (Output_File, Non_Atomic_Prefix);
          end if;
           end if;

           -- Get the next expression off the stack.

           Pop (Stack, S_Expr_Ref);
        end loop;
     end if;
      end Put;

      -------------------------------------------------------------------------

      --    Procedure:    Put
      --    Visibility:   Exported.
      --    Description:  Print the structure of the input symbolic expression
      --                  to the current default output file.
      --
      --    Exceptions Raised: None.

      procedure Put (S_Expr_Arg : in S_Expr) is
      begin
     Put (Current_Output, S_Expr_Arg);
      end Put;

      -------------------------------------------------------------------------

      --    Function:     Prefix
      --    Visibility:   Exported.
      --    Description:  If the second argument is atomic, Prefix returns
      --                  an expression, X, such that First(X)=First_Value
      --                  and First (Rest (X)) = Rest_Value.  Otherwise, it returns
      --                  an expression, Y, such that First(Y) = First_Value and
      --                  Rest(Y) = Rest_Value.
      --
      --    Exceptions Raised: None.

      function Prefix (First_Value : in S_Expr;
               Rest_Value  : in S_Expr := Null_S_Expr) return S_Expr is
      begin

     -- If the second argument is null, create an expression of one component.

     if Is_Null(Rest_Value) then
        return Create_Non_Atomic_Node (Value_Of_First => First_Value);

     -- If the second argument is atomic, create an additional non-atomic
     -- node, set its First field to the second argument and create an
     -- expression from the first argument and newly created non-atomic node.

     elsif Is_Atomic(Rest_Value) then
        return Create_Non_Atomic_Node (
              Value_Of_First => First_Value,
              Value_Of_Rest => Create_Non_Atomic_Node (
                      Value_Of_First => Rest_Value));

     -- Otherwise, return a non-atomic node with its First and Rest fields
     -- set to the Value_Of_First and Value_of_Rest, respectively.

     else
        return Create_Non_Atomic_Node (
              Value_Of_First => First_Value,
              Value_Of_Rest => Rest_Value);
     end if;
      end Prefix;

      -------------------------------------------------------------------------

      --    Function:     Length
      --    Visibility:   Exported.
      --    Description:  Returns 0 for atomic expressions or the number of
      --                  top level components for non-atomic expressions.
      --
      --    Exceptions Raised:  None.

      function Length (S_Expr_Arg : in S_Expr) return Natural is
    Length_Value : Natural := 0;
    Length_Arg   : S_Expr  := S_Expr_Arg;
      begin
     if not Is_Atomic (Length_Arg) then
        loop
           Length_Value := Length_Value + 1;
           Length_Arg := Length_Arg.Rest;
           exit when Is_Null (Length_Arg);
        end loop;
     end if;

     return Length_Value;
      end Length;

      -------------------------------------------------------------------------

      --    Function:     "&"
      --    Visibility:   Exported.
      --    Description:  Returns a symbolic expression composed of the elements
      --                  of each of the input arguments.
      --
      --    Exceptions Raised:  None.

      function "&" (S_Expr_Arg1, S_Expr_Arg2 : in S_Expr) return S_Expr is
      begin

     -- If both arguments are null, they have no elements, return null.

     if Is_Null (S_Expr_Arg1) and Is_Null (S_Expr_Arg2) then
        return Null_S_Expr;
     else
        declare
           Front_Arg, Back_Arg : S_Expr := Null_S_Expr;
        begin

           -- Create the second part of the result.
           -- If the second input argument is a non-null atomic expression,
           -- create a non-atomic node containing the second input argument as
           -- the value of its first field.  Otherwise, the second part of the
           -- result is the second input argument itself.

           if not Is_Non_Atomic (S_Expr_Arg2) then
          Back_Arg := Create_Non_Atomic_Node(Value_Of_First=> S_Expr_Arg2);
           else
          Back_Arg := S_Expr_Arg2;
           end if;

           -- Create the result by appending the second part of the result
           -- (created above) to a copy of the first input argument.

           -- If the first input argument is a non-null atomic argument,
           -- create a non-atomic containing a copy of the first input argument
           -- in its first field and the second part of the result in its
           -- rest field.

           if not Is_Non_Atomic (S_Expr_Arg1) then
          Front_Arg := Create_Non_Atomic_Node(Value_Of_First=>S_Expr_Arg1);
          Bind (Front_Arg.Rest, Back_Arg);

           -- If the first input argument is a non-null non-atomic argument,
           -- create a copy of the first input argument, find the last
           -- non-atomic node in the copy and set the rest field of the last
           -- node to the second part of the result.

           elsif not Is_Atomic (S_Expr_Arg1) then
          declare
             Nth_Arg, Current : S_Expr;
          begin
             for Position in reverse 1 .. Length (S_Expr_Arg1) loop
            Nth_Arg := S_Expr_Arg1;
            for Node_Number in 1 .. Position-1 loop
               Nth_Arg := Nth_Arg.Rest;
            end loop;
            Front_Arg := Prefix (Nth_Arg.First, Front_Arg);
             end loop;

             Current := Front_Arg;

             while not Is_Null (Current.Rest) loop
            Current := Current.Rest;
             end loop;

             Bind (Current.Rest, Back_Arg);
          end;
           end if;

           -- If the first argument turned out to be null, return a pointer
           -- to the second part of the result.  Otherwise, return the pointer
           -- to the front of the result.

           if Is_Null (Front_Arg) then
          return Back_Arg;
           else
          return Front_Arg;
           end if;
        end;
     end if;
      end "&";

      -------------------------------------------------------------------------

      --    Function:     First
      --    Visibility:   Exported.
      --    Description:  Returns the first component of the non-null,
      --                  non-atomic input argument.
      --
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.

      function First (Non_Atomic_Arg : in S_Expr) return S_Expr is
      begin
     if Is_Atomic (Non_Atomic_Arg) then
        raise Atomic_Expression;
     end if;
     return Non_Atomic_Arg.First;
      end First;

      -------------------------------------------------------------------------

      --    Function:     Rest
      --    Visibility:   Exported.
      --    Description:  Returns all components of the non-null, non-atomic
      --                  input argument except the first.
      --
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.

      function Rest (Non_Atomic_Arg : in S_Expr) return S_Expr is
      begin
     if Is_Atomic (Non_Atomic_Arg) then
        raise Atomic_Expression;
     end if;
     return Non_Atomic_Arg.Rest;
      end Rest;

      -------------------------------------------------------------------------

      --    Function:     Last
      --    Visibility:   Exported.
      --    Description:  Returns the last component of the non-null,
      --                  non-atomic input argument.
      --
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.

      function Last (Non_Atomic_Arg : in S_Expr) return S_Expr is
      begin
     if Is_Atomic (Non_Atomic_Arg) then
        raise Atomic_Expression;
     end if;

     declare
        Last_Arg : S_Expr := Non_Atomic_Arg;
     begin
        while not Is_Null (Last_Arg.Rest) loop
           Last_Arg := Last_Arg.Rest;
        end loop;

        return Last_Arg.First;
     end;
      end Last;

      -------------------------------------------------------------------------

      --    Function:     Nth
      --    Visibility:   Exported.
      --    Description:  Returns the position-th component of the non-null,
      --                  non-atomic input argument.
      --
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.
      --                        Invalid_Position - if Position > # of components.

      function Nth (Non_Atomic_Arg : in S_Expr;
            Position : in Positive) return S_Expr is
      begin
     if Is_Atomic (Non_Atomic_Arg) then
        raise Atomic_Expression;
     end if;

     if Position > Length (Non_Atomic_Arg) then
        raise Invalid_Position;
     end if;

     declare
        Nth_Arg : S_Expr := Non_Atomic_Arg;
     begin
        for Node_Number in 1 .. Position-1 loop
           Nth_Arg := Nth_Arg.Rest;
        end loop;

        return Nth_Arg.First;
     end;
      end Nth;

      -------------------------------------------------------------------------

      --    Function:     Nth_First
      --    Visibility:   Exported.
      --    Description:  Returns the result of calling the function First n times,
      --                  each time using the result of the previous call as the
      --                  argument for the new iteration.
      --
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.
      --                        Invalid_Repetitions - if Repetitions > maximum
      --                                              depth of the expression.

      function Nth_First (Non_Atomic_Arg : in S_Expr;
              Repetitions : in Positive) return S_Expr is
     Nth_First_Arg : S_Expr := Non_Atomic_Arg;
      begin
     if Is_Atomic (Non_Atomic_Arg) then
        raise Atomic_Expression;
     end if;

     for Iteration in 1 .. Repetitions loop
        Nth_First_Arg := Nth_First_Arg.First;
        if Is_Atomic(Nth_First_Arg) and then Iteration < Repetitions then
           raise Invalid_Repetitions;
        end if;
     end loop;

     return Nth_First_Arg;
      end Nth_First;

      -------------------------------------------------------------------------

      --    Function:     Nth_Rest
      --    Visibility:   Exported.
      --    Description:  Returns the result of calling the function Rest n times,
      --                  each time using the result of the previous call as the
      --                  argument for the new iteration.
      --
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.
      --                        Invalid_Repetitions - if Repetitions > maximum
      --                                              length of the expression.

      function Nth_Rest (Non_Atomic_Arg : in S_Expr;
             Repetitions : in Positive) return S_Expr is
     Nth_Rest_Arg : S_Expr := Non_Atomic_Arg;
      begin
     for Iteration in 1 .. Repetitions loop
        Nth_Rest_Arg := Nth_Rest_Arg.Rest;
        if Is_Atomic(Nth_Rest_Arg) and then Iteration < Repetitions then
           raise Invalid_Repetitions;
        end if;
     end loop;

     return Nth_Rest_Arg;
      end Nth_Rest;

      -------------------------------------------------------------------------

      --    Function:     Reverse_S_Expr
      --    Visibility:   Exported.
      --    Description:  Returns a non-atomic symbolic expression with the
      --                  components of the given argument in reverse order.
      --
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.

      function Reverse_S_Expr (Non_Atomic_Arg : in S_Expr) return S_Expr is
      begin
     if Is_Atomic (Non_Atomic_Arg) then
        raise Atomic_Expression;
     end if;

     declare
        Reverse_Arg    : S_Expr := Non_Atomic_Arg;
        Reverse_Result : S_Expr := Null_S_Expr;
     begin

        -- Create the new symbolic expression by traversing the argument
        -- forward while building the result backwards.

        loop
           Reverse_Result := Prefix (First_Value => Reverse_Arg.First,
                     Rest_Value  => Reverse_Result);
           Reverse_Arg := Reverse_Arg.Rest;
           exit when Is_Null (Reverse_Arg);
        end loop;

        return Reverse_Result;
     end;
      end Reverse_S_Expr;

      -------------------------------------------------------------------------

      --    Function:     Delete
      --    Visibility:   Exported.
      --    Description:  Deletes all top level occurences of the first argument
      --                  from the second.
      --
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.

      function Delete (S_Expr_Arg, Non_Atomic_Arg : in S_Expr) return S_Expr is
      begin
     if Is_Atomic (Non_Atomic_Arg) then
        raise Atomic_Expression;
     end if;

     -- If it's not there, we can't delete it.

     if not Is_Member (S_Expr_Arg, Non_Atomic_Arg) then
        return Non_Atomic_Arg;
     else
        declare
           Delete_Arg    : S_Expr := Non_Atomic_Arg;
           Delete_Result : S_Expr := Null_S_Expr;
        begin

           -- Loop until the argument is exhausted or until the first component
           -- which does not match the argument to be delete is found.

           loop
          if not Is_Equal (Delete_Arg.First, S_Expr_Arg) then
             Delete_Result := Prefix (First_Value => Delete_Arg.First);
          end if;

          Delete_Arg := Delete_Arg.Rest;

          exit when Is_Null (Delete_Arg) or else
                not Is_Null (Delete_Result);
           end loop;

           -- If there are more components to be examined in the argument,
           -- set a pointer to the current contents of the result.

           if not Is_Null (Delete_Arg) then
          declare
             End_Of_Result : S_Expr := Delete_Result;
          begin

             -- Loop through the remainder of the argument, building
             -- a new expression with those components which do not
             -- match the expression being deleted.

             loop
            if not Is_Equal (Delete_Arg.First, S_Expr_Arg) then
               Bind (End_Of_Result.Rest,
                  Prefix (First_Value => Delete_Arg.First));
               End_Of_Result := End_Of_Result.Rest;
            end if;

            Delete_Arg := Delete_Arg.Rest;

            exit when Is_Null (Delete_Arg);
             end loop;
          end;
           end if;

           return Delete_Result;
        end;
     end if;
      end Delete;

      -------------------------------------------------------------------------

      --    Function:     Replace
      --    Visibility:   Exported.
      --    Description:  Replaces all top level occurences of the first argument
      --                  in the third with the second.
      --
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.

      function Replace (S_Expr_Arg1, S_Expr_Arg2, Non_Atomic_Arg : in S_Expr)
     return S_Expr is
      begin
     if Is_Atomic (Non_Atomic_Arg) then
        raise Atomic_Expression;
     end if;

     -- If the expression to be replaced and its replacement are equivalent
     -- or if the expression to be replaced is not a component of the
     -- of the expression being operated upon, the resulting expression
     -- will be exactly equivalent to the original.

     if Is_Equal (S_Expr_Arg1, S_Expr_Arg2) or else
        not Is_Member (S_Expr_Arg1, Non_Atomic_Arg) then
        return Non_Atomic_Arg;
     else
        declare
           Replace_Arg    : S_Expr := Non_Atomic_Arg;
           Replace_Result : S_Expr := Null_S_Expr;
        begin

           -- If the first component of the original expression is equal
           -- to the expression to be replaced, the first component of the
           -- result will be the replacement expression.  Otherwise, the
           -- first component of the original and result will be the same.

           if Is_Equal (Replace_Arg.First, S_Expr_Arg1) then
          Replace_Result := Prefix (First_Value => S_Expr_Arg2);
           else
          Replace_Result := Prefix (First_Value => Replace_Arg.First);
           end if;

           Replace_Arg := Replace_Arg.Rest;


           -- If there are more components to be examined in the original
           -- argument, set a pointer to the current contents of the result.

           if not Is_Null (Replace_Arg) then
          declare
             End_Of_Result : S_Expr := Replace_Result;
          begin

             -- Loop through the remainder of the original expression.
             -- If the component being examined matches the expression to
             -- be replaced, add the replacement expression to the result.
             -- Otherwise, add the component being examined to the result.

             loop
            if Is_Equal (Replace_Arg.First, S_Expr_Arg1) then
               Bind (End_Of_Result.Rest,
                 Prefix (First_Value => S_Expr_Arg2));
            else
               Bind (End_Of_Result.Rest,
                 Prefix (First_Value => Replace_Arg.First));
            end if;

            End_Of_Result := End_Of_Result.Rest;
            Replace_Arg := Replace_Arg.Rest;

            exit when Is_Null (Replace_Arg);
             end loop;
          end;
           end if;

           return Replace_Result;
        end;
     end if;
      end Replace;

      -------------------------------------------------------------------------

      --    Function:     Flatten
      --    Visibility:   Exported.
      --    Description:  Returns a non-atomic expression which has as components
      --                  all atomic components and all atomic components of all
      --                  the non-atomic expressions within the given argument.
      --
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg is atomic.

      function Flatten (Non_Atomic_Arg : in S_Expr) return S_Expr is
      begin
     if Is_Atomic (Non_Atomic_Arg) then
        raise Atomic_Expression;
     end if;

     declare
        Flatten_Arg : S_Expr := Non_Atomic_Arg;
        Stack, Flatten_Result : S_Expr := Null_S_Expr;
     begin

        -- Loop until finding the first value of the result or
        -- the argument is exhausted.

        loop
           -- Do a depth-first traversal of the argument, pushing the
           -- second thru nth components of the argument onto a stack
           -- and making the first component of the argument the new argument.
           -- Stop when an atomic expression is found.

           while not Is_Atomic (Flatten_Arg) loop
          Push (Flatten_Arg.Rest, Stack);
          Flatten_Arg := Flatten_Arg.First;
           end loop;

           -- If the expression is non-null, add it to the result.

           if not Is_Null (Flatten_Arg) then
          Flatten_Result := Prefix (First_Value => Flatten_Arg);
          Flatten_Arg := Null_S_Expr;
           end if;

           exit when (not Is_Null (Flatten_Result)) or else Is_Null (Stack);

           -- Get the next set of components from the stack.

           Pop (Stack, Flatten_Arg);
        end loop;

        -- If there's more to flatten, continue.

        if not Is_Null (Stack) then
           declare
          End_Of_Result : S_Expr := Flatten_Result;
           begin
          -- Loop until there are no more component sequences on
          -- the stack.

          Pop (Stack, Flatten_Arg);

          loop

             -- If the current argument is non-null and non-atomic,
             -- push all but the first component on the stack and
             -- make the first component the current argument.

             while not Is_Atomic (Flatten_Arg) loop
            Push (Flatten_Arg.Rest, Stack);
            Flatten_Arg := Flatten_Arg.First;
             end loop;

             -- If the atomic expression found is non-null,
             -- add it to the result.

             if not Is_Null (Flatten_Arg) then
            Bind (End_Of_Result.Rest,
                  Prefix (First_Value => Flatten_Arg));
            End_Of_Result := End_Of_Result.Rest;
             end if;

             exit when Is_Null (Stack);

             -- Get the next set of components off the stack.

             Pop (Stack, Flatten_Arg);
          end loop;
           end;
        end if;

        return Flatten_Result;
     end;
      end Flatten;

      -------------------------------------------------------------------------

      --    Function:     "And"
      --    Visibility:   Exported.
      --    Description:  Returns a non-atomic expression which contains as
      --                  components all components which are both in the first
      --                  argument AND in the second argument with no duplicates.
      --
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg1 or
      --                                            Non_Atomic_Arg2 is
      --                                            non-null atomic.

      function "And" (Non_Atomic_Arg1, Non_Atomic_Arg2 : in S_Expr)
     return S_Expr is
      begin
     if not Is_Non_Atomic (Non_Atomic_Arg1) or else
        not Is_Non_Atomic (Non_Atomic_Arg2) then
        raise Atomic_Expression;
     end if;

     declare
        And_Arg1   : S_Expr := Non_Atomic_Arg1;
        And_Arg2   : S_Expr := Non_Atomic_Arg2;
        And_Result : S_Expr := Null_S_Expr;
     begin

        -- Loop through the first argument.

        while not Is_Null (And_Arg1) loop

           -- If the current component of the first argument has not
           -- been previously added to the result and the current
           -- component is also a member of the second argument, add
           -- it to the result.

           if not Is_Member (And_Arg1.First, And_Result) and then
          Is_Member (And_Arg1.First, And_Arg2) then

          And_Result := Prefix (And_Arg1.First, And_Result);
           end if;

           And_Arg1 := And_Arg1.Rest;
        end loop;

        return And_Result;
     end;
      end "And";

      -------------------------------------------------------------------------

      --    Function:     "Or"
      --    Visibility:   Exported.
      --    Description:  Returns a non-atomic expression which contains as
      --                  components all components which are either in the first
      --                  argument OR in the second argument with no duplicates.
      --
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg1 or
      --                                            Non_Atomic_Arg2 is
      --                                            non-null atomic.

      function "Or" (Non_Atomic_Arg1, Non_Atomic_Arg2 : in S_Expr) return S_Expr is
      begin
     if not Is_Non_Atomic (Non_Atomic_Arg1) or else
        not Is_Non_Atomic (Non_Atomic_Arg2) then
        raise Atomic_Expression;
     end if;

     declare
          Or_Arg1   : S_Expr := Non_Atomic_Arg1;
          Or_Arg2   : S_Expr := Non_Atomic_Arg2;
          Or_Result : S_Expr := Null_S_Expr;
     begin

        -- Loop through the second argument, adding all of
        -- its components (without duplication) to the result.

        while not Is_Null (Or_Arg2) loop
           if not Is_Member (Or_Arg2.First, Or_Result) then
          Or_Result := Prefix (Or_Arg2.First, Or_Result);
           end if;

           Or_Arg2 := Or_Arg2.Rest;
        end loop;

        -- Loop through the first argument.

        while not Is_Null (Or_Arg1) loop

           -- If the current component of the first argument has not
           -- been previously added to the result, add it.

           if not Is_Member (Or_Arg1.First, Or_Result) then
          Or_Result := Prefix (Or_Arg1.First, Or_Result);
           end if;

           Or_Arg1 := Or_Arg1.Rest;
        end loop;

        return Or_Result;
     end;
      end "Or";

      -------------------------------------------------------------------------

      --    Function:     "-"
      --    Visibility:   Exported.
      --    Description:  Returns a non-atomic expression which contains as
      --                  components all those components of the first argument
      --                  which are not contained within the second with no
      --                  duplicates.
      --
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg1 or
      --                                            Non_Atomic_Arg2 is
      --                                            non-null atomic.

      function "-" (Non_Atomic_Arg1, Non_Atomic_Arg2 : in S_Expr) return S_Expr is
      begin
     if not Is_Non_Atomic (Non_Atomic_Arg1) or else
        not Is_Non_Atomic (Non_Atomic_Arg2) then
        raise Atomic_Expression;
     end if;

     declare
        Diff_Arg1   : S_Expr := Non_Atomic_Arg1;
        Diff_Arg2   : S_Expr := Non_Atomic_Arg2;
        Diff_Result : S_Expr := Null_S_Expr;
     begin

        -- Loop through the first argument.

        while not Is_Null (Diff_Arg1) loop

           -- If the current component of the first argument is not
           -- a member of the result or the second argument, add it
           -- to the result.

           if not Is_Member (Diff_Arg1.First, Diff_Result) and then
          not Is_Member (Diff_Arg1.First, Diff_Arg2) then
          Diff_Result := Prefix (Diff_Arg1.First, Diff_Result);
           end if;

           Diff_Arg1 := Diff_Arg1.Rest;
        end loop;

        return Diff_Result;
     end;
      end "-";

      -------------------------------------------------------------------------

      --    Function:     "Xor"
      --    Visibility:   Exported.
      --    Description:  Returns a non-atomic expression which contains as
      --                  components all those components of the first argument
      --                  which are not components of the second and all those
      --                  components of the second argument which are not
      --                  components of the first with no duplicates.
      --
      --    Exceptions Raised:  Atomic_Expression - if Non_Atomic_Arg1 or
      --                                            Non_Atomic_Arg2 is
      --                                            non-null atomic.

      function "Xor" (Non_Atomic_Arg1, Non_Atomic_Arg2 : in S_Expr)
     return S_Expr is
     Or_Arg1, Or_Arg2 : S_Expr;
     Xor_Result : S_Expr;
      begin
     if not Is_Non_Atomic (Non_Atomic_Arg1) or else
        not Is_Non_Atomic (Non_Atomic_Arg2) then
        raise Atomic_Expression;
     end if;

     Or_Arg1 := Non_Atomic_Arg1 - Non_Atomic_Arg2;
     Or_Arg2 := Non_Atomic_Arg2 - Non_Atomic_Arg1;

     if Is_Null (Or_Arg1) then
        return Or_Arg2;
     elsif Is_Null (Or_Arg2) then
        return Or_Arg1;
     else
        Xor_Result := Or_Arg1 OR Or_Arg2;
        Free (Or_Arg1);
        Free (Or_Arg2);
        return Xor_Result;
     end if;

      end "Xor";

      -------------------------------------------------------------------------

      --    Function:     Associate
      --    Visibility:   Exported.
      --    Description:  Returns the first component of A_Table whose
      --                  Search_Position-th component is equivalent to the Key.
      --
      --    Exceptions Raised:  Atomic_Expression - if A_Table is atomic.

      function Associate (Key, A_Table : in S_Expr;
              Search_Position : Positive := 1) return S_Expr is
      begin
     if Is_Atomic (A_Table) then
        raise Atomic_Expression;
     end if;

     declare
        A_Table_Arg : S_Expr := A_Table;
        Component   : S_Expr := Null_S_Expr;
     begin

        -- Loop until the A_Table is exhausted or a component
        -- satisfying the necessary criteria is found.

        loop

           -- Examine the component only if it has a number of
           -- components greater or equal to Search_Position.

           if Length (A_Table_Arg.First) >= Search_Position then
          Component := A_Table_Arg.First;

          -- Loop to the correct position within the component.

          for Component_Number in 1 .. Search_Position-1 loop
             Component := Component.Rest;
          end loop;

          -- Examine the component at the current position.

          if Is_Equal (Component.First, Key) then
             return A_Table_Arg.First;
          end if;
           end if;

           -- We haven't found a match, get the next entry of the A_Table.

           A_Table_Arg := A_Table_Arg.Rest;

           exit when Is_Null (A_Table_Arg);
        end loop;

        return Null_S_Expr;
     end;
      end Associate;

      -------------------------------------------------------------------------

      --    Function:     Associate_All
      --    Visibility:   Exported.
      --    Description:  Returns a non-atomic expression containing ALL the
      --                  components of A_Table whose Search_Position-th
      --                  component is equivalent to the Key.
      --
      --    Exceptions Raised:  Atomic_Expression - if A_Table is atomic.

      function Associate_All (Key, A_Table : in S_Expr;
                  Search_Position : Positive := 1) return S_Expr is

      begin
     if Is_Atomic (A_Table) then
        raise Atomic_Expression;
     end if;

     declare
        A_Table_Arg       : S_Expr := A_Table;
        Component,
        Associate_Result  : S_Expr := Null_S_Expr;
     begin

        -- Loop until finding the first component which satisifies
        -- the necessary criteria or until the A_Table is exhausted.

        loop

           -- Examine the component only if it has a number of
           -- components greater or equal to Search_Position.

           if Length (A_Table_Arg.First) >= Search_Position then
          Component := A_Table_Arg.First;

          -- Loop to the correct position within the component.

          for Component_Number in 1 .. Search_Position-1 loop
             Component := Component.Rest;
          end loop;

          -- If the component at the current position matches the
          -- Key, add it to the result.

          if Is_Equal (Component.First, Key) then
             Associate_Result := Prefix (First_Value => A_Table_Arg.First);
          end if;
           end if;

           A_Table_Arg := A_Table_Arg.Rest;

           exit when not Is_Null (Associate_Result) or else
             Is_Null (A_Table_Arg);
        end loop;

        -- If there are further components to search in the A_Table, continue.

        if not Is_Null (A_Table_Arg) then
           declare
          End_Of_Result : S_Expr := Associate_Result;
           begin

          -- Loop through the remainder of the A_Table.

          loop

             -- Examine the component only if it has a number of
             -- components greater or equal to Search_Position.

             if Length (A_Table_Arg.First) >= Search_Position then
            Component := A_Table_Arg.First;

            -- Loop to the correct position within the component.

            for Component_Number in 1 .. Search_Position-1 loop
               Component := Component.Rest;
            end loop;

            -- If the component at the current position matches the
            -- Key, add it to the result.

            if Is_Equal (Component.First, Key) then
               Bind (End_Of_Result.Rest,
                  Prefix (First_Value => A_Table_Arg.First));

               End_Of_Result := End_Of_Result.Rest;
            end if;
             end if;

             A_Table_Arg := A_Table_Arg.Rest;

             exit when Is_Null (A_Table_Arg);
          end loop;
           end;
        end if;

        return Associate_Result;
     end;
      end Associate_All;

   end Symbolic_Expressions;


   package body Patterns is

      -- A Pattern is a S_Expr whose first component is the pattern template
      -- and whose second component is the variable binding context.

      -------------------------------------------------------------------------

      --    Function:     Is_Null
      --    Visibility:   Exported.
      --    Description:  Determines if Pattern_Arg = Null_Pattern.
      --
      --    Exceptions Raised:  None.

      function Is_Null (Pattern_Arg : in Pattern) return Boolean is
      begin
     return SE."=" (SE.S_Expr (Pattern_Arg), SE.S_Expr (Null_Pattern));
      end Is_Null;

      -------------------------------------------------------------------------

      --    Function:     Create_Pattern
      --    Visibility:   Exported.
      --    Description:  Creates a pattern. The symbolic expression forms the
      --                  pattern's template and the pattern's variable binding
      --                  context is set to null.
      --
      --    Exceptions Raised:  None.

      function Create_Pattern (Template : in SE.S_Expr;
                   Bindings : in SE.S_Expr := SE.Null_S_Expr)
         return Pattern is
      begin
     if SE.Is_Null (Template) and then
        SE.Is_Null (Bindings) then
        return Null_Pattern;
     else
        return Pattern (SE.Prefix (Template, Bindings));
     end if;
      end Create_Pattern;

      -------------------------------------------------------------------------

      --    Function:     Get_Template
      --    Visibility:   Exported
      --    Description:  Returns the template portion of the given pattern.
      --
      --    Exceptions Raised:  None.

      function Get_Template (Pattern_Arg : in Pattern) return SE.S_Expr is
      begin
     if Is_Null (Pattern_Arg) then
        return SE.Null_S_Expr;
     else
        return SE.First (SE.S_Expr (Pattern_Arg));
     end if;
      end Get_Template;

      -------------------------------------------------------------------------

      --    Function:     Get_Bindings
      --    Visibility:   Exported.
      --    Description:  Returns a symbolic expression representing the current
      --                  bindings of the variables found in the pattern
      --                  argument's template.
      --
      --    Exceptions Raised:  None.

      function Get_Bindings (Pattern_Arg : in Pattern) return SE.S_Expr is
      begin
     if Is_Null (Pattern_Arg) then
        return SE.Null_S_Expr;
     else
        return SE.Rest (SE.S_Expr(Pattern_Arg));
     end if;
      end Get_Bindings;

      -------------------------------------------------------------------------

      --    Function:     Set_Bindings
      --    Visibility:   Exported.
      --    Description:  Sets the variable binding context for the pattern
      --                  to the specified context.  NOTE: This function can
      --                  also be used to erase the current context by setting
      --                  the bindings to null.
      --
      --    Exceptions Raised:  None.

      function Set_Bindings (Pattern_Arg : in Pattern;
                 Bindings : in SE.S_Expr) return Pattern is
      begin
     return Create_Pattern (Get_Template (Pattern_Arg), Bindings);
      end Set_Bindings;

      -------------------------------------------------------------------------

      --    Function:     First
      --    Visibility:   Exported.
      --    Description:  Returns a pattern whose template consists of the
      --                  first component of the argument.  The variable binding
      --                  context of the new pattern is the same as that of the
      --                  argument.
      --
      --    Exceptions Raised:  Atomic_Template -- if the pattern template
      --                                           is an atomic expression.

      function First (Pattern_Arg : in Pattern) return Pattern is
      begin
     return Create_Pattern (SE.First (Get_Template (Pattern_Arg)),
                Get_Bindings (Pattern_Arg));
     exception
        when SE.Atomic_Expression => raise Atomic_Template;
      end First;

      -------------------------------------------------------------------------

      --    Function:     Rest
      --    Visibility:   Exported.
      --    Description:  Returns a pattern whose template consists of the all
      --                  but the first component of the argument.  The variable
      --                  binding context of the new pattern is the same as that
      --                  of the argument.
      --
      --    Exceptions Raised:  Atomic_Template -- if the pattern template
      --                                           is an atomic expression.

      function Rest (Pattern_Arg : in Pattern) return Pattern is
      begin
     return Create_Pattern (SE.Rest (Get_Template (Pattern_Arg)),
                Get_Bindings (Pattern_Arg));
     exception
        when SE.Atomic_Expression => raise Atomic_Template;
      end Rest;

      -------------------------------------------------------------------------

      --    Function:     Instantiate
      --    Visibility:   Exported.
      --    Description:  Returns a symbolic expression created by replacing
      --                  all variables in the pattern argument's template with
      --                  their current bindings (found in the variable binding
      --                  context).
      --
      --    Exceptions Raised:  None.

      function Instantiate (Pattern_Arg : in Pattern) return SE.S_Expr is

     Bindings, Result : SE.S_Expr;

     ----------------------------------------------------------------------

     --    Function:     Create_Inst
     --    Visibility:   Internal.
     --    Description:  Returns a symbolic expression created by replacing
     --                  all variables in the pattern argument's template
     --                  with their current bindings (found in the variable
     --                  binding context).
     --
     --    Exceptions Raised:  None.

     function Create_Inst (Template, Binding_List : in SE.S_Expr)
        return SE.S_Expr is
        Var_Value_Pair, Value, Result : SE.S_Expr;
     begin

        -- If the template is a variable, check to see if it has a binding.

        if SE.Is_Variable (Template) then
           SE.Bind (Var_Value_Pair, SE.Associate (Template, Binding_List));

           -- If the variable has no binding, return the variable itself.
           -- Otherwise, examine the expression to which it's bound.

           if SE.Is_Null (Var_Value_Pair) then
          SE.Bind (Result, Template);
           else
          SE.Bind (Value, SE.First (SE.Rest (Var_Value_Pair)));
          SE.Bind (Result,
               Create_Inst (SE.First (SE.Rest (Var_Value_Pair)),
                    Binding_List));
           end if;

        -- If the template is atomic, just return it.

        elsif SE.Is_Atomic (Template) then
           SE.Bind (Result, Template);

        -- Otherwise, build up an expression with the result of examining
        -- the first and rest sections of the given template.

        elsif not SE.Is_Atomic (Template) then
           SE.Bind (Result,
            SE.Prefix (Create_Inst (SE.First (Template),
                        Binding_List),
                   Create_Inst (SE.Rest (Template),
                        Binding_List)));
        end if;

        SE.Free (Var_Value_Pair);
        return SE.Return_And_Free (Result);
     end Create_Inst;

      begin
     SE.Bind (Bindings, Get_Bindings (Pattern_Arg));
     if SE.Is_Null (Bindings) then
        SE.Bind (Result, Get_Template (Pattern_Arg));
     else
        SE.Bind (Result,
             Create_Inst (Get_Template (Pattern_Arg), Bindings));
     end if;

     SE.Free (Bindings);
     return SE.Return_And_Free (Result);
      end Instantiate;

      -------------------------------------------------------------------------

      --    Function:     Is_Equal
      --    Visibility:   Exported.
      --    Description:  Determines if two patterns are equal by determining
      --                  if their instantiations are equal.
      --
      --    Exceptions Raised:  None.

      function Is_Equal (Pattern1, Pattern2 : in Pattern) return Boolean is
      begin
     return SE.Is_Equal (Instantiate (Pattern1), Instantiate (Pattern2));
      end Is_Equal;

      ----------------------------------------------------------------------

      --    Function:     Tag_Variables
      --    Visibility:   Exported.
      --    Description:  Tags all variables within a pattern with the same
      --                  tag.  This can be used to make a particular pattern
      --                  unique with respect to other patterns.
      --
      --    Exceptions Raised:  None.

      procedure Tag_Variables (Pattern_Arg : in Pattern; Tag : in Natural) is

     procedure Tag_Expression (Expression : in SE.S_Expr) is
     begin
        -- If the template is a variable, set its tag.

        if SE.Is_Variable (Expression) then
           SE.Set_Variable_Tag (Expression, Tag);

        -- Otherwise, tag the variables in the first and rest sections
        -- of the given template if it's a non-null, non-atomic expression.

        elsif not SE.Is_Atomic (Expression) then
           Tag_Expression (SE.First (Expression));
           Tag_Expression (SE.Rest (Expression));
        end if;
     end Tag_Expression;

      begin
     Tag_Expression (Get_Template (Pattern_Arg));
     Tag_Expression (Get_Bindings (Pattern_Arg));
      end Tag_Variables;

      -------------------------------------------------------------------------

      --    Function:     Match
      --    Visibility:   Exported.
      --    Description:  If the two pattern arguments can be made identical by
      --                  variable substitution, Is_Match will be set to True
      --                  and the variable binding contexts of Pattern1 and
      --                  Pattern2 will contain the particular set of bindings
      --                  which made the patterns identical.  Otherwise,Is_Match
      --                  will be False and the variable binding contexts for
      --                  the two patterns will remain unchanged.
      --    References:   The pattern matching algorithms used are based upon
      --                  those found in the following reference:
      --
      --                  Wilensky, Robert.  LISPCRAFT.
      --                  New York: W. W. Norton & Co., Inc., 1984.
      --
      --    Exceptions Raised:  None.

      procedure Match (Pattern1, Pattern2 : in out Pattern;
               Is_Match : out Boolean) is

     Match_Arg1, Match_Arg2, Bindings : SE.S_Expr;

     ----------------------------------------------------------------------

     --    Function:     Contained_In
     --    Visibility:   Internal
     --    Description:  Determines if the given pattern variable is
     --                  contained within the given Item.
     --
     --    Exceptions Raised:  None.

     function Contained_In (Pattern_Var, Item, Bindings : in SE.S_Expr)
        return Boolean is

        Var_Value_Pair, Var_Binding : SE.S_Expr;
        Result : Boolean;
     begin

        -- If the item is an atomic literal, the variable cannot be
        -- contained within it.

        if SE.Is_Atomic (Item) and then
           not SE.Is_Variable (Item) then
           Result := False;

        -- If the item is a variable, determine if the pattern variable
        -- and the item are the same variable or if the pattern variable
        -- occurs within the expression to which the item is bound.

        elsif SE.Is_Variable (Item) then
           if SE.Is_Null (Bindings) then
          SE.Bind (Var_Binding, SE.Null_S_Expr);
           else
          SE.Bind (Var_Value_Pair, SE.Associate (Pattern_Var,Bindings));

          if SE.Is_Null (Var_Value_Pair) then
             SE.Bind (Var_Binding, SE.Null_S_Expr);
          else
             SE.Bind (Var_Binding, SE.First (SE.Rest (Var_Value_Pair)));
          end if;
           end if;

           Result := SE.Is_Equal (Pattern_Var, Item) or else
             Contained_In (Pattern_Var, Var_Binding, Bindings);

        -- Otherwise, determine if the pattern variable is contained within
        -- the given non-atomic expression.

        else
           Result :=
          Contained_In (Pattern_Var, SE.First (Item), Bindings) or else
          Contained_In (Pattern_Var, SE.Rest (Item), Bindings);
        end if;

        SE.Free (Var_Binding);
        SE.Free (Var_Value_Pair);
        return Result;
     end Contained_In;

     -- Forward declaration for Match_With_Bindings used
     -- within Variable_Match.

     function Match_With_Bindings (S_Expr1, S_Expr2,
                      Bindings : in SE.S_Expr) return SE.S_Expr;

     ----------------------------------------------------------------------

     --    Function:     Variable_Match
     --    Visibility:   Internal.
     --    Description:  Determines if the input pattern variable can be
     --                  bound to the second argument given the current
     --                  variable bindings.  The binding list resulting
     --                  from this process is returned.
     --
     --    Exceptions Raised:  None.

     function Variable_Match (Pattern_Var, Item, Bindings : in SE.S_Expr)
        return SE.S_Expr is

        Var_Value_Pair, Var_Binding, Result : SE.S_Expr;
     begin

        -- If the second argument is an equivalent variable, return a
        -- symbolic expression whose first component is the current binding
        -- list.

        if SE.Is_Equal (Pattern_Var, Item) then
           SE.Bind (Result, SE.Prefix (Bindings));

        -- Otherwise, continue the attempt to bind the variable to the item.

        else

           -- Lookup the current binding of the variable in the binding list

           if SE.Is_Null (Bindings) then
          SE.Bind (Var_Binding, SE.Null_S_Expr);
           else
          SE.Bind (Var_Value_Pair, SE.Associate (Pattern_Var,Bindings));

          if SE.Is_Null (Var_Value_Pair) then
             SE.Bind (Var_Binding, SE.Null_S_Expr);
          else
             SE.Bind (Var_Binding, SE.First (SE.Rest (Var_Value_Pair)));
          end if;
           end if;

           -- If the variable is currently bound to an expression, determine
           -- if the two expressions can be made equivalent by variable
           -- substitution.

           if not SE.Is_Null (Var_Binding) then
          SE.Bind (Result,
               Match_With_Bindings (Var_Binding, Item, Bindings));

           -- If the pattern variable is not contained within the expression
           -- to which we would like to bind it, it may be bound with the
           -- current expression and added to the binding list. The
           -- augmented binding list is then returned.

           elsif not Contained_In (Pattern_Var, Item, Bindings) then
          SE.Bind (Result,
               SE.Prefix (
                  SE.Prefix (
                 SE.Prefix (Pattern_Var, SE.Prefix (Item)),
                        Bindings)));
           else
          SE.Bind (Result, SE.Null_S_Expr);
           end if;
        end if;

        SE.Free (Var_Binding);
        SE.Free (Var_Value_Pair);
        return SE.Return_And_Free (Result);
     end Variable_Match;

     ----------------------------------------------------------------------

     --    Function:     Match_With_Bindings
     --    Visibility:   Internal.
     --    Description:  Returns a symbolic expression containing the
     --                  variable bindings determined during the pattern
     --                  matching process.
     --
     --    Exceptions Raised:  None.

     function Match_With_Bindings (S_Expr1, S_Expr2, Bindings: in SE.S_Expr)
        return SE.S_Expr is

        New_Bindings : SE.S_Expr;
     begin

        -- If the first expression is a variable, return the result of
        -- attempting to bind it to the second expression.

        if SE.Is_Variable (S_Expr1) then
           return Variable_Match (S_Expr1, S_Expr2, Bindings);

        -- If the second expression is a variable, return the result of
        -- attempting to bind it to the first expression.

        elsif SE.Is_Variable (S_Expr2) then
           return Variable_Match (S_Expr2, S_Expr1, Bindings);

        -- If either argument is atomic, they both have to be to match.

        elsif SE.Is_Atomic (S_Expr1) or else SE.Is_Atomic (S_Expr2) then

           -- If they are equivalent, return a symbolic expression
           -- whose first component is the current binding list.
           -- Otherwise, return null.

           if SE.Is_Equal (S_Expr1, S_Expr2) then
          return SE.Prefix (Bindings);
           else
          return SE.Null_S_Expr;
           end if;

        -- Otherwise, attempt to match the non-atomic components.

        else

           -- First, match the first components of the arguments.

           SE.Bind (New_Bindings,
                Match_With_Bindings (SE.First (S_Expr1),
                         SE.First (S_Expr2),
                         Bindings));

           -- If variable bindings were found for the first components,
           -- continue the match.  Otherwise, it's not worth continuing.

           if not SE.Is_Null (New_Bindings) then
          SE.Bind (New_Bindings,
               Match_With_Bindings (SE.Rest (S_Expr1),
                        SE.Rest (S_Expr2),
                        SE.First (New_Bindings)));
           end if;

           return SE.Return_And_Free (New_Bindings);
        end if;
     end Match_With_Bindings;

     ----------------------------------------------------------------------

     --    Function:     Set_Pattern_Bindings
     --    Visibility:   Internal.
     --    Description:  Sets the variable binding contexts of the pattern
     --                  arguments based on the contents of the binding list
     --
     --    Exceptions Raised:  None.

     procedure Set_Pattern_Bindings (Pattern1, Pattern2 : in out Pattern;
                     Binding_List : in SE.S_Expr) is

        -------------------------------------------------------------------

        --    Function:     Create_Bindings
        --    Visibility:   Internal.
        --    Description:  Creates a variable binding context by searching
        --                  the given template for variables and then adding
        --                  the variable-value pair found in the binding
        --                  list to the context.
        --
        --    Exceptions Raised:  None.

        function Create_Bindings (Template, Binding_List : in SE.S_Expr)
           return SE.S_Expr is
           Var_Value_Pair, Value, Result : SE.S_Expr;
        begin
           -- If it's a variable, return the value to which it's bound
           -- and the values to which any variables within the first
           -- value are bound.

           if SE.Is_Variable (Template) then
          SE.Bind (Var_Value_Pair, SE.Associate(Template,Binding_List));

          if SE.Is_Null (Var_Value_Pair) then
             SE.Bind (Result, SE.Null_S_Expr);
          else
             SE.Bind (Value, SE.First (SE.Rest (Var_Value_Pair)));

             if SE.Is_Atomic (Value) and then
            not SE.Is_Variable (Value) then
            SE.Bind (Result, SE.Prefix (Var_Value_Pair));
             else
            SE.Bind (Result,
                 SE.Prefix (Var_Value_Pair,
                     Create_Bindings (Value,Binding_List)));
             end if;
          end if;

           -- Return null for any other atomic values.

           elsif SE.Is_Atomic (Template) then
          SE.Bind (Result, SE.Null_S_Expr);

           -- Otherwise, create a binding list by prefixing the result
           -- of processing the first component onto the result of
           -- processing the rest.

           elsif not SE.Is_Atomic (Template) then
          SE.Bind (Result, SE."&" (
                Create_Bindings (SE.First (Template),Binding_List),
                Create_Bindings (SE.Rest (Template),Binding_List)));
           end if;

           SE.Free (Var_Value_Pair);
           SE.Free (Value);
           return SE.Return_And_Free (Result);
        end Create_Bindings;

     begin
          Bind (Pattern1,
          Set_Bindings (Pattern1,
                SE."Or" (
                   Get_Bindings (Pattern1),
                   Create_Bindings (Get_Template (Pattern1),
                            Binding_List))));
          Bind (Pattern2,
          Set_Bindings (Pattern2,
                SE."Or" (
                   Get_Bindings (Pattern2),
                       Create_Bindings (Get_Template (Pattern2),
                            Binding_List))));

     end Set_Pattern_Bindings;

      begin

     -- Instantiate the variables found in the template with the
     -- values (if any) to which they're bound in the binding context.

     SE.Bind (Match_Arg1, Instantiate (Pattern1));
     SE.Bind (Match_Arg2, Instantiate (Pattern2));

     -- Attempt to match the two templates,
     -- creating a binding list in the process.

     SE.Bind (Bindings,
           Match_With_Bindings (Match_Arg1, Match_Arg2, SE.Null_S_Expr));

     -- If the match was successful, set the binding contexts of the
     -- individual patterns with the bindings found in the binding list.
     -- Set the value of the boolean result (a null value indicates failure)
     -- as appropriate.

     if not SE.Is_Null (Bindings) then
        SE.Bind (Bindings, SE.First (Bindings));
        if not SE.Is_Atomic (Bindings) then
           Set_Pattern_Bindings (Pattern1, Pattern2, Bindings);
        end if;
        Is_Match := True;
     else
        Is_Match := False;
     end if;

         SE.Free (Match_Arg1);
         SE.Free (Match_Arg2);
         SE.Free (Bindings);
      end Match;

      -------------------------------------------------------------------------

      --    Procedure:    Get
      --    Visibility:   Exported.
      --    Description:  Read a pattern from the specified input file.
      --
      --    Exceptions Raised: None.

      procedure Get (Input_File : in File_Type;
             Pattern_Result : in out Pattern) is
     S_Expr_Arg : SE.S_Expr;
      begin
     SE.Get (Input_File, S_Expr_Arg);
     Bind (Pattern_Result, Create_Pattern (Template => S_Expr_Arg));
     SE.Free (S_Expr_Arg);
      end Get;

      -------------------------------------------------------------------------

      --    Procedure:    Get
      --    Visibility:   Exported.
      --    Description:  Read a pattern from the current default input file.
      --
      --    Exceptions Raised: None.

      procedure Get (Pattern_Result : in out Pattern) is
      begin
     Get (Current_Input, Pattern_Result);
      end Get;

      -------------------------------------------------------------------------

      --    Procedure:    Put
      --    Visibility:   Exported.
      --    Description:  Print the structure of the input pattern
      --                  to the current default output file.
      --
      --    Exceptions Raised: None.

      procedure Put (Pattern_Arg : in Pattern) is
      begin
     SE.Put (Current_Output, Instantiate (Pattern_Arg));
      end Put;

      -------------------------------------------------------------------------

      --    Procedure:    Put
      --    Visibility:   Exported.
      --    Description:  Print the structure of the input pattern
      --                  to the specified output file.
      --
      --    Exceptions Raised:  None.

      procedure Put (Output_File : in File_Type; Pattern_Arg : in Pattern) is
      begin
     SE.Put (Output_File, Instantiate (Pattern_Arg));
      end Put;

   end Patterns;


   package body Rules is

      -------------------------------------------------------------------------

      --    Function:     Create_Rule
      --    Visibility:   Exported.
      --    Description:  Creates a rule. The symbolic expressions form the
      --                  rule's template and the rule's variable binding
      --                  context is set to null.
      --
      --    Exceptions Raised:  None.

      function Create_Rule (Antecedent,
                Consequent,
                Bindings : in SE.S_Expr := SE.Null_S_Expr)
     return Rule is
      begin
     if SE.Is_Null (Antecedent) and then
        SE.Is_Null (Consequent) and then
        SE.Is_Null (Bindings) then
        return Null_Rule;
     else
        return Rule (
           PAT.Create_Pattern (SE.Prefix(Antecedent, SE.Prefix(Consequent)),
                   Bindings));
     end if;
      end Create_Rule;

      -------------------------------------------------------------------------

      --    Function:     Antecedent
      --    Visibility:   Exported.
      --    Description:  Returns the antecedent of the given rule.
      --
      --    Exceptions Raised:  None.

      function Antecedent (Rule_Arg : in Rule) return PAT.Pattern is
      begin
     if Is_Null (Rule_Arg) then
        return PAT.Null_Pattern;
     else
        return PAT.Create_Pattern (SE.First (Get_Template (Rule_Arg)),
                       Get_Bindings (Rule_Arg));
     end if;
      end Antecedent;

      -------------------------------------------------------------------------

      --    Function:     Consequent
      --    Visibility:   Exported.
      --    Description:  Returns the consequent of the given rule.
      --
      --    Exceptions Raised:  None.

      function Consequent (Rule_Arg : in Rule) return PAT.Pattern is
      begin
     if Is_Null (Rule_Arg) then
        return PAT.Null_Pattern;
     else
        return PAT.Create_Pattern (
              SE.First (SE.Rest (Get_Template (Rule_Arg))),
              Get_Bindings (Rule_Arg));
     end if;
      end Consequent;

      -------------------------------------------------------------------------

      --    Function:     Is_Query
      --    Visibility:   Exported.
      --    Description:  Determines if the rule is a query.
      --                  A query is a rule which has only a antecedent.
      --
      --    Exceptions Raised:  None.

      function Is_Query (Rule_Arg : in Rule) return Boolean is
      begin
     if Is_Null (Rule_Arg) then
        return False;
     else
        return SE.Is_Null (SE.First (SE.Rest (Get_Template (Rule_Arg))));
     end if;
      end Is_Query;

      -------------------------------------------------------------------------

      --    Function:     Is_Fact
      --    Visibility:   Exported.
      --    Description:  Determines if the rule is a fact.
      --                  A fact is a rule which has only a consequent.
      --
      --    Exceptions Raised:  None.

      function Is_Fact (Rule_Arg : in Rule) return Boolean is
      begin
     if Is_Null (Rule_Arg) then
        return False;
     else
        return SE.Is_Null (SE.First (Get_Template (Rule_Arg)));
     end if;
      end Is_Fact;

      -------------------------------------------------------------------------

      --    Function:     Is_Rule
      --    Visibility:   Exported.
      --    Description:  Determines if the given rule contains
      --                  both a antecedent and a consequent.
      --
      --    Exceptions Raised:  None.

      function Is_Rule (Rule_Arg : in Rule) return Boolean is
      begin
     if Is_Null (Rule_Arg) then
        return False;
     else
        return not (Is_Query (Rule_Arg) or else Is_Fact (Rule_Arg));
     end if;
      end Is_Rule;

      -------------------------------------------------------------------------

      --    Procedure:    Get
      --    Visibility:   Exported.
      --    Description:  Read a rule from the specified input file.
      --
      --    Exceptions Raised: Invalid_Rule_Format - if the input does not
      --                                             contain both an antecedent
      --                                             and consequent.

      procedure Get (Input_File : in File_Type; Rule_Result : in out Rule) is
     S_Expr_Arg : SE.S_Expr;
      begin
     SE.Get (Input_File, S_Expr_Arg);
     if SE.Is_Null (S_Expr_Arg) then
        Bind (Rule_Result, Null_Rule);
     else
        if SE.Length (S_Expr_Arg) /= 2 then
           SE.Free (S_Expr_Arg);
           raise Invalid_Rule_Format;
        else
           Bind (Rule_Result,
             Create_Rule (
            SE.First (S_Expr_Arg), SE.First (SE.Rest(S_Expr_Arg))));
        end if;
     end if;
     SE.Free (S_Expr_Arg);
      end Get;

      -------------------------------------------------------------------------

      --    Procedure:    Get
      --    Visibility:   Exported.
      --    Description:  Read a rule from the current default input file.
      --
      --    Exceptions Raised: None.

      procedure Get (Rule_Result : in out Rule) is
      begin
     Get (Current_Input, Rule_Result);
      end Get;

   end Rules;


   package body Rulebases is

      Rulebase_Free_List : Rulebase := Null_Rulebase;

      -------------------------------------------------------------------------

      --    Function:     Is_Null
      --    Visibility:   Exported.
      --    Description:  Determines if Rulebase_Arg is empty.
      --
      --    Exceptions Raised:  None.

      function Is_Null (Rulebase_Arg : in Rulebase) return Boolean is
      begin
     -- Check if it's really null.
     if Rulebase_Arg = Null_Rulebase then
        return True;

     -- Otherwise, check to see if there are no rules.
     else
        declare
           Empty : Boolean;
        begin
           for Id in Index'First .. Index'Last loop
          Empty := SE.Is_Null (Rulebase_Arg.Rules(Id));
          exit when not Empty;
           end loop;
           return Empty;
        end;
     end if;
      end Is_Null;

      -------------------------------------------------------------------------

      --    Function:     Is_Equal
      --    Visibility:   Exported.
      --    Description:  Determines if Rulebase_Arg1 is equivalent
      --                  to Rulebase_Arg2.
      --
      --    Exceptions Raised:  None.

      function Is_Equal (Rulebase_Arg1, Rulebase_Arg2 : in Rulebase)
     return Boolean is
     Result : Boolean;
      begin
     -- If one's null the other has to be null to be equal.
     if Is_Null (Rulebase_Arg1) then
        Result := Is_Null (Rulebase_Arg2);

     -- Otherwise, check to see if there are no rules.
     else
        for Id in Index'First .. Index'Last loop
           Result := SE.Is_Null (SE."Xor" (Rulebase_Arg1.Rules(Id),
                           Rulebase_Arg2.Rules(Id)));
           exit when not Result;
        end loop;
     end if;

     return Result;
      end Is_Equal;

      -------------------------------------------------------------------------

      --    Function:     Allocate Rulebase
      --    Visibility:   Internal
      --    Description:  Allocates a new rulebase with its rule array entries
      --                  initialized to Null_Rule.
      --
      --    Exceptions Raised:  None.

      function Allocate_Rulebase return Rulebase is
     New_Rulebase : Rulebase := Null_Rulebase;
     Array_Of_Rules : Rule_Array := Rule_Array'(others => RUL.Null_Rule);
      begin

     -- If the rulebase free list is empty, allocate a new rulebase
     -- node. Otherwise, retrieve one from the free list.

     if Is_Null (Rulebase_Free_List) then
        New_Rulebase := new Rulebase_Node;
     else
        New_Rulebase := Rulebase_Free_List;
        Rulebase_Free_List := Rulebase_Free_List.Next_Free;
     end if;

     -- Initialize the node's reference counter,
     -- free list pointer and value.

     New_Rulebase.Ref_Count := 0;
     New_Rulebase.Next_Free := Null_Rulebase;
     New_Rulebase.Rules     := Array_Of_Rules;

     return New_Rulebase;
      end Allocate_Rulebase;

      -------------------------------------------------------------------------

      --    Function:     Create_Rulebase
      --    Visibility:   Exported.
      --    Description:  Creates a rulebase from the given symbolic expression.
      --
      --    Exceptions Raised:  None.

      function Create_Rulebase (Template : in SE.S_Expr) return Rulebase is
     New_Rulebase : Rulebase := Allocate_Rulebase;
     Temp_Pointer : SE.S_Expr;
      begin
     if SE.Is_Null (Template) then
        return Null_Rulebase;
     else
        SE.Bind (Temp_Pointer, Template);
        while not SE.Is_Null (Temp_Pointer) loop
           Assert (
          RUL.Create_Rule (SE.First (SE.First (Temp_Pointer)),
                   SE.First (SE.Rest (SE.First(Temp_Pointer)))),
          New_Rulebase);
           SE.Bind (Temp_Pointer, SE.Rest (Temp_Pointer));
        end loop;
     end if;

     SE.Free (Temp_Pointer);
     return New_Rulebase;

     exception
        when SE.Atomic_Expression |
         RUL.Invalid_Rule_Format =>
           raise Invalid_Rulebase_Format;

      end Create_Rulebase;

      -------------------------------------------------------------------------

      --    Function:     Get_Template
      --    Visibility:   Exported.
      --    Description:  Returns a symbolic expression representing the
      --                  template for the given rulebase.
      --
      --    Exceptions Raised:  None.

      function Get_Template (Rulebase_Arg : in Rulebase) return SE.S_Expr is
     Template, Slot : SE.S_Expr;
      begin
     SE.Bind (Template, SE.Null_S_Expr);
     if not Is_Null (Rulebase_Arg) then
        for Id in reverse Index'First .. Index'Last loop
           SE.Bind (Slot, Rulebase_Arg.Rules(Id));
           while not SE.Is_Null (Slot) loop
          SE.Bind (Template,
             SE.Prefix (RUL.Instantiate (SE.First (Slot)), Template));
          SE.Bind (Slot, SE.Rest (Slot));
           end loop;
        end loop;
     end if;

     SE.Free (Slot);
     return SE.Return_And_Free (Template);
      end Get_Template;

      -------------------------------------------------------------------------

      --    Function:     Free
      --    Visibility:   Exported.
      --    Description:  Frees the given rulebase.
      --
      --    Exceptions Raised:  None.

      procedure Free (Rulebase_Arg : in out Rulebase) is
      begin

     -- Only non-null rulebases need to be freed.

     if not Is_Null (Rulebase_Arg) then

        -- If the reference count of the rulebase is greater than one
        -- (there is more than one variable of type Rulebase which refers
        -- to this structure), we don't want to return its storage to the
        -- free lists.  Just decrement the reference counter.

        if Rulebase_Arg.Ref_Count > 1 then
           Rulebase_Arg.Ref_Count := Rulebase_Arg.Ref_Count - 1;

        -- Otherwise, free all the contents of the rulebase and
        -- put it on the free list.

        else
           for Id in Index'First .. Index'Last loop
          SE.Free (Rulebase_Arg.Rules(Id));
           end loop;
           Rulebase_Arg.Next_Free := Rulebase_Free_List;
           Rulebase_Free_List := Rulebase_Arg;
        end if;

        Rulebase_Arg := Null_Rulebase;
     end if;
      end Free;

      -------------------------------------------------------------------------

      --    Function:     Return_And_Free
      --    Visibility:   Exported.
      --    Description:  Provides a way for decrementing the ref-count of a
      --                  rulebase bound to a local variable being returned
      --                  from a function.
      --
      --    Exceptions Raised:  None.

      function Return_And_Free (Rulebase_Arg : in Rulebase) return Rulebase is
      begin
     if not Is_Null (Rulebase_Arg) and then
        Rulebase_Arg.Ref_Count > 0 then
        Rulebase_Arg.Ref_Count := Rulebase_Arg.Ref_Count - 1;
     end if;

     return Rulebase_Arg;
      end Return_And_Free;

      -------------------------------------------------------------------------

      --    Function:     Bind
      --    Visibility:   Exported.
      --    Description:  Assigns the value of New_Value to Current_Value after
      --                  freeing the value of Current_Value.
      --
      --    Exceptions Raised:  None.

      procedure Bind (Current_Value : in out Rulebase;
              New_Value : in Rulebase) is
     Temp_Value : Rulebase := Current_Value;
      begin

     -- Ignore cases of Bind (X, X);

     if Current_Value /= New_Value then
        Current_Value := New_Value;

        -- Increment the ref-count.

        if not Is_Null (Current_Value) then
           Current_Value.Ref_Count := Current_Value.Ref_Count + 1;
        end if;

        -- Free the original rulebase.

        if not Is_Null (Temp_Value) then
           Free (Temp_Value);
        end if;
     end if;
      end Bind;

      -------------------------------------------------------------------------

      --    Function:     Assert
      --    Visibility:   Exported.
      --    Description:  Adds the given rule to the specified rulebase.
      --
      --    Exceptions Raised:  None.

      procedure Assert (Rule_Arg : in RUL.Rule;
            Rulebase_Arg : in out Rulebase) is
     Id : Index;
      begin
     if Is_Null (Rulebase_Arg) then
        Bind (Rulebase_Arg, Allocate_Rulebase);
     end if;
     Id := Key (Rule_Arg);
     SE.Bind (Rulebase_Arg.Rules(Id),
          SE.Prefix(Rule_Arg, Rulebase_Arg.Rules(Id)));
      end Assert;

      -------------------------------------------------------------------------

      --    Function:     Retract
      --    Visibility:   Exported.
      --    Description:  Removes all occurrences of the given rule from the
      --                  specified rulebase.
      --
      --    Exceptions Raised:  None.

      procedure Retract (Rule_Arg : in RUL.Rule;
             Rulebase_Arg : in out Rulebase) is
     Id : Index;
      begin
     if not Is_Null (Rulebase_Arg) then
        Id := Key (Rule_Arg);
        SE.Bind (Rulebase_Arg.Rules(Id),
             SE.Delete (Rule_Arg, Rulebase_Arg.Rules(Id)));
     end if;
      end Retract;

      -------------------------------------------------------------------------

      --    Function:     "And" (Intersection)
      --    Visibility:   Exported.
      --    Description:  Returns a rulebase containing all those rules
      --                  which are both in Rulebase1 AND Rulebase2.
      --
      --    Exceptions Raised:  None.

      function "And" (Rulebase1, Rulebase2 : in Rulebase) return Rulebase is
     New_Rulebase : Rulebase := Allocate_Rulebase;
      begin
     for Id in Index'First .. Index'Last loop
        SE.Bind (New_Rulebase.Rules(Id),
             SE."And" (Rulebase1.Rules(Id), Rulebase2.Rules(Id)));
     end loop;
     return New_Rulebase;
      end "And";

      -------------------------------------------------------------------------

      --    Function:     "Or" (Union)
      --    Visibility:   Exported.
      --    Description:  Returns a rulebase containing all those rules
      --                  which are either in Rulebase1 OR Rulebase2.
      --
      --    Exceptions Raised:  None.

      function "Or" (Rulebase1, Rulebase2 : in Rulebase) return Rulebase is
     New_Rulebase : Rulebase := Allocate_Rulebase;
      begin
     for Id in Index'First .. Index'Last loop
        SE.Bind (New_Rulebase.Rules(Id),
             SE."Or" (Rulebase1.Rules(Id), Rulebase2.Rules(Id)));
     end loop;
     return New_Rulebase;
      end "Or";

      -------------------------------------------------------------------------

      --    Function:     "-" (Difference)
      --    Visibility:   Exported.
      --    Description:  Returns a rulebase containing all those rules
      --                  which are in Rulebase1 but NOT in Rulebase2.
      --
      --    Exceptions Raised:  None.

      function "-" (Rulebase1, Rulebase2 : in Rulebase) return Rulebase is
     New_Rulebase : Rulebase := Allocate_Rulebase;
      begin
     for Id in Index'First .. Index'Last loop
        SE.Bind (New_Rulebase.Rules(Id),
             SE."-" (Rulebase1.Rules(Id), Rulebase2.Rules(Id)));
     end loop;
     return New_Rulebase;
      end "-";

      -------------------------------------------------------------------------

      --    Function:     "Xor" (Exclusive Or)
      --    Visibility:   Exported.
      --    Description:  Returns a rulebase containing all those rules
      --                  which are in Rulebase1 but NOT Rulebase2 AND
      --                  all those rules which are in Rulebase2 but NOT
      --                  in Rulebase1.
      --
      --    Exceptions Raised:  None.

      function "Xor" (Rulebase1, Rulebase2 : in Rulebase) return Rulebase is
     New_Rulebase : Rulebase := Allocate_Rulebase;
      begin
     for Id in Index'First .. Index'Last loop
        SE.Bind (New_Rulebase.Rules(Id),
             SE."Xor" (Rulebase1.Rules(Id), Rulebase2.Rules(Id)));
     end loop;
     return New_Rulebase;
      end "Xor";

      -------------------------------------------------------------------------

      --    Function:     Retrieve
      --    Visibility:   Exported.
      --    Description:  Returns a symbolic expression containing instantiated
      --                  versions of all rules which matched the input query.
      --
      --    Exceptions Raised:  None.

      function Retrieve (Rule_Arg : in RUL.Rule;
             Rulebase_Arg : in Rulebase) return SE.S_Expr is
     List_Of_Bindings, Current_Bindings,
     Antecedent_Var, List_Of_Instantiations : SE.S_Expr;
     Rule_Antecedent : PAT.Pattern;

     ----------------------------------------------------------------------

     --    Procedure:    Query
     --    Visibility:   Internal.
     --    Description:  Recursive procedure which follows a backward
     --                  chaining algorithm to determine if the input
     --                  argument matches the information in the rulebase.
     --
     --    Exceptions Raised:  None.

     procedure Query (Query_Arg : in SE.S_Expr) is

        Rule_Subset, Original_Bindings : SE.S_Expr;
        New_Rule, Current_Rule : RUL.Rule;
        Success : Boolean;

     begin

        -- Create a new rule with the given query arg.
        RUL.Bind (New_Rule, RUL.Create_Rule (Antecedent_Var, Query_Arg));

        -- Get the subset of rules in the rulebase against
        -- which we can match the new rule.
        SE.Bind (Rule_Subset, Rulebase_Arg.Rules (Key (New_Rule)));

        -- While there are still rules in the subset
        -- to be matched against ...
        while not SE.Is_Null (Rule_Subset) loop

               -- Erase any existing bindings for New_Rule.
           RUL.Bind (New_Rule, RUL.Set_Bindings (New_Rule, SE.Null_S_Expr));

           -- Get the first rule in the subset.
           RUL.Bind (Current_Rule, SE.First (Rule_Subset));

           -- Match the new rule with the current rule.
           RUL.Match (New_Rule, Current_Rule, Success);

           -- If the match succeeded ..
           if Success then

          -- Add the bindings of all variables in the new rule
          -- to the current binding set we're using.
          SE.Bind (Original_Bindings, Current_Bindings);
          SE.Bind (Current_Bindings,
               SE."&" (Current_Bindings,
                   RUL.Get_Bindings (New_Rule)));

          -- If the current rule is a fact ..
          if RUL.Is_Fact (Current_Rule) then

             -- Add the current binding set to the master
             -- set of binding sets.
             SE.Bind (List_Of_Bindings,
                  SE.Prefix (Current_Bindings, List_Of_Bindings));

          -- Otherwise, the current rule in the subset must
          -- actually be a rule.
          else

             -- Instantiate the value bound to the variable ?antecedent
             -- in the new rule and pass it off to a another invocation
             -- of the Query procedure.
             Query (PAT.Instantiate (RUL.Antecedent (New_Rule)));
          end if;

          -- Undo the bindings contributed by the new rule and
          -- reset the bindings of the current rule from the subset.
          SE.Bind (Current_Bindings, Original_Bindings);
          RUL.Bind (Current_Rule,
                RUL.Set_Bindings (Current_Rule, SE.Null_S_Expr));
           end if;

           -- Shorten the symbolic expression containing the
           -- subset of rules to be examined.
           SE.Bind (Rule_Subset, SE.Rest (Rule_Subset));
        end loop;

        RUL.Free (Current_Rule);
        RUL.Free (New_Rule);
        SE.Free (Original_Bindings);
        SE.Free (Rule_Subset);
     end Query;

      begin
     -- Create a variable of the form "?antecedent"
     -- for use in the Query function.
     SE.Bind (Antecedent_Var, SE.Create_Atomic_Variable ("antecedent"));

     -- Extract the antecedent from the given query.
     PAT.Bind (Rule_Antecedent, RUL.Antecedent (Rule_Arg));

     -- Pass the instantiated pattern off to the Query function.
     Query (PAT.Instantiate (Rule_Antecedent));

     -- If a list of binding sets has been contributed as a
     -- result of the Query function, make a list of instantiations
     -- using the given query and the list of binding sets.
     while not SE.Is_Null (List_Of_Bindings) loop
        PAT.Bind (Rule_Antecedent,
              PAT.Set_Bindings (Rule_Antecedent,
                        SE.First (List_Of_Bindings)));
        SE.Bind (List_Of_Instantiations,
             SE.Prefix (PAT.Instantiate (Rule_Antecedent),
                        List_Of_Instantiations));
        SE.Bind (List_Of_Bindings, SE.Rest (List_Of_Bindings));
     end loop;

     SE.Free (List_Of_Bindings);
     SE.Free (Current_Bindings);
     SE.Free (Antecedent_Var);
     PAT.Free (Rule_Antecedent);

     -- Return the list of instantiations.
     return SE.Return_And_Free (List_Of_Instantiations);

      end Retrieve;

      -------------------------------------------------------------------------

      --    Procedure:    Get
      --    Visibility:   Exported.
      --    Description:  Reads a rulebase from the given input file.
      --
      --    Exceptions Raised:  None.

      procedure Get (Input_File : in File_Type;
             Rulebase_Result : in out Rulebase) is
     S_Expr_Arg : SE.S_Expr;
      begin
     SE.Get (Input_File, S_Expr_Arg);
     Bind (Rulebase_Result, Create_Rulebase (S_Expr_Arg));
     SE.Free (S_Expr_Arg);
      end Get;

      -------------------------------------------------------------------------

      --    Procedure:    Get
      --    Visibility:   Exported
      --    Description:  Reads a rulebase from the current default input file.
      --
      --    Exceptions Raised:  None.

      procedure Get (Rulebase_Result : in out Rulebase) is
      begin
     Get (Current_Input, Rulebase_Result);
      end Get;

      -------------------------------------------------------------------------

      --    Procedure:    Put
      --    Visibility:   Exported.
      --    Description:  Prints the contents of a rulebase to the given
      --                  output file.
      --
      --    Exceptions Raised:  None.

      procedure Put (Output_File : in File_Type;
             Rulebase_Arg : in Rulebase) is
      begin
     SE.Put (Output_File, Get_Template (Rulebase_Arg));
      end Put;

      -------------------------------------------------------------------------

      --    Procedure:    Put
      --    Visibility:   Exported.
      --    Description:  Prints the contents of a rulebase to the current
      --                  default output file.
      --
      --    Exceptions Raised:  None.

      procedure Put (Rulebase_Arg : in Rulebase) is
      begin
     SE.Put (Current_Output, Get_Template (Rulebase_Arg));
      end Put;

   end Rulebases;

begin
   Lookahead := ' ';
end AI_Data_Types;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--instspc.ada
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
---------------------------------------------------------------------------

-- Inst_Facilities package specification

-- The following specification describes how the facilities which
-- are needed to instantiate the AI_Data_Types package should be defined
-- and used.

-- Developing Organization:  Software Architecture & Engineering
--                           1600 Wilson Boulevard, Suite 500
--                           Arlington, VA  22209
--
-- Contact:  Michael A. Jaskowiak

---------------------------------------------------------------------------

with Text_Io; use Text_Io;
with Integer_Text_Io; use Integer_Text_Io;
with AI_Data_Types;
package Inst_Facilities is

   type Literal_Kind is (Int, Length1,  Length2,  Length3,  Length4,  Length5,
                  Length6,  Length7,  Length8,  Length9,  Length10,
                  Length11, Length12, Length13, Length14, Length15);

   type Atomic_Literal (Kind : Literal_Kind := Int) is
      record
     case Kind is
        when Int => Int : Integer;
        when Length1  => Length1  : String (1 .. 1);
        when Length2  => Length2  : String (1 .. 2);
        when Length3  => Length3  : String (1 .. 3);
        when Length4  => Length4  : String (1 .. 4);
        when Length5  => Length5  : String (1 .. 5);
        when Length6  => Length6  : String (1 .. 6);
        when Length7  => Length7  : String (1 .. 7);
        when Length8  => Length8  : String (1 .. 8);
        when Length9  => Length9  : String (1 .. 9);
        when Length10 => Length10 : String (1 .. 10);
        when Length11 => Length11 : String (1 .. 11);
        when Length12 => Length12 : String (1 .. 12);
        when Length13 => Length13 : String (1 .. 13);
        when Length14 => Length14 : String (1 .. 14);
        when Length15 => Length15 : String (1 .. 15);
     end case;
      end record;

   ----------------------------------------------------------------------

   --    Function:       String_To_Literal
   --    Description:    Converts the input string to a value of
   --                    type Atomic_Literal.
   --    Restrictions:  None.

   function String_To_Literal (String_Arg : in String)
      return Atomic_Literal;

   -------------------------------------------------------------------------

   --    Function:       Is_Equal
   --    Description:    Determines if two atomic literals are equivalent.
   --    Restrictions:   None.

   function Is_Equal (Lit_Arg1, Lit_Arg2 : in Atomic_Literal)
      return Boolean;

   Lookahead : Character := ' ';

   -------------------------------------------------------------------------

   --    Procedure:      Get
   --    Description:    Reads an atomic literal from the given file.
   --    Restrictions:   None.

   procedure Get (Input_File : in File_Type;
          Literal_Result : in out Atomic_Literal);

   -------------------------------------------------------------------------

   --    Procedure:      Put
   --    Description:    Prints the image of the input atomic literal.
   --    Restrictions:   None.

   procedure Put (Output_File : in File_Type;
          Literal_Arg : in Atomic_Literal);

   package AI_Types is
      new AI_Data_Types (Atomic_Literal, Is_Equal, Lookahead, Get, Put);

end Inst_Facilities;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--instimp.ada
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
---------------------------------------------------------------------------

-- Inst_Facilities package implementation

-- The following implementation describes how the facilities which
-- are needed to instantiate the AI_Data_Types package should be defined
-- and used.

-- Developing Organization:  Software Architecture & Engineering
--                           1600 Wilson Boulevard, Suite 500
--                           Arlington, VA  22209
--
-- Contact:  Michael A. Jaskowiak

---------------------------------------------------------------------------

package body Inst_Facilities is

   ----------------------------------------------------------------------

   --    Function:       String_To_Literal
   --    Description:    Converts the input string to a value of
   --                    type Atomic_Literal.
   --    Restrictions:  None.

   function String_To_Literal (String_Arg : in String)
      return Atomic_Literal is
      Atom_Value : Atomic_Literal;
      Atom_Str   : String (1 .. String_Arg'Length) := String_Arg;
      Is_Numeric : Boolean := True;
      Index      : Natural range 0 .. Atom_Str'Last := 1;
   begin
      Is_Numeric :=
     ('0' <= Atom_Str(Index) and Atom_Str(Index) <= '9') or else
     (Atom_Str(Index) = '-' and Index /= Atom_Str'Last);

      while Is_Numeric and then
        Index /= Atom_Str'Last loop
     Index := Index + 1;
     Is_Numeric := '0' <= Atom_Str(Index) and Atom_Str(Index) <= '9';
      end loop;

      if Is_Numeric then
     Atom_Value := (Kind => Int, Int => Integer'Value (Atom_Str));
      else
     case Atom_Str'Length is
        when 1  => Atom_Value := (Kind => Length1,  Length1  => Atom_Str);
        when 2  => Atom_Value := (Kind => Length2,  Length2  => Atom_Str);
        when 3  => Atom_Value := (Kind => Length3,  Length3  => Atom_Str);
        when 4  => Atom_Value := (Kind => Length4,  Length4  => Atom_Str);
        when 5  => Atom_Value := (Kind => Length5,  Length5  => Atom_Str);
        when 6  => Atom_Value := (Kind => Length6,  Length6  => Atom_Str);
        when 7  => Atom_Value := (Kind => Length7,  Length7  => Atom_Str);
        when 8  => Atom_Value := (Kind => Length8,  Length8  => Atom_Str);
        when 9  => Atom_Value := (Kind => Length9,  Length9  => Atom_Str);
        when 10 => Atom_Value := (Kind => Length10, Length10 => Atom_Str);
        when 11 => Atom_Value := (Kind => Length11, Length11 => Atom_Str);
        when 12 => Atom_Value := (Kind => Length12, Length12 => Atom_Str);
        when 13 => Atom_Value := (Kind => Length13, Length13 => Atom_Str);
        when 14 => Atom_Value := (Kind => Length14, Length14 => Atom_Str);
        when 15 => Atom_Value := (Kind => Length15, Length15 => Atom_Str);
        when others => raise Constraint_Error;
     end case;
      end if;

      return Atom_Value;
   end String_To_Literal;

   -------------------------------------------------------------------------

   --    Function:       Is_Equal
   --    Description:    Determines if two atomic literals are equivalent.
   --    Restrictions:   None.

   function Is_Equal (Lit_Arg1, Lit_Arg2 : in Atomic_Literal) return Boolean is
   begin
      if Lit_Arg1.Kind /= Lit_Arg2.Kind then
     return False;
      else
     case Lit_Arg1.Kind is
        when Int => return Lit_Arg1.Int  = Lit_Arg2.Int;
        when Length1  => return Lit_Arg1.Length1  = Lit_Arg2.Length1;
        when Length2  => return Lit_Arg1.Length2  = Lit_Arg2.Length2;
        when Length3  => return Lit_Arg1.Length3  = Lit_Arg2.Length3;
        when Length4  => return Lit_Arg1.Length4  = Lit_Arg2.Length4;
        when Length5  => return Lit_Arg1.Length5  = Lit_Arg2.Length5;
        when Length6  => return Lit_Arg1.Length6  = Lit_Arg2.Length6;
        when Length7  => return Lit_Arg1.Length7  = Lit_Arg2.Length7;
        when Length8  => return Lit_Arg1.Length8  = Lit_Arg2.Length8;
        when Length9  => return Lit_Arg1.Length9  = Lit_Arg2.Length9;
        when Length10 => return Lit_Arg1.Length10 = Lit_Arg2.Length10;
        when Length11 => return Lit_Arg1.Length11 = Lit_Arg2.Length11;
        when Length12 => return Lit_Arg1.Length12 = Lit_Arg2.Length12;
        when Length13 => return Lit_Arg1.Length13 = Lit_Arg2.Length13;
        when Length14 => return Lit_Arg1.Length14 = Lit_Arg2.Length14;
        when Length15 => return Lit_Arg1.Length15 = Lit_Arg2.Length15;
     end case;
      end if;
   end Is_Equal;

   -------------------------------------------------------------------------

   --    Procedure:      Get
   --    Description:    Reads an atomic literal from the given file.
   --    Restrictions:   None.

   procedure Get (Input_File : in File_Type;
          Literal_Result : in out Atomic_Literal) is

      ----------------------------------------------------------------------

      --    Function:     Get_Atom_Rep
      --    Visibility:   Internal.
      --    Description:  Returns a string containing the character
      --                  representation of the next atomic expression
      --                  to be processed.
      --
      --    Exceptions Raised: None.

      function Get_Atom_Rep return String is
     Input_Char        : Character;
     Max_Buffer_Length : constant Natural := 255;
     Position          : Natural range 0 .. Max_Buffer_Length := 0;
     Atom_Buffer       : String (1 .. Max_Buffer_Length);
     Separator         : constant Character := ',';
     Delimiter         : constant Character := ' ';
     Non_Atomic_Suffix : constant Character := ')';
      begin

         Input_Char := Lookahead;
     Lookahead := ' ';

     -- Read characters from the file and put them in a
     -- buffer until finding a separator or non-atomic suffix
     -- or the end of the line.

     while Input_Char /= Separator and then
           Input_Char /= Delimiter and then
           Input_Char /= Non_Atomic_Suffix loop
        Position := Position + 1;
        Atom_Buffer (Position) := Input_Char;

        exit when End_Of_Line (Input_File);

        Get (Input_File, Input_Char);
     end loop;

     if Input_Char = Separator or else
        Input_Char = Non_Atomic_Suffix then
        Lookahead := Input_Char;
     end if;

     return Atom_Buffer (1 .. Position);
      end Get_Atom_Rep;

   begin
      Literal_Result := String_To_Literal (Get_Atom_Rep);
   end Get;

   -------------------------------------------------------------------------

   --    Procedure:      Put
   --    Description:    Prints the image of the input atomic literal.
   --    Restrictions:   None.

   procedure Put (Output_File : in File_Type;
          Literal_Arg : in Atomic_Literal) is
   begin
      case Literal_Arg.Kind is
     when Int => Put (File => Output_File,
              Item => Literal_Arg.Int, Width => 0);
     when Length1  => Put (Output_File, Literal_Arg.Length1);
     when Length2  => Put (Output_File, Literal_Arg.Length2);
     when Length3  => Put (Output_File, Literal_Arg.Length3);
     when Length4  => Put (Output_File, Literal_Arg.Length4);
     when Length5  => Put (Output_File, Literal_Arg.Length5);
     when Length6  => Put (Output_File, Literal_Arg.Length6);
     when Length7  => Put (Output_File, Literal_Arg.Length7);
     when Length8  => Put (Output_File, Literal_Arg.Length8);
     when Length9  => Put (Output_File, Literal_Arg.Length9);
     when Length10 => Put (Output_File, Literal_Arg.Length10);
     when Length11 => Put (Output_File, Literal_Arg.Length11);
     when Length12 => Put (Output_File, Literal_Arg.Length12);
     when Length13 => Put (Output_File, Literal_Arg.Length13);
     when Length14 => Put (Output_File, Literal_Arg.Length14);
     when Length15 => Put (Output_File, Literal_Arg.Length15);
      end case;
   end Put;

end Inst_Facilities;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--aitypesdemo.ada
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
---------------------------------------------------------------------------

-- AITypesdemo demonstration implementation

-- The following subprogram is an implementation of the facilities
-- used to demonstrate the AI_Data_Types package.

-- Developing Organization:  Software Architecture & Engineering
--                           1600 Wilson Boulevard, Suite 500
--                           Arlington, VA  22209
--
-- Contact:  Michael A. Jaskowiak

---------------------------------------------------------------------------

with Text_Io;
with Integer_Text_Io;
with Inst_Facilities;
procedure AITypesdemo is
   Max_Length    : constant Natural := 8;
   Stringlength  : Natural range 0 .. Max_Length;
   Response      : String (1 .. Max_Length)  := (1 .. Max_Length  => ' ');

   package SE renames Inst_Facilities.AI_Types.Symbolic_Expressions;
   package PAT renames Inst_Facilities.AI_Types.Patterns;
   package RUL renames Inst_Facilities.AI_Types.Rules;
   package TIO renames Text_Io;
   package ITIO renames Integer_Text_Io;
   package BIO is new TIO.Enumeration_Io (Boolean);

   procedure Sexprdemo is

      type Functions is (Is_Null, Is_Atomic, Is_Variable, Is_Non_Atomic,
             Is_Equal, Is_Member, Prefix, Append, First, Rest,
             Last, Nth, Nth_First, Nth_Rest, Reverse_S_Expr,
             Delete, Replace, Flatten, Set_And, Set_Or, Set_Differ,
             Set_Xor, Associate, Associate_All, Length, Help, Quit);

      package FIO is new TIO.Enumeration_Io (Functions);

      Function_Name : Functions;
      Symbol_Exp1, Symbol_Exp2, Symbol_Exp3, Result : SE.S_Expr;
      Prompt : constant String := " -> ";
      Spacer : constant String := "    ";
      Position, Repetitions, Int_Result : Integer;
      Boolean_Result : Boolean;

   begin
      TIO.New_Line;
      TIO.Put_line(" Entering the Symbolic Expression Demonstration.");
      TIO.Put_line(" To terminate this demonstration, enter ""quit"" at any time.");
      TIO.Put_line(" For a list of available operations, enter ""help"".");
      TIO.New_Line;

      SE.Bind (Symbol_Exp1, SE.Null_S_Expr);
      SE.Bind (Symbol_Exp2, SE.Null_S_Expr);
      SE.Bind (Symbol_Exp3, SE.Null_S_Expr);
      SE.Bind (Result, SE.Null_S_Expr);

      loop
     TIO.New_Line;
     TIO.Put (Prompt);

     begin
        FIO.Get (Function_Name);

        case Function_Name is

           when Is_Null =>
          SE.Get (Symbol_Exp1);
          Boolean_Result := SE.Is_Null (Symbol_Exp1);
          TIO.New_Line;
          TIO.Put (Spacer);
          BIO.Put (Boolean_Result);

           when Is_Atomic =>
          SE.Get (Symbol_Exp1);
          Boolean_Result := SE.Is_Atomic (Symbol_Exp1);
          TIO.New_Line;
          TIO.Put (Spacer);
          BIO.Put (Boolean_Result);

           when Is_Variable =>
          SE.Get (Symbol_Exp1);
          Boolean_Result := SE.Is_Variable (Symbol_Exp1);
          TIO.New_Line;
          TIO.Put (Spacer);
          BIO.Put (Boolean_Result);

           when Is_Non_Atomic =>
          SE.Get (Symbol_Exp1);
          Boolean_Result := SE.Is_Non_Atomic (Symbol_Exp1);
          TIO.New_Line;
          TIO.Put (Spacer);
          BIO.Put (Boolean_Result);

           when Is_Equal =>
          SE.Get (Symbol_Exp1);
          SE.Get (Symbol_Exp2);
          Boolean_Result := SE.Is_Equal (Symbol_Exp1, Symbol_Exp2);
          TIO.New_Line;
          TIO.Put (Spacer);
          BIO.Put (Boolean_Result);

           when Is_Member =>
          SE.Get (Symbol_Exp1);
          SE.Get (Symbol_Exp2);
          Boolean_Result := SE.Is_Member (Symbol_Exp1, Symbol_Exp2);
          TIO.New_Line;
          TIO.Put (Spacer);
          BIO.Put (Boolean_Result);

           when First =>
          SE.Get (Symbol_Exp1);
          SE.Bind (Result, SE.First (Symbol_Exp1));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (Result);

           when Rest =>
          SE.Get (Symbol_Exp1);
          SE.Bind (Result, SE.Rest (Symbol_Exp1));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (Result);

           when Last =>
          SE.Get (Symbol_Exp1);
          SE.Bind (Result, SE.Last (Symbol_Exp1));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (Result);

           when Nth =>
          SE.Get (Symbol_Exp1);
          ITIO.Get (Position);
          SE.Bind (Result, SE.Nth (Symbol_Exp1, Position));
          TIO.Put (Spacer);
          SE.Put (Result);

           when Nth_First =>
          SE.Get (Symbol_Exp1);
          ITIO.Get (Repetitions);
          SE.Bind (Result, SE.Nth_First (Symbol_Exp1, Repetitions));
          TIO.Put (Spacer);
          SE.Put (Result);

           when Nth_Rest =>
          SE.Get (Symbol_Exp1);
          ITIO.Get (Repetitions);
          SE.Bind (Result, SE.Nth_Rest (Symbol_Exp1, Repetitions));
          TIO.Put (Spacer);
          SE.Put (Result);

           when Prefix =>
          SE.Get (Symbol_Exp1);
          SE.Get (Symbol_Exp2);
          SE.Bind (Result, SE.Prefix (Symbol_Exp1, Symbol_Exp2));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (Result);

           when Reverse_S_Expr =>
          SE.Get (Symbol_Exp1);
          SE.Bind (Result, SE.Reverse_S_Expr (Symbol_Exp1));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (Result);

           when Length =>
          SE.Get (Symbol_Exp1);
          Int_Result := SE.Length (Symbol_Exp1);
          TIO.New_Line;
          TIO.Put (Spacer);
          ITIO.Put (Item => Int_Result, Width => 0);

           when Delete =>
          SE.Get (Symbol_Exp1);
          SE.Get (Symbol_Exp2);
          SE.Bind (Result, SE.Delete (Symbol_Exp1, Symbol_Exp2));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (Result);

           when Replace =>
          SE.Get (Symbol_Exp1);
          SE.Get (Symbol_Exp2);
          SE.Get (Symbol_Exp3);
          SE.Bind (Result,
               SE.Replace (Symbol_Exp1, Symbol_Exp2, Symbol_Exp3));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (Result);

           when Flatten =>
          SE.Get (Symbol_Exp1);
          SE.Bind (Result, SE.Flatten (Symbol_Exp1));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (Result);

           when Set_And =>
          SE.Get (Symbol_Exp1);
          SE.Get (Symbol_Exp2);
          SE.Bind (Result, SE."And" (Symbol_Exp1, Symbol_Exp2));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (Result);

           when Set_Or =>
          SE.Get (Symbol_Exp1);
          SE.Get (Symbol_Exp2);
          SE.Bind (Result, SE."Or" (Symbol_Exp1, Symbol_Exp2));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (Result);

           when Set_Differ =>
          SE.Get (Symbol_Exp1);
          SE.Get (Symbol_Exp2);
          SE.Bind (Result, SE."-" (Symbol_Exp1, Symbol_Exp2));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (Result);

           when Set_Xor =>
          SE.Get (Symbol_Exp1);
          SE.Get (Symbol_Exp2);
          SE.Bind (Result, SE."Xor" (Symbol_Exp1, Symbol_Exp2));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (Result);

           when Associate =>
          SE.Get (Symbol_Exp1);
          SE.Get (Symbol_Exp2);
          ITIO.Get (Position);
          SE.Bind (Result,
               SE.Associate (Symbol_Exp1, Symbol_Exp2, Position));
          TIO.Put (Spacer);
          SE.Put (Result);

           when Associate_All =>
          SE.Get (Symbol_Exp1);
          SE.Get (Symbol_Exp2);
          ITIO.Get (Position);
          SE.Bind (Result,
               SE.Associate_All (Symbol_Exp1, Symbol_Exp2, Position));
          TIO.Put (Spacer);
          SE.Put (Result);

           when Append =>
          SE.Get (Symbol_Exp1);
          SE.Get (Symbol_Exp2);
          SE.Bind (Result, SE."&" (Symbol_Exp1, Symbol_Exp2));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (Result);

           when Help =>
          TIO.New_Line;
          TIO.New_Line;
          TIO.Put_Line (" Available Operations:");
          TIO.New_Line;
          TIO.Put_Line ("    Append         Help           Is_Variable  Prefix          Set_Differ");
          TIO.Put_Line ("    Associate      Is_Atomic      Last         Quit            Set_Or");
          TIO.Put_Line ("    Associate_All  Is_Equal       Length       Replace         Set_Xor");
          TIO.Put_Line ("    Delete         Is_Member      Nth          Rest");
          TIO.Put_Line ("    First          Is_Non_Atomic  Nth_First    Reverse_S_Expr");
          TIO.Put_Line ("    Flatten        Is_Null        Nth_Rest     Set_And");
          TIO.New_Line;
          TIO.Put_Line (" For more specific information, see the User's Manual.");

           when Quit =>
          TIO.Skip_Line;
          TIO.Put_line (" Exiting Symbolic Expression Demonstration.");
          return;

           when Others =>
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Not accessible.");

        end case;


        exception
           when TIO.Data_Error =>
          TIO.Put (Spacer);
          TIO.Put ("Incorrect function name, try again.");
           when SE.Improper_Input =>
          TIO.Put (Spacer);
          TIO.Put ("Input error, try again.");
           when SE.Atomic_Expression =>
          TIO.Put (Spacer);
          TIO.Put ("Input must be non-atomic, try again.");
           when SE.Non_Atomic_Expression =>
          TIO.Put (Spacer);
          TIO.Put ("Input must be atomic, try again.");
           when SE.Invalid_Position =>
          TIO.Put (Spacer);
          TIO.Put ("No value at that position, try again.");
           when SE.Missing_Separator =>
          TIO.Put (Spacer);
          TIO.Put ("Input is missing a separator, try again.");
           when SE.Extra_Separator =>
          TIO.Put (Spacer);
          TIO.Put ("Input has an extra separator, try again.");
           when SE.Invalid_Repetitions =>
          TIO.Put (Spacer);
          TIO.Put ("Invalid number of repetitions, try again.");
     end;

     TIO.Skip_Line;
     SE.Free (Symbol_Exp1);
     SE.Free (Symbol_Exp2);
     SE.Free (Symbol_Exp3);
     SE.Free (Result);
      end loop;

   end Sexprdemo;

   procedure Patdemo is

      type Functions is (Is_Null1, Is_Null2, Is_Equal, Create_Pattern1,
             Create_Pattern2, Get_Template1, Get_Template2,
             Set_Bindings1, Set_Bindings2, Get_Bindings1,
             Get_Bindings2, Instantiate1, Instantiate2,
             First1, First2, Rest1, Rest2, Match, Help,
             Tag_Variables1, Tag_Variables2, Free1, Free2, Quit);

      package FIO is new TIO.Enumeration_Io (Functions);

      Function_Name : Functions;
      S_Expr_Result : SE.S_Expr;
      Pattern1, Pattern2, Pattern_Result : PAT.Pattern;
      Prompt : constant String := " -> ";
      Spacer : constant String := "    ";
      Boolean_Result : Boolean;
      Tag_Value : Natural;

   begin
      TIO.New_Line;
      TIO.Put_Line(" Entering the Pattern Demonstration.");
      TIO.Put_Line(" To terminate this demonstration, enter ""quit"" at any time.");
      TIO.Put_line(" For a list of available operations, enter ""help"".");
      TIO.New_Line;

      PAT.Bind (Pattern1, PAT.Null_Pattern);
      PAT.Bind (Pattern2, PAT.Null_Pattern);
      PAT.Bind (Pattern_Result, PAT.Null_Pattern);
      SE.Bind (S_Expr_Result, SE.Null_S_Expr);

      loop
     TIO.New_Line;
     TIO.Put (Prompt);

     begin
        FIO.Get (Function_Name);

        case Function_Name is

           when Is_Null1 =>
          Boolean_Result := PAT.Is_Null (Pattern1);
          TIO.New_Line;
          TIO.Put (Spacer);
          BIO.Put (Boolean_Result);

           when Is_Null2 =>
          Boolean_Result := PAT.Is_Null (Pattern2);
          TIO.New_Line;
          TIO.Put (Spacer);
          BIO.Put (Boolean_Result);

           when Is_Equal =>
          Boolean_Result := PAT.Is_Equal (Pattern1, Pattern2);
          TIO.New_Line;
          TIO.Put (Spacer);
          BIO.Put (Boolean_Result);


           when Create_Pattern1 =>
          PAT.Get (Pattern1);
          TIO.New_Line;
          TIO.Put (Spacer);
          PAT.Put (Pattern1);

           when Create_Pattern2 =>
          PAT.Get (Pattern2);
          TIO.New_Line;
          TIO.Put (Spacer);
          PAT.Put (Pattern2);

           when Get_Template1 =>
          SE.Bind (S_Expr_Result, PAT.Get_Template (Pattern1));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (S_Expr_Result);

           when Get_Template2 =>
          SE.Bind (S_Expr_Result, PAT.Get_Template (Pattern2));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (S_Expr_Result);

           when Set_Bindings1 =>
          SE.Get (S_Expr_Result);
          PAT.Bind (Pattern1,
                PAT.Set_Bindings (Pattern1, S_Expr_Result));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Bind (S_Expr_Result, PAT.Get_Bindings (Pattern1));
          SE.Put (S_Expr_Result);

           when Set_Bindings2 =>
          SE.Get (S_Expr_Result);
          PAT.Bind (Pattern2,
                PAT.Set_Bindings (Pattern2, S_Expr_Result));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Bind (S_Expr_Result, PAT.Get_Bindings (Pattern2));
          SE.Put (S_Expr_Result);

           when Get_Bindings1 =>
          SE.Bind (S_Expr_Result, PAT.Get_Bindings (Pattern1));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (S_Expr_Result);

           when Get_Bindings2 =>
          SE.Bind (S_Expr_Result, PAT.Get_Bindings (Pattern2));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (S_Expr_Result);

           when Instantiate1 =>
          SE.Bind (S_Expr_Result, PAT.Instantiate (Pattern1));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (S_Expr_Result);

           when Instantiate2 =>
          SE.Bind (S_Expr_Result, PAT.Instantiate (Pattern2));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (S_Expr_Result);

           when First1 =>
          PAT.Bind (Pattern_Result, PAT.First (Pattern1));
          TIO.New_Line;
          TIO.Put (Spacer);
          PAT.Put (Pattern_Result);

           when First2 =>
          PAT.Bind (Pattern_Result, PAT.First (Pattern2));
          TIO.New_Line;
          TIO.Put (Spacer);
          PAT.Put (Pattern_Result);

           when Rest1 =>
          PAT.Bind (Pattern_Result, PAT.Rest (Pattern1));
          TIO.New_Line;
          TIO.Put (Spacer);
          PAT.Put (Pattern_Result);

           when Rest2 =>
          PAT.Bind (Pattern_Result, PAT.Rest (Pattern2));
          TIO.New_Line;
          TIO.Put (Spacer);
          PAT.Put (Pattern_Result);

           when Match =>
          SE.Bind (S_Expr_Result, PAT.Get_Template (Pattern1));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Initial Template of Pattern1: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, PAT.Get_Bindings (Pattern1));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Initial Bindings of Pattern1: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, PAT.Get_Template (Pattern2));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Initial Template of Pattern2: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, PAT.Get_Bindings (Pattern2));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Initial Bindings of Pattern2: ");
          SE.Put (S_Expr_Result);
          PAT.Match (Pattern1, Pattern2, Boolean_Result);
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Result of Match: ");
          BIO.Put (Boolean_Result);
          SE.Bind (S_Expr_Result, PAT.Get_Template (Pattern1));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Final Template of Pattern1: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, PAT.Get_Bindings (Pattern1));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Final Bindings of Pattern1: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, PAT.Get_Template (Pattern2));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Final Template of Pattern2: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, PAT.Get_Bindings (Pattern2));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Final Bindings of Pattern2: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, PAT.Instantiate (Pattern1));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Instantiation of Pattern1: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, PAT.Instantiate (Pattern2));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Instantiation of Pattern2: ");
          SE.Put (S_Expr_Result);

           when Tag_Variables1 =>
          ITIO.Get (Tag_Value);
          PAT.Tag_Variables (Pattern1, Tag_Value);
          SE.Bind (S_Expr_Result, PAT.Get_Template (Pattern1));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Template of Pattern1: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, PAT.Get_Bindings (Pattern1));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Bindings of Pattern1: ");
          SE.Put (S_Expr_Result);

           when Tag_Variables2 =>
          ITIO.Get (Tag_Value);
          PAT.Tag_Variables (Pattern2, Tag_Value);
          SE.Bind (S_Expr_Result, PAT.Get_Template (Pattern2));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Template of Pattern2: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, PAT.Get_Bindings (Pattern2));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Bindings of Pattern2: ");
          SE.Put (S_Expr_Result);

           when Free1 =>
          PAT.Free (Pattern1);
          TIO.New_Line;
          TIO.Put (Spacer);
          PAT.Put (Pattern1);

           when Free2 =>
          PAT.Free (Pattern2);
          TIO.New_Line;
          TIO.Put (Spacer);
          PAT.Put (Pattern2);

           when Help =>
          TIO.New_Line;
          TIO.New_Line;
          TIO.Put_Line (" Available Operations:");
          TIO.New_Line;
          TIO.Put_Line ("    Create_Pattern1  Free2          Help          Is_Null2  Set_Bindings1");
          TIO.Put_Line ("    Create_Pattern2  Get_Bindings1  Instantiate1  Match     Set_Bindings2");
          TIO.Put_Line ("    First1           Get_Bindings2  Instantiate2  Quit      Tag_Variables1");
          TIO.Put_Line ("    First2           Get_Template1  Is_Equal      Rest1     Tag_Variables2");
          TIO.Put_Line ("    Free1            Get_Template2  Is_Null1      Rest2");
          TIO.New_Line;
          TIO.Put_Line (" For more specific information, see the User's Manual.");

           when Quit =>
          TIO.Skip_Line;
          TIO.Put_Line (" Exiting Pattern Demonstration.");
          return;

           when Others =>
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Not accessible.");
        end case;


        exception
           when TIO.Data_Error =>
          TIO.Put (Spacer);
          TIO.Put ("Incorrect function name, try again.");
           when PAT.Atomic_Template =>
          TIO.Put (Spacer);
          TIO.Put ("Input must be non-atomic, try again.");
           when SE.Improper_Input =>
          TIO.Put (Spacer);
          TIO.Put ("Input error, try again.");
           when SE.Atomic_Expression =>
          TIO.Put (Spacer);
          TIO.Put ("Input must be non-atomic, try again.");
           when SE.Non_Atomic_Expression =>
          TIO.Put (Spacer);
          TIO.Put ("Input must be atomic, try again.");
           when SE.Invalid_Position =>
          TIO.Put (Spacer);
          TIO.Put ("No value at that position, try again.");
           when SE.Missing_Separator =>
          TIO.Put (Spacer);
          TIO.Put ("Input is missing a separator, try again.");
           when SE.Extra_Separator =>
          TIO.Put (Spacer);
          TIO.Put ("Input has an extra separator, try again.");
           when SE.Invalid_Repetitions =>
          TIO.Put (Spacer);
          TIO.Put ("Invalid number of repetitions, try again.");
     end;

     TIO.Skip_Line;
     SE.Free (S_Expr_Result);
      end loop;

   end Patdemo;

   procedure Ruledemo is

      type Functions is (Is_Null1, Is_Null2, Is_Equal, Create_Rule1,
             Create_Rule2, Get_Template1, Get_Template2,
             Set_Bindings1, Set_Bindings2, Get_Bindings1,
             Get_Bindings2, Instantiate1, Instantiate2,
             Antecedent1, Antecedent2, Consequent1, Consequent2,
             Match, Is_Fact1, Is_Fact2, Is_Query1, Is_Query2,
             Is_Rule1, Is_Rule2, Tag_Variables1, Tag_Variables2,
             Free1, Free2, Help, Quit);

      package FIO is new Text_Io.Enumeration_Io(Functions);

      Function_Name : Functions;
      S_Expr_Result : SE.S_Expr;
      Pattern_Result : PAT.Pattern;
      Rule1, Rule2 : RUL.Rule;
      Prompt : constant String := " -> ";
      Spacer : constant String := "    ";
      Boolean_Result : Boolean;
      Tag_Value : Natural;

   begin
      TIO.New_Line;
      TIO.Put_line(" Entering the Rule Demonstration.");
      TIO.Put_line(" To terminate this demonstration, enter ""quit"" at any time.");
      TIO.Put_line(" For a list of available operations, enter ""help"".");
      TIO.New_Line;

      RUL.Bind (Rule1, RUL.Null_Rule);
      RUL.Bind (Rule1, RUL.Null_Rule);
      PAT.Bind (Pattern_Result, PAT.Null_Pattern);
      SE.Bind (S_Expr_Result, SE.Null_S_Expr);

      loop
     TIO.New_Line;
     TIO.Put (Prompt);

     begin
        FIO.Get (Function_Name);

        case Function_Name is

           when Is_Null1 =>
          Boolean_Result := RUL.Is_Null (Rule1);
          TIO.New_Line;
          TIO.Put (Spacer);
          BIO.Put (Boolean_Result);

           when Is_Null2 =>
          Boolean_Result := RUL.Is_Null (Rule2);
          TIO.New_Line;
          TIO.Put (Spacer);
          BIO.Put (Boolean_Result);

           when Is_Fact1 =>
          Boolean_Result := RUL.Is_Fact (Rule1);
          TIO.New_Line;
          TIO.Put (Spacer);
          BIO.Put (Boolean_Result);

           when Is_Fact2 =>
          Boolean_Result := RUL.Is_Fact (Rule2);
          TIO.New_Line;
          TIO.Put (Spacer);
          BIO.Put (Boolean_Result);

           when Is_Query1 =>
          Boolean_Result := RUL.Is_Query (Rule1);
          TIO.New_Line;
          TIO.Put (Spacer);
          BIO.Put (Boolean_Result);

           when Is_Query2 =>
          Boolean_Result := RUL.Is_Query (Rule2);
          TIO.New_Line;
          TIO.Put (Spacer);
          BIO.Put (Boolean_Result);

           when Is_Rule1 =>
          Boolean_Result := RUL.Is_Rule (Rule1);
          TIO.New_Line;
          TIO.Put (Spacer);
          BIO.Put (Boolean_Result);

           when Is_Rule2 =>
          Boolean_Result := RUL.Is_Rule (Rule2);
          TIO.New_Line;
          TIO.Put (Spacer);
          BIO.Put (Boolean_Result);

           when Is_Equal =>
          Boolean_Result := RUL.Is_Equal (Rule1, Rule2);
          TIO.New_Line;
          TIO.Put (Spacer);
          BIO.Put (Boolean_Result);

           when Create_Rule1 =>
          RUL.Get (Rule1);
          TIO.New_Line;
          TIO.Put (Spacer);
          RUL.Put (Rule1);

           when Create_Rule2 =>
          RUL.Get (Rule2);
          TIO.New_Line;
          TIO.Put (Spacer);
          RUL.Put (Rule2);

           when Get_Template1 =>
          SE.Bind (S_Expr_Result, RUL.Get_Template (Rule1));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (S_Expr_Result);

           when Get_Template2 =>
          SE.Bind (S_Expr_Result, RUL.Get_Template (Rule2));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (S_Expr_Result);

           when Set_Bindings1 =>
          SE.Get (S_Expr_Result);
          RUL.Bind (Rule1,
                RUL.Set_Bindings (Rule1, S_Expr_Result));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Bind (S_Expr_Result, RUL.Get_Bindings (Rule1));
          SE.Put (S_Expr_Result);

           when Set_Bindings2 =>
          SE.Get (S_Expr_Result);
          RUL.Bind (Rule2,
                RUL.Set_Bindings (Rule2, S_Expr_Result));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Bind (S_Expr_Result, RUL.Get_Bindings (Rule2));
          SE.Put (S_Expr_Result);

           when Get_Bindings1 =>
          SE.Bind (S_Expr_Result, RUL.Get_Bindings (Rule1));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (S_Expr_Result);

           when Get_Bindings2 =>
          SE.Bind (S_Expr_Result, RUL.Get_Bindings (Rule2));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (S_Expr_Result);

           when Instantiate1 =>
          SE.Bind (S_Expr_Result, RUL.Instantiate (Rule1));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (S_Expr_Result);

           when Instantiate2 =>
          SE.Bind (S_Expr_Result, RUL.Instantiate (Rule2));
          TIO.New_Line;
          TIO.Put (Spacer);
          SE.Put (S_Expr_Result);

           when Antecedent1 =>
          PAT.Bind (Pattern_Result, RUL.Antecedent (Rule1));
          TIO.New_Line;
          TIO.Put (Spacer);
          PAT.Put (Pattern_Result);

           when Antecedent2 =>
          PAT.Bind (Pattern_Result, RUL.Antecedent (Rule2));
          TIO.New_Line;
          TIO.Put (Spacer);
          PAT.Put (Pattern_Result);

           when Consequent1 =>
          PAT.Bind (Pattern_Result, RUL.Consequent (Rule1));
          TIO.New_Line;
          TIO.Put (Spacer);
          PAT.Put (Pattern_Result);

           when Consequent2 =>
          PAT.Bind (Pattern_Result, RUL.Consequent (Rule2));
          TIO.New_Line;
          TIO.Put (Spacer);
          PAT.Put (Pattern_Result);

           when Match =>
          SE.Bind (S_Expr_Result, RUL.Get_Template (Rule1));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Initial Template of Rule1: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, RUL.Get_Bindings (Rule1));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Initial Bindings of Rule1: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, RUL.Get_Template (Rule2));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Initial Template of Rule2: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, RUL.Get_Bindings (Rule2));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Initial Bindings of Rule2: ");
          SE.Put (S_Expr_Result);
          RUL.Match (Rule1, Rule2, Boolean_Result);
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Result of Match: ");
          BIO.Put (Boolean_Result);
          SE.Bind (S_Expr_Result, RUL.Get_Template (Rule1));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Final Template of Rule1: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, RUL.Get_Bindings (Rule1));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Final Bindings of Rule1: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, RUL.Get_Template (Rule2));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Final Template of Rule2: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, RUL.Get_Bindings (Rule2));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Final Bindings of Rule2: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, RUL.Instantiate (Rule1));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Instantiation of Rule1: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, RUL.Instantiate (Rule2));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Instantiation of Rule2: ");
          SE.Put (S_Expr_Result);

           when Tag_Variables1 =>
          ITIO.Get (Tag_Value);
          RUL.Tag_Variables (Rule1, Tag_Value);
          SE.Bind (S_Expr_Result, RUL.Get_Template (Rule1));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Template of Rule1: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, RUL.Get_Bindings (Rule1));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Bindings of Rule1: ");
          SE.Put (S_Expr_Result);

           when Tag_Variables2 =>
          ITIO.Get (Tag_Value);
          RUL.Tag_Variables (Rule2, Tag_Value);
          SE.Bind (S_Expr_Result, RUL.Get_Template (Rule2));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Template of Rule2: ");
          SE.Put (S_Expr_Result);
          SE.Bind (S_Expr_Result, RUL.Get_Bindings (Rule2));
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Bindings of Rule2: ");
          SE.Put (S_Expr_Result);

           when Free1 =>
          RUL.Free (Rule1);
          TIO.New_Line;
          TIO.Put (Spacer);
          RUL.Put (Rule1);

           when Free2 =>
          RUL.Free (Rule2);
          TIO.New_Line;
          TIO.Put (Spacer);
          RUL.Put (Rule2);

           when Help =>
          TIO.New_Line;
          TIO.New_Line;
          TIO.Put_Line (" Available Operations:");
          TIO.New_Line;
          TIO.Put_Line ("    Antecedent1   Free1          Help          Is_Null1   Match");
          TIO.Put_Line ("    Antecedent2   Free2          Instantiate1  Is_Null2   Quit");
          TIO.Put_Line ("    Consequent1   Get_Bindings1  Instantiate2  Is_Query1  Set_Bindings1");
          TIO.Put_Line ("    Consequent2   Get_Bindings2  Is_Equal      Is_Query2  Set_Bindings2");
          TIO.Put_Line ("    Create_Rule1  Get_Template1  Is_Fact1      Is_Rule1   Tag_Variables1");
          TIO.Put_Line ("    Create_Rule2  Get_Template2  Is_Fact2      Is_Rule2   Tag_Variables2");
          TIO.New_Line;
          TIO.Put_Line (" For more specific information, see the User's Manual.");

           when Quit =>
          TIO.Skip_Line;
          TIO.Put_Line (" Exiting Rule Demonstration.");
          return;

           when Others =>
          TIO.New_Line;
          TIO.Put (Spacer);
          TIO.Put ("Not accessible.");
        end case;


        exception
           when TIO.Data_Error =>
          TIO.Put (Spacer);
          TIO.Put ("Incorrect function name, try again.");
           when RUL.Invalid_Rule_Format =>
          TIO.Put (Spacer);
          TIO.Put ("Improper rule format, try again.");
           when RUL.Atomic_Template =>
          TIO.Put (Spacer);
          TIO.Put ("Input must be non-atomic, try again.");
           when SE.Improper_Input =>
          TIO.Put (Spacer);
          TIO.Put ("Input error, try again.");
           when SE.Atomic_Expression =>
          TIO.Put (Spacer);
          TIO.Put ("Input must be non-atomic, try again.");
           when SE.Non_Atomic_Expression =>
          TIO.Put (Spacer);
          TIO.Put ("Input must be atomic, try again.");
           when SE.Invalid_Position =>
          TIO.Put (Spacer);
          TIO.Put ("No value at that position, try again.");
           when SE.Missing_Separator =>
          TIO.Put (Spacer);
          TIO.Put ("Input is missing a separator, try again.");
           when SE.Extra_Separator =>
          TIO.Put (Spacer);
          TIO.Put ("Input has an extra separator, try again.");

--   The following exception handler is commented out because it appears
--   that DEC Ada allows a maximum of only nine exception handlers per frame.
--
--           when SE.Invalid_Repetitions =>
--          TIO.Put (Spacer);
--          TIO.Put ("Invalid number of repetitions, try again.");
     end;

     TIO.Skip_Line;
     SE.Free (S_Expr_Result);
     PAT.Free (Pattern_Result);
      end loop;

   end Ruledemo;

   procedure Rbdemo is
      use Inst_Facilities;  -- Use clause needed because values of an
                -- enumerated type (Literal_Kind) declared
                -- outside of a compilation unit are not
                -- being recognized.  Is this standard behavior?

      type Functions is (Create_Rulebase1, Create_Rulebase2,
             Assert1, Assert2, Retract1, Retract2,
             Get_Template1, Get_Template2, Free1, Free2,
             Is_Null1, Is_Null2, Retrieve1, Retrieve2, Help,
             Is_Equal, Rb_And, Rb_Or, Rb_Differ, Rb_Xor, Quit);

      package FIO is new TIO.Enumeration_Io (Functions);

      type Rb_Index is (loves, friends, wife, husband, father, mother, parent);

      Invalid_Index : exception;

      function Rb_Key (Rule_Arg : in RUL.Rule) return Rb_Index is
     Literal_Val : Inst_Facilities.Atomic_Literal;
      begin
     Literal_Val := SE.Return_Atomic_Literal (
               SE.First (
                  PAT.Instantiate (RUL.Consequent (Rule_Arg))));
     case Literal_Val.Kind is
        when Int => raise Invalid_Index;
        when Length1  => return Rb_Index'Value (Literal_Val.Length1);
        when Length2  => return Rb_Index'Value (Literal_Val.Length2);
        when Length3  => return Rb_Index'Value (Literal_Val.Length3);
        when Length4  => return Rb_Index'Value (Literal_Val.Length4);
        when Length5  => return Rb_Index'Value (Literal_Val.Length5);
        when Length6  => return Rb_Index'Value (Literal_Val.Length6);
        when Length7  => return Rb_Index'Value (Literal_Val.Length7);
        when Length8  => return Rb_Index'Value (Literal_Val.Length8);
        when Length9  => return Rb_Index'Value (Literal_Val.Length9);
        when Length10 => return Rb_Index'Value (Literal_Val.Length10);
        when Length11 => return Rb_Index'Value (Literal_Val.Length11);
        when Length12 => return Rb_Index'Value (Literal_Val.Length12);
        when Length13 => return Rb_Index'Value (Literal_Val.Length13);
        when Length14 => return Rb_Index'Value (Literal_Val.Length14);
        when Length15 => return Rb_Index'Value (Literal_Val.Length15);
     end case;

     exception
        when Constraint_Error => raise Invalid_Index;
      end Rb_Key;

      package RB is new Inst_Facilities.AI_Types.Rulebases (Rb_Index, Rb_Key);

      procedure Print (Print_Arg : in SE.S_Expr) is
     S_Expr_Arg : SE.S_Expr;
      begin
     SE.Bind (S_Expr_Arg, Print_Arg);
     TIO.Put ("(");
     while not SE.Is_Null (S_Expr_Arg) loop
        SE.Put (SE.First (S_Expr_Arg));
        SE.Bind (S_Expr_Arg, SE.Rest (S_Expr_Arg));
        if not SE.Is_Null (S_Expr_Arg) then
           TIO.New_Line;
           TIO.Put ("     ");
        end if;
     end loop;
     TIO.Put (")");
      end Print;
   begin
      declare
     Function_Name : Functions;
     S_Expr_Result : SE.S_Expr;
     Rule_Arg : RUL.Rule;
     Rulebase1, Rulebase2, Rulebase_Result : RB.Rulebase;
     Prompt : constant String := " -> ";
     Spacer : constant String := "    ";
     Boolean_Result : Boolean;
      begin
     TIO.New_Line;
     TIO.Put_line(" Entering the Rulebase Demonstration.");
     TIO.Put_line(" To terminate this demonstration, enter ""quit"" at any time.");
     TIO.Put_line(" For a list of available operations, enter ""help"".");
     TIO.New_Line;

     RB.Bind (Rulebase1, RB.Null_Rulebase);
     SE.Bind (S_Expr_Result, SE.Null_S_Expr);
     RUL.Bind (Rule_Arg, RUL.Null_Rule);

     loop
        TIO.New_Line;
        TIO.Put (Prompt);

        begin
           FIO.Get (Function_Name);

           case Function_Name is

          when Create_Rulebase1 =>
             RB.Get (Rulebase1);
             SE.Bind (S_Expr_Result, RB.Get_Template (Rulebase1));
             TIO.New_Line;
             TIO.Put (Spacer);
             Print (S_Expr_Result);

          when Create_Rulebase2 =>
             RB.Get (Rulebase2);
             SE.Bind (S_Expr_Result, RB.Get_Template (Rulebase2));
             TIO.New_Line;
             TIO.Put (Spacer);
             Print (S_Expr_Result);

          when Assert1 =>
             RUL.Get (Rule_Arg);
             RB.Assert (Rule_Arg, Rulebase1);
             SE.Bind (S_Expr_Result, RB.Get_Template (Rulebase1));
             TIO.New_Line;
             TIO.Put (Spacer);
             Print (S_Expr_Result);

          when Assert2 =>
             RUL.Get (Rule_Arg);
             RB.Assert (Rule_Arg, Rulebase2);
             SE.Bind (S_Expr_Result, RB.Get_Template (Rulebase2));
             TIO.New_Line;
             TIO.Put (Spacer);
             Print (S_Expr_Result);

          when Retract1 =>
             RUL.Get (Rule_Arg);
             RB.Retract (Rule_Arg, Rulebase1);
             SE.Bind (S_Expr_Result, RB.Get_Template (Rulebase1));
             TIO.New_Line;
             TIO.Put (Spacer);
             Print (S_Expr_Result);

          when Retract2 =>
             RUL.Get (Rule_Arg);
             RB.Retract (Rule_Arg, Rulebase2);
             SE.Bind (S_Expr_Result, RB.Get_Template (Rulebase2));
             TIO.New_Line;
             TIO.Put (Spacer);
             Print (S_Expr_Result);

          when Get_Template1 =>
             TIO.New_Line;
             TIO.Put (Spacer);
             SE.Bind (S_Expr_Result, RB.Get_Template (Rulebase1));
             Print (S_Expr_Result);

          when Get_Template2 =>
             TIO.New_Line;
             TIO.Put (Spacer);
             SE.Bind (S_Expr_Result, RB.Get_Template (Rulebase2));
             Print (S_Expr_Result);

          when Free1 =>
             RB.Free (Rulebase1);
             TIO.New_Line;
             TIO.Put (Spacer);
             SE.Bind (S_Expr_Result, RB.Get_Template (Rulebase1));
             Print (S_Expr_Result);

          when Free2 =>
             RB.Free (Rulebase2);
             TIO.New_Line;
             TIO.Put (Spacer);
             SE.Bind (S_Expr_Result, RB.Get_Template (Rulebase2));
             Print (S_Expr_Result);

          when Is_Null1 =>
             Boolean_Result := RB.Is_Null (Rulebase1);
             TIO.New_Line;
             TIO.Put (Spacer);
             BIO.Put (Boolean_Result);

          when Is_Null2 =>
             Boolean_Result := RB.Is_Null (Rulebase2);
             TIO.New_Line;
             TIO.Put (Spacer);
             BIO.Put (Boolean_Result);

          when Retrieve1 =>
             RUL.Get (Rule_Arg);
             RUL.Tag_Variables (Rule_Arg, 42);
             SE.Bind (S_Expr_Result, RB.Retrieve (Rule_Arg, Rulebase1));
             TIO.New_Line;
             TIO.Put (Spacer);
             Print (S_Expr_Result);

          when Retrieve2 =>
             RUL.Get (Rule_Arg);
             RUL.Tag_Variables (Rule_Arg, 42);
             SE.Bind (S_Expr_Result, RB.Retrieve (Rule_Arg, Rulebase2));
             TIO.New_Line;
             TIO.Put (Spacer);
             Print (S_Expr_Result);

          when Is_Equal =>
             Boolean_Result := RB.Is_Equal (Rulebase1, Rulebase2);
             TIO.New_Line;
             TIO.Put (Spacer);
             BIO.Put (Boolean_Result);

          when Rb_And =>
             RB.Bind (Rulebase_Result, RB."And" (Rulebase1, Rulebase2));
             TIO.New_Line;
             TIO.Put (Spacer);
             SE.Bind (S_Expr_Result, RB.Get_Template (Rulebase_Result));
             Print (S_Expr_Result);

          when Rb_Or =>
             RB.Bind (Rulebase_Result, RB."Or" (Rulebase1, Rulebase2));
             TIO.New_Line;
             TIO.Put (Spacer);
             SE.Bind (S_Expr_Result, RB.Get_Template (Rulebase_Result));
             Print (S_Expr_Result);

          when Rb_Differ =>
             RB.Bind (Rulebase_Result, RB."-" (Rulebase1, Rulebase2));
             TIO.New_Line;
             TIO.Put (Spacer);
             SE.Bind (S_Expr_Result, RB.Get_Template (Rulebase_Result));
             Print (S_Expr_Result);

          when Rb_Xor =>
             RB.Bind (Rulebase_Result, RB."Xor" (Rulebase1, Rulebase2));
             TIO.New_Line;
             TIO.Put (Spacer);
             SE.Bind (S_Expr_Result, RB.Get_Template (Rulebase_Result));
             Print (S_Expr_Result);

          when Help =>
             TIO.New_Line;
             TIO.New_Line;
             TIO.Put_Line (" Available Operations:");
             TIO.New_Line;
             TIO.Put_Line ("    Assert1            Get_Template1   Quit       Retract2");
             TIO.Put_Line ("    Assert2            Get_Template2   Rb_And     Retrieve1");
             TIO.Put_Line ("    Create_Rulebase1   Help            Rb_Differ  Retrieve2");
             TIO.Put_Line ("    Create_Rulebase2   Is_Equal        Rb_Or");
             TIO.Put_Line ("    Free1              Is_Null1        Rb_Xor");
             TIO.Put_Line ("    Free2              Is_Null2        Retract1");
             TIO.New_Line;
             TIO.Put_Line (" For more specific information, see the User's Manual.");

          when Quit =>
             TIO.Skip_Line;
             TIO.Put_Line (" Exiting Rulebase Demonstration.");
             return;

          when Others =>
             TIO.New_Line;
             TIO.Put (Spacer);
             TIO.Put ("Not accessible.");
           end case;


           exception
          when TIO.Data_Error =>
             TIO.Put (Spacer);
             TIO.Put ("Incorrect function name, try again.");
          when RUL.Atomic_Template =>
             TIO.Put (Spacer);
             TIO.Put ("Input must be non-atomic, try again.");
          when RUL.Invalid_Rule_Format =>
             TIO.Put (Spacer);
             TIO.Put ("Improper rule format, try again.");
          when Invalid_Index =>
             TIO.Put (Spacer);
             TIO.Put ("Improper relation, try again.");
          when SE.Improper_Input =>
             TIO.Put (Spacer);
             TIO.Put ("Input error, try again.");
          when SE.Atomic_Expression =>
             TIO.Put (Spacer);
             TIO.Put ("Input must be non-atomic, try again.");
          when SE.Non_Atomic_Expression =>
             TIO.Put (Spacer);
             TIO.Put ("Input must be atomic, try again.");
          when SE.Missing_Separator =>
             TIO.Put (Spacer);
             TIO.Put ("Input is missing a separator, try again.");
          when SE.Extra_Separator =>
             TIO.Put (Spacer);
             TIO.Put ("Input has an extra separator, try again.");

--   The following exception handlers are commented out because it appears
--   that DEC Ada allows a maximum of only nine exception handlers per frame.
--
--          when SE.Invalid_Position =>
--             TIO.Put (Spacer);
--             TIO.Put ("No value at that position, try again.");
--          when SE.Invalid_Repetitions =>
--             TIO.Put (Spacer);
--             TIO.Put ("Invalid number of repetitions, try again.");

        end;

        TIO.Skip_Line;
        SE.Free (S_Expr_Result);
        RUL.Free (Rule_Arg);
        RB.Free (Rulebase_Result);
     end loop;
      end;
   end Rbdemo;

begin
   TIO.New_Line;
   TIO.Put_Line (" Welcome to the AI Data Types Demonstration.");
   TIO.Put_Line (" To terminate this demonstration, enter ""quit"" at any time.");
   TIO.New_Line;

   loop
      loop
     begin
        TIO.Put_Line (" Choose number of desired demonstration: ");
        TIO.New_Line;
        TIO.Put_Line ("    1. Symbolic_Expression");
        TIO.Put_Line ("    2. Pattern");
        TIO.Put_Line ("    3. Rule");
        TIO.Put_Line ("    4. Rulebase");
        TIO.New_Line;
        TIO.Put (" >> ");
        TIO.Get_Line (Response, Stringlength);
        if Stringlength = 0 then
           TIO.New_Line;
        elsif Response (1 .. Stringlength) = "quit" then
           TIO.New_Line;
           TIO.Put_Line (" Exiting AI Data Types Demonstration.");
           return;
        else
           case Integer'Value (Response (1 .. Stringlength)) is
          when 1 =>
             TIO.New_Line;
             Sexprdemo;
             TIO.New_Line;
             exit;
          when 2 =>
             TIO.New_Line;
             Patdemo;
             TIO.New_Line;
             exit;
          when 3 =>
             TIO.New_Line;
             Ruledemo;
             TIO.New_Line;
             exit;
          when 4 =>
             TIO.New_Line;
             Rbdemo;
             TIO.New_Line;
             exit;
          when others =>
             TIO.New_Line;
             TIO.Put_Line (" Demonstration number must be 1, 2, 3 or 4, try again.");
             TIO.New_Line;
           end case;
        end if;

        exception
           when Constraint_Error =>
          TIO.New_Line;
          TIO.Put_Line (" Demonstration number must be 1, 2, 3 or 4, try again.");
              TIO.New_Line;
         end;
      end loop;

      loop
     TIO.New_Line;
     TIO.Put_Line (" Would you like to try another demonstration? (y/n)");
     TIO.Put (" >> ");
     TIO.Get_Line (Response, Stringlength);
     if Stringlength = 0 then
        TIO.New_Line;
     elsif Response (1 .. Stringlength) = "y" then
        TIO.New_Line;
        TIO.New_Line;
        exit;
     elsif Response (1 .. Stringlength) = "n" then
        TIO.New_Line;
        TIO.Put_Line (" Exiting AI Data Types Demonstration.");
        return;
     elsif Response (1 .. Stringlength) = "quit" then
        TIO.New_Line;
        TIO.Put_Line (" Exiting AI Data Types Demonstration.");
        return;
     else
        TIO.New_Line;
        TIO.Put_Line (" Response must be ""y"" or ""n"", try again.");
     end if;
      end loop;
   end loop;

end AITypesdemo;