;;; Unifier based on a queue 
;;;  of equations and subequations.

(define (unify t1 t2)
  (let lp ((xs (list t1)) (ys (list t2)) (dict '()))
    (cond ((and (null? xs) (null? ys)) dict)
	  ((or (null? xs) (null? ys)) #f)
	  (else
	   (let ((x (unify:value (car xs) dict))
		 (y (unify:value (car ys) dict)))
	     (cond ((equal? x y)
		    (lp (cdr xs) (cdr ys) dict))
		   ((variable? x)
		    (and (not (occurs-in? x y))
			(lp (cdr xs) (cdr ys)
			    (bind x y dict))))
		   ((variable? y)
		    (and (not (occurs-in? y x))
			(lp (cdr xs) (cdr ys)
			    (bind y x dict))))
		   ((and (pair? x) (pair? y))
		    (lp (append x (cdr xs))
			(append y (cdr ys)) dict))
		   (else #f)))))))

(define (unify:value expr dict)
  (cond ((variable? expr)
	 (let ((vcell (lookup expr dict)))
	   (if vcell
	       (unify:value (value vcell) dict)
	       expr)))
	((pair? expr)
	 (cons (unify:value (car expr) dict) 
	       (unify:value (cdr expr) dict)))
	(else expr)))

(define (occurs-in? x y)
  (cond ((equal? x y) #t)
	((pair? y)
	 (or (occurs-in? x (car y))
	     (occurs-in? x (cdr y))))
	(else #f)))

(define (variable? x)
  (and (pair? x) (eq? (car x) '?)))

(define (variable-name var)
  (cadr var))

(define (bind var val dict)
  (cons (list (variable-name var) val)
	(map (lambda (entry)
	       (list (car entry)
		     (substitute val var
				 (cadr entry))))
	     dict)))

(define (lookup var dict)
  (assq (variable-name var) dict))

(define (value vcell)
  (cadr vcell))

(define (substitute val var expr)
  (cond ((equal? var expr) val)
	((pair? expr)
	 (cons (substitute val var (car expr))
	       (substitute val var (cdr expr))))
	(else expr)))

#|
(define expr1
  '(h (? x1)
      (? x2)
      (? x3)
      (? x4) 
      (f (? y0) (? y0))
      (f (? y1) (? y1))
      (f (? y2) (? y2))
      (f (? y3) (? y3))
      (? y4)))

(define expr2
  '(h (f (? x0) (? x0))
      (f (? x1) (? x1))
      (f (? x2) (? x2))
      (f (? x3) (? x3))
      (? y1)
      (? y2)
      (? y3)
      (? y4)
      (? x4)))

(define substitution
  (show-time
   (lambda () (unify expr1 expr2))))
;;; process time: 20 (20 RUN + 0 GC);
;Value: substitution

(pp substitution)
#|
((y0 (? x0))
 (y4
  (f
   (f (f (f (? x0) (? x0)) (f (? x0) (? x0)))
      (f (f (? x0) (? x0)) (f (? x0) (? x0))))
   (f (f (f (? x0) (? x0)) (f (? x0) (? x0)))
      (f (f (? x0) (? x0)) (f (? x0) (? x0))))))
 (y3
  (f (f (f (? x0) (? x0)) (f (? x0) (? x0)))
     (f (f (? x0) (? x0)) (f (? x0) (? x0)))))
 (y2 (f (f (? x0) (? x0)) (f (? x0) (? x0))))
 (y1 (f (? x0) (? x0)))
 (x4
  (f
   (f (f (f (? x0) (? x0)) (f (? x0) (? x0)))
      (f (f (? x0) (? x0)) (f (? x0) (? x0))))
   (f (f (f (? x0) (? x0)) (f (? x0) (? x0)))
      (f (f (? x0) (? x0)) (f (? x0) (? x0))))))
 (x3
  (f (f (f (? x0) (? x0)) (f (? x0) (? x0)))
     (f (f (? x0) (? x0)) (f (? x0) (? x0)))))
 (x2 (f (f (? x0) (? x0)) (f (? x0) (? x0))))
 (x1 (f (? x0) (? x0))))
|#
|#

#|
(count-pairs substitution)
;Value: 245

(define usubst (canonical-copy substitution))
;Value: usubst

(count-pairs usubst)
;Value: 33

(equal? usubst substitution)
;Value: #t
|#

;;; Consing in unifier result is made unique here.

(define (unify t1 t2)
  (let lp ((xs (list-unique t1))
	   (ys (list-unique t2))
	   (dict '()))
    (cond ((and (null? xs) (null? ys)) dict)
	  ((or (null? xs) (null? ys)) #f)
	  (else
	   (let ((x (unify:value (car xs) dict))
		 (y (unify:value (car ys) dict)))
	     (cond ((equal? x y)
		    (lp (cdr xs) (cdr ys) dict))
		   ((variable? x)
		    (and (not (occurs-in? x y))
			(lp (cdr xs) (cdr ys)
			    (bind x y dict))))
		   ((variable? y)
		    (and (not (occurs-in? y x))
			(lp (cdr xs) (cdr ys)
			    (bind y x dict))))
		   ((and (pair? x) (pair? y))
		    (lp (append x (cdr xs))
			(append y (cdr ys)) dict))
		   (else #f)))))))

(define (unify:value expr dict)
  (cond ((variable? expr)
	 (let ((vcell (lookup expr dict)))
	   (if vcell
	       (unify:value (value vcell) dict)
	       expr)))
	((pair? expr)
	 (cons-unique
	  (unify:value (car expr) dict) 
	  (unify:value (cdr expr) dict)))
	(else expr)))

(define (bind var val dict)
  (cons (list-unique (variable-name var) val)
	(map (lambda (entry)
	       (list-unique
		(car entry)
		(substitute val var
			    (cadr entry))))
	     dict)))

(define (substitute val var expr)
  (cond ((equal? var expr) val)
	((pair? expr)
	 (cons-unique
	  (substitute val var (car expr)) 
	  (substitute val var (cdr expr))))
	(else expr)))

#|
(define substitution
  (show-time
   (lambda () (unify expr1 expr2))))
;;; process time: 30 (30 RUN + 0 GC);
;Value: substitution

(count-pairs substitution)
;Value: 33
|#