;;; 10/5/2011 renamed from MATCH, which is reserved by Lispworks
;;;   -- http://www.lispworks.com/kb/84cddb761a7232e0802571c400553ff1.html

(defpackage :matcher
  (:use :common-lisp)
  (:export :match))

(in-package :matcher)

(defvar *match-extensions* (make-hash-table :test 'equal))

(defun get-extension (x)
  (gethash (symbol-name x) *match-extensions*))

(defun set-extension (x fn)
  (setf (gethash (symbol-name x) *match-extensions*) fn))

(defun match-extension-p (x)
  (and (consp x)
       (symbolp (car x))
       (not (null (get-extension (car x))))))

(defun match-extension (x y lsts)
  (funcall (get-extension (car x)) x y lsts))


(defun match (x y &optional (lsts (list nil)))
  (cond ((null lsts) nil)
        ((var-p x) (match-var x y lsts))
        ((eql x y) lsts)
        ((atom x) nil)
        ((match-extension-p x) (match-extension x y lsts))
        ((name= (car x) '?*) (match* x y lsts))
        ((atom y) nil)
        (t
         (match (cdr x) (cdr y)
                (match (car x) (car y) lsts)))))

(defun match* (x y lsts)
  (append (match (cdr x) y lsts)
          (and (consp y) (match x (cdr y) lsts))))

(defun match-var (x y lsts)
  (if (name= x '?) lsts
    (loop for lst in lsts append (bind-var x y lst))))

(defun bind-var (x y lst)
  (let ((entry (assoc x lst)))
    (cond ((null entry) (list (cons (list x y) lst)))
          ((eql (cadr entry) y) (list lst))
          (t nil))))

(defun name= (sym1 sym2)
  (and (symbolp sym1)
       (symbolp sym2)
       (string= (symbol-name sym1) (symbol-name sym2))))

(defun var-p (sym)
  (and (symbolp sym)
       (eql (char (symbol-name sym) 0) #\?)
       (not (name= sym '?*))))


;;; Extensions

(set-extension '?is 'match-is)

(defun match-is (x y lsts)
  (if (apply (cadr x) y (cddr x)) lsts nil))

(set-extension '?and 'match-and)

(defun match-and (x y lsts)
  (match-and-patterns (cdr x) y lsts))

(defun match-and-patterns (pats y lsts)
  (cond ((null lsts) nil)
        ((null pats) lsts)
        (t
         (match-and-patterns (cdr pats) y
                             (match (car pats) y lsts)))))

(set-extension '?not 'match-not)

(defun match-not (x y lsts)
  (if (match (cadr x) y lsts) nil lsts))

(set-extension '?or 'match-or)

(defun match-or (x y lsts)
  (match-or-patterns (cdr x) y lsts))

(defun match-or-patterns (pats y lsts)
  (cond ((null lsts) nil)
        ((null pats) nil)
        (t (append (match (car pats) y lsts)
                   (match-or-patterns (cdr pats) y lsts)))))