;;;; -*- mode:Scheme -*- ;;;;

;;; UTILITIES

;;; Aliases for list access.

;;(define first car)
;;(define second cadr)
(define rest cdr)

;;; Something that prints as a single symbol
(define (atom? x) (or (symbol? x) (number? x) (boolean? x) (null? x)))

;;; A test for a (? x) type of variable.
(define (simple-variable? x) (and (pair? x) (eq? '? (first x))))

;;;; MATCHER

(define (match p d) (do-match p d '()))

(define (do-match p d bindings)
  "
  Purpose:	Matching
  Arguments:	Pattern, datum, optional bindings.
  Returns:	A list of bindings, which may be (), or FAIL.
  Remarks:	Pattern variables are indicated by (? <variable name>)
		Prolog's nameless variable is indicated by (? _)
  "
  (cond ((and (atom? p) (atom? d))
         (match-atoms p d bindings))
        ((simple-variable? p)
         (match-variable p d bindings))
        ((and (pair? p) (pair? d))
         (match-pieces p d bindings))
        (else 'fail)))

(define (match-atoms p d bindings)
  ;;Are the pattern and datum the same:
  (if (eqv? p d)			; eqv? not eq? because of numbers.
      ;;If so, return the value of BINDINGS:
      bindings
      ;;Otherwise, return FAIL.
      'fail))

(define (match-variable p d bindings)
  (let ((binding (find-binding p bindings)))
    ;;Is the pattern variable on the list of bindings:
    (if binding 
        ;;If it is, substitute its value an try again:
        (do-match (extract-value binding) d bindings)      
        ;;Otherwise, add new binding:
        (add-binding p d bindings))))

(define (match-pieces p d bindings)
  (let ((result (do-match (first p) (first d) bindings)))
    ;;See if the FIRST parts match producing new bindings:
    (if (eq? 'fail result)
	;;If they do not match, fail.
	'fail
	;;If they do match, try the REST parts using the resulting bindings:
	(do-match (rest p) (rest d) result))))

;;;; AUXILIARY PROCEDURES

(define (add-binding variable-expression datum bindings)
 (if (eq? '_ (second variable-expression))
     bindings
     (cons (list (second variable-expression) datum) bindings)))

(define (find-binding variable-expression binding)
  (if (not (eq? '_ (second variable-expression)))
    (assoc (second variable-expression) binding)
    #f))

(define (extract-key binding) (first binding))
(define (extract-value binding) (second binding))