;;; MATCH.SS -- a recursive pattern-matching function
;;; for use in production-systems programming.

;;; (C) Copyright 1995 by Steven L. Tanimoto.
;;; This program is described in Chapter 3 ("Productions Systems
;;; and Pattern Matching") of
;;; "The Elements of Artificial Intelligence Using Common Lisp," 2nd ed.,
;;; published by W. H. Freeman, 41 Madison Ave., New York, NY 10010.
;;; Permission is granted for noncommercial use and modification of
;;; 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)
;;; that represents the pairings of variables of P with
;;; components of S that put P into correspondence with S.
;;; If matching is unsuccessful, #f is returned.

(define (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))
    ((null? p) #f)
    ((handle-normal-recursion p s))
    ((and (pair? p)(atom? (car p))) #f)
    ((handle-? p s))
    ((handle-* p s))
    ((handle-restrict-pred p s))
    (#t #f) ) )

(define (atom? s) (not (pair? s)))

(define (1st-pattern-op p)
  ; Return the *, ? or predicate in the first pattern
  ; construct of P.
  (car (car p)) ) ; same as (CAAR P)

(define (1st-pattern-variable p)
  ; Return the variable in the first pattern
  ; construct of P.
  (car (cdr (car p))) ) ; same as (CADAR P)

(define (handle-both-null p s)
  ; Test for and handle case when both P and S
  ; are null. If they are, return an empty binding list.
  ; Otherwise, false.
  (if (and (null? p)(null? s))
      ()
      #f ) )

(define (handle-normal-recursion p s)
  ; Test for and handle case when the first
  ;  elements of P and S are EQ?.
  (if (and (atom? (car p)) (pair? s))
      (if (eq? (car p)(car s))
          (match (cdr p)(cdr s))
          #f )
      #f ) )

(define (handle-? p s)
  ; Test for and handle the case when (CAR P) is of
  ; the form (? X).
  (if (not (null? s)) ; S must not be null
      (if (eq? (1st-pattern-op p) '?)
          (let ((rest-match
                  (match (cdr p)(cdr s)) ))
            (if rest-match
                (acons 
                  (1st-pattern-variable p)
                  (car s)
                  rest-match)
                #f ) )
          #f )
      #f ) )

;;; The macro REBIND both does an assignment and returns
;;; the value.
(define-syntax rebind
  (syntax-rules ()
    ((_ x y) (begin (set! x y) y)) ) )

(define (handle-* p s)
  ; Test for and handle the case when (FIRST P) is of
  ;  the form (* X).
  (if (eq? (1st-pattern-op p) '*)
      (let ((pattern-variable
              (1st-pattern-variable p) )
            (rest-match #f) )
        (cond ; subcase 1 --match 1 element of S:
              ((and (pair? s)
                    (rebind rest-match
                          (match (cdr p)
                                 (cdr s) ) ) )
               (acons pattern-variable
                      (list (car s))
                      rest-match) )

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

              ; subcase 3 --match more than 1 elt of S:
              ((and (pair? s)
                    (rebind rest-match
                          (match p (cdr s)) ) )
               (acons pattern-variable
                      (cons (car s)
                            (val pattern-variable
                                 rest-match) )
                      (cdr rest-match)) )
              (#t #f) ) ) #f ) )


(define (handle-restrict-pred p s)
  ; Handle case when (CAR P) is of the form
  ; (PREDICATE X).
  (if (pair? s) ; S must not be null
    (if (member (1st-pattern-op p)
                '(? *) ) ; Don't apply '? or '*.
      #f
      (if (apply (eval (1st-pattern-op p))
                 (list (car s)) )
          (let ((rest-match
                  (match (cdr p) (cdr s)) )
                (pattern-variable
                  (1st-pattern-variable p) ) )
            (if rest-match
                (acons pattern-variable
                       (car s)
                       rest-match)
                #f ) )
          #f ) ) #f ) )

(define (acons a b lst)
  (cons (cons a b) lst) )

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