;;;; Matching really is generalized equality.

#|
;;; Recursive Equality of s-expressions.
;;; Equal? is provided by all Lisp systems.

(define (equal? a b)
  (cond ((pair? a)
	 (if (pair? b)
	     (and (equal? (car a) (car b))
		  (equal? (cdr a) (cdr b)))
	     #f))
	((pair? b) #f)
	(else (eqv? a b))))


;;; Don't cares for partial match.

(define (match? a b)
  (cond ((variable? a) #t)
	((pair? a)
	 (if (pair? b)
	     (and (match? (car a) (car b))
		  (match? (cdr a) (cdr b)))
	     #f))
	((pair? b) #f)
	(else (eqv? a b))))
|#
;;; But we want our matcher to require that
;;; if there are multiple instances of a
;;; variable in a pattern, that all instances
;;; match the same expression.

;;; MATCH? takes a pattern and an expression.
;;; If they can match it returns a dictionary
;;; giving the substitutions for variables in
;;; the pattern that make the match.  If they
;;; cannot match it returns #f.

(define (match? pattern expression)
  (define (walk pat expr dict)
    (cond ((match-variable? pat)
	   (variable-match pat expr dict))
	  ((pair? pat)
	   (if (pair? expr)
	       (let ((ndict
		      (walk (car pat)
			    (car expr)
			    dict)))
		 (and ndict
		      (walk (cdr pat)
			    (cdr expr)
			    ndict)))
	       #f))
	  ((pair? expr) #f)
	  ((atom-match? pat expr) dict)
	  (else #f)))
  (walk pattern
	expression
	(empty-dictionary)))

;;; match variables will be represented as
;;; symbols that begin with a question mark.

(define (variable-match var expr dict)
  (let ((entry
	 (dictionary-lookup var dict)))
    (if entry
	(and (equal? (value-in-entry entry)
		     expr)
	     dict)
	(add-to-dictionary var expr dict))))


;;; The following are pattern-syntax choices

(define (match-variable? x)
  (and (symbol? x)
       (char=? (string-ref (symbol->string x)
			   0)
	       #\?)))

(define (atom-match? pat expr)
  (or (eq? pat expr)
      (and (number? pat)
	   (number? expr)
	   (= pat expr))))

;;; The dictionary data structure is
;;; represented as an association list.

(define (empty-dictionary) '())

(define (add-to-dictionary var expr dict)
  (cons (make-entry var expr) dict))

(define (make-entry var expr)
  (list var expr))

(define (variable-in-entry entry)
  (car entry))

(define (value-in-entry entry)
  (cadr entry))  

(define (dictionary-lookup var dictionary)
  (assq var dictionary))

#|
;;; ASSQ is provided by every Scheme system.

(define (assq key alist)
  (cond ((null? alist) #f)
	((eq? key (caar alist)) (car alist))
	(else (alist-lookup key (cdr alist)))))
|#	   

#|
(match? 'a 'a)
;Value: ()

(match? '?x 'a)
;Value: ((?x a))

(match? '(a ?x c) '(a b c))
;Value: ((?x b))

(match? '(a ?x c) '(a (b c)))
;Value: #f

(match? '(a ?x c) '(a (b c) c))
;Value: ((?x (b c)))

(match? '(a (?x ?y) c) '(a (b c) c))
;Value: ((?y c) (?x b))

(match? '(a (?x ?y) ?x) '(a (b c) c))
;Value: #f

(match? '(a (?x ?y) ?y) '(a (b c) c))
;Value: ((?y c) (?x b))
|#