;;; MATCH -- a recursive pattern-matching function
;;; for use in production-systems programming.
;;; (c) Copyright 1994 by S. Tanimoto
;;; This appears in The Elements of Artificial Intelligence
;;; Using Common Lisp, 2nd Ed. W. H. Freeman, 41 Madison Ave.,
;;; New York, NY 10010.
;;; Permission is granted to use or modify this program
;;; provided that this copyright notice is retained and followed
;;; by a notice of any modifications made to the program.

;;; (MATCH P S) returns an association list of bindings
;;; e.g., ((X . 5) (Y A SEQUENCE OF ELTS) (YES . YES)),
;;; that represents the pairings of variables of P with
;;; components of S that put P into correspondence with S.
;;; The substitution list always ends with (YES . YES)
;;; which represents an empty substitution. The presence of this
;;; empty substitution indicates that the match was successful.
;;; If matching is unsuccessful, NIL is returned.

(defun match (p s)
  "Attempt to find a correspondence between P and S, utilizing
   any special constructs appearing in P.  Return an association
   list of bindings if successful; NIL otherwise."
  (cond
    ((handle-both-null p s))
    ((handle-normal-recursion p s))
    ((atom (first p)) nil)
    ((handle-? p s))
    ((handle-* p s))
    ((handle-restrict-pred p s))
    (t nil) ) )

(defun handle-both-null (p s)
  "Test for and handle case when both P and S are null."
  (if (and (null p)(null s))
      '((yes . yes)) ) )

(defun handle-normal-recursion (p s)
  "Test for and handle case when the first elements of
    P and S are EQL."
  (if (atom (first p))
      (if (eql (first p)(first s))
          (match (rest p)(rest s)) ) ) )

(defun handle-? (p s)
  "Test for and handle the case when (FIRST P) is of
   the form (? X)."
  (if s ; S must not be null
      (if (eq (first (first p)) '?)
          (let ((rest-match (match (rest p)(rest s))))
            (if rest-match
                (acons (first (rest (first p)))
                       (first s)
                       rest-match) ) ) ) ) )

(defun handle-* (p s)
  "Test for and handle the case when (FIRST P) is of
   the form (* X)."
  (if (eq (first (first p)) '*)
      (let ((pattern-variable (first (rest (first p))))
            rest-match)
        (cond ; subcase 1 --match one element of S:
              ((and s
                    (setf rest-match
                          (match (rest p)(rest s)) ) )
               (acons pattern-variable
                      (list (first s))
                      rest-match) )

              ; subcase 2 --match no elements of S:
              ((setf rest-match (match (rest p) s))
               (acons pattern-variable nil rest-match) )

              ; subcase 3 --match more than one element of S:
              ((and s
                    (setf rest-match
                          (match p (rest s)) ) )
               (acons pattern-variable
                      (cons (first s)
                            (val pattern-variable
                                 rest-match) )
                      (rest rest-match)) )
              (t nil) ) ) ) )

(defun handle-restrict-pred (p s)
  "Handle case when (FIRST P) is of the form (PREDICATE X)."
  (if s ; S must not be null
    (if (member (first (first p)) '(? *)) ; Don't apply '? or '*.
        nil
      (if (apply (caar p) (list (first s)))
          (let ((rest-match (match (rest p) (rest s)))
                (pattern-variable (first (rest (first p)))) )
            (if rest-match
                (acons pattern-variable
                       (first s)
                       rest-match) ) ) ) ) ) )

;;; The function VAL provides convenient access to
;;; something matched by a variable after matching with MATCH.
(defun val (variable alist)
  "Return the value associated with VARIABLE on ALIST."
  (rest (assoc variable alist)) )