;;;**************************************************

;;; Code for matching, variables, and binding lists. 

;;; There will be two calls:  

;;;

;;;     (MATCH input-expr macro-input) 

;;;         => binding list or :FAIL

;;;

;;; which will match an s-expression (with no 

;;; variables) to the input portion of a macrop 

;;; (which might contain variables).  Both are 

;;; S-expressions.  The function will either return 

;;; a list of bindings for the variables in 

;;; MACRO-INPUT (if any), or will return :FAIL if 

;;; the two expressions don't match.

;;;

;;; For example:   

;;;   (match '(pickup the-book the-arm) 

;;;          '(pickup ?x ?y)) 

;;;       => ((?x . the-book) (?y . the-arm))

;;;   (match '(pickup the-book the-arm) 

;;;          '(pickup ?x the-arm))

;;;       => ((?x . the-book))

;;;   (match '(pickup the-book the-arm) 

;;;          '(pickup the-book the-arm))

;;;       => ()     ;; No bindings, but succeeded

;;;   (match '(p A A) '(p ?x ?x))

;;;       => ((?x . A))

;;;   (match '(p A B) '(p ?x ?x))

;;;       => :FAIL

;;;   (match '(a x) '(b ?y))

;;;       => :FAIL

;;;   (match '(a x) '(a ?x ?y))

;;;       => :FAIL

;;;

;;;  The second function is 

;;;     (COPY-AND-INSTANTIATE sexp binding-list)

;;; where SEXP can contain variables, 

;;; and returns a copy of SEXP with variables 

;;;  bound according to BINDING-LIST.

;;;

;;;   (copy-and-instantiate 

;;;       '(pickup ?x ?y) 

;;;       '((?x . the-book) (?y . the-arm)))

;;;    => (pickup the-book the-arm)

;;;   (copy-and-instantiate 

;;;       '(p ?y ?z) 

;;;       '((?z . foo)))

;;;    => (p ?y foo)

;;;



;;;**********************************************

;;;  First data structures for variables and binding 

;;;  lists.  A variable is just a symbol whose name 

;;;  begins with a question mark (the character #\?)



(defun variable-p (thing)

  (and (symbolp thing) 

       (eq #\? (elt (string thing) 0))))



;;;*************************************************

;;;  A binding list is a list of bindings, and a 

;;;  binding is a cons-pair of the form 

;;;        (variable . constant), 

;;;  e.g. (?x . foo)



;;;  We need functions to make a new binding list, 

;;;  to retrieve the binding for a variable, and to 

;;;  add a binding to a binding list.



;;; Implement bindings as a cons pair

;;;      (?VAR . BINDING)



(defun binding-p (thing)

  (and (consp thing)

       (variable-p (car thing))))



(defun make-binding (var const)

  (cons var const))



(defun binding-var (binding)

  (car binding))



(defun binding-bdg (binding)

  (cdr binding))



;;;************************************

;;;  A binding list is just a list of bindings



(defun binding-list-p (thing)

  (and (listp thing)

       (every #'binding-p thing)))



(defun make-empty-binding-list ()

  '())



(defun get-binding (var binding-list)

  (binding-bdg (assoc var binding-list)))



(defun add-binding (binding binding-list)

  (cons binding binding-list))





;;;**********************************************

;;;  Now the code for matching.  The top-level call 

;;;  takes as input an input expression (no 

;;;  variables) and a macrop left-hand-side 

;;;  (possibly with variables).  It does some 

;;;  cursory checking (same names?  same length?) 

;;;  then calls a helper function to do the match.



(defun match (input-sexp macrop-input)

  (cond

   ((or (not (eq (car input-sexp) 

		 (car macrop-input)))

        (not (= (length input-sexp) 

		(length macrop-input))))

    :FAIL)

   (T (really-match input-sexp 

		    macrop-input 

		    (make-empty-binding-list)))))



;;;**************************************************

;;;  Recursive function for matching:

;;;    1.  check for empty list 

;;;          (termination condition; return the 

;;;          current binding list

;;;    2.  check to see if a previous recursion has 

;;;        failed, if so fail immediately

;;;    3.  try to match the CARs

;;;     -- if the second argument has a 

;;;        variable in the CAR then see if it 

;;;        already has a binding.  If so, that binding

;;;        must be identical to the CAR of the first 

;;;        input.  If not, fail.   If the variable

;;;        is not currently bound, create a new 

;;;        binding  between this variable and the 

;;;        first element of the first argument.

;;;     -- if the CAR of the second argument is  not 

;;;        a variable, then it must be identical 

;;;        to the CAR of the first input.  If not, 

;;;        fail. 

;;;    4.  If the match on the CARs succeeded, then 

;;;        recurse on the CDRs, passing through 

;;;        the new binding list.

;;;        



(defun really-match (input-sexp macrop-input blist)

  (cond

   ((null input-sexp) blist)

   ((eq blist :FAIL)  blist)

   ((variable-p (car macrop-input))

    (let ((current-binding 

	   (get-binding (car macrop-input) blist)))

      (cond

       ((null current-binding)

        (really-match 

	 (cdr input-sexp) 

	 (cdr macrop-input) 

	 (add-binding (make-binding (car macrop-input)

				    (car input-sexp))

		      blist)))

       ((equal current-binding (car input-sexp)) 

        (really-match (cdr input-sexp) 

		      (cdr macrop-input) blist))

       (T :FAIL))))

   ((equal (car macrop-input) (car input-sexp))

    (really-match (cdr input-sexp) 

		  (cdr macrop-input) blist))

   (T :FAIL)))





;;;**********************************************

;;;  Copy and instantiate is easy:  

;;;  iterate for each element in the 

;;;  input expression:  

;;;   -- if it's a constant, pass it through

;;;   -- if it's an unbound variable, pass it through

;;;   -- if it's a bound variable, pass through the 

;;;      variable binding.

;;;

;;;



(defun copy-and-instantiate (sexp bindings)

  (mapcar #'(lambda (elt) 

              (cond

               ((or (not (variable-p elt))

                    (null (get-binding elt bindings)))

                elt)

               (t (get-binding elt bindings))))

          sexp))