;; Pattern matcher from Chapter 21 of Wilensky, "Common LISPcraft.

(set-macro-character #\?
  #'(lambda (stream char) (list '*var* (read stream t nil t))))

(defun match (pattern1 pattern2)
  (match-with-bindings pattern1 pattern2 nil))

(defun match-with-bindings (pattern1 pattern2 bindings)
  (cond ((pattern-var-p pattern1)
          (variable-match pattern1 pattern2 bindings))
        ((pattern-var-p pattern2)
          (variable-match pattern2 pattern1 bindings))
        ((atom pattern1)
          (if (eq pattern1 pattern2) (values t bindings)))
        ((atom pattern2) nil)
        ( t (multiple-value-bind
             (flag carbindings)
               (match-with-bindings (car pattern1) (car pattern2) bindings)
             (and flag
               (match-with-bindings (cdr pattern1) (cdr pattern2) carbindings)
         )))))

(defun variable-match (pattern-var item bindings)
  (if (equal pattern-var item) (values t bindings)
    (let ((var-binding (get-binding pattern-var bindings)))
         (cond (var-binding (match-with-bindings var-binding item bindings))
               ((not (contained-in pattern-var item bindings))
                 (values t (add-binding pattern-var item bindings)))))))

(defun contained-in (pattern-var item bindings)
  (cond ((atom item) nil)
        ((pattern-var-p item)
          (or (equal pattern-var item)
              (contained-in pattern-var
                  (get-binding item bindings) bindings)))
        (t (or (contained-in pattern-var (car item) bindings)
               (contained-in pattern-var (cdr item) bindings)))))

(defun add-binding (pattern-var item bindings)
  (cons (list pattern-var item) bindings))

(defun pattern-var-p (item)
  (and (listp item) (eq '*var* (car item))))

(defun get-binding (pattern-var bindings)
  (cadr (assoc pattern-var bindings :test #'equal)))

