(load "record.ss")

(define-record varref (var))
(define-record lambda (formals body))
(define-record app (operator operands))

(define remove-all
  (lambda (ls1 ls2)
    (cond
      ((null? ls1) ls2)
      (else (remove-all (cdr ls1) (remq (car ls1) ls2))))))

(define append-all
  (lambda (lss)
    (cond
      ((null? lss) '())
      (else (append (car lss) (append-all (cdr lss)))))))

(define recordify
  (lambda (exp)
    (cond
      ((symbol? exp) (make-varref exp))
      ((atom? exp) (error 'recordify "illegal expression ~s" exp))
      ((eq? (car exp) 'lambda)
       (make-lambda (cadr exp) (recordify (caddr exp))))
      (else (make-app (recordify (car exp)) (map recordify (cdr exp)))))))

(define listify
  (lambda (exp)
    (variant-case exp
      (varref (var) var)
      (lambda (formals body) (list 'lambda formals (listify body)))
      (app (operator operands)
	(cons (listify operator) (map listify operands)))
      (else (error 'listify "illegeal representation ~s" exp)))))

(define free-vars
  (lambda (exp)
    (variant-case exp
      (varref (var) (list var))
      (lambda (formals body) (remove-all formals (free-vars body)))
      (app (operator operands)
	(append (free-vars operator) (append-all (map free-vars operands))))
      (else (error 'free-vars "illegeal representation ~s" exp)))))

(define rename-var
  (letrec ((lookup (lambda (v vs)
		     (cond
		       ((null? vs) #f)
		       (else (or (memq v (car vs)) (lookup v (cdr vs))))))))
    (lambda (v vs)
      (if (lookup v vs)
	  (rename-var (string->symbol (string-append (symbol->string v) "~"))
	    vs)
	  v))))

(define subst*
  (letrec ((h (lambda (s exp vars)
		(variant-case exp
		  (varref (var) (let ((pr (assq var s))) (if pr (cdr pr) exp)))
		  (lambda (formals body)
		    (filter formals s vars
		      (lambda (s vars)
			(rename formals s vars
			  (lambda (formals s vars)
			    (make-lambda formals (h s body vars)))))))
		  (app (operator operands)
		    (make-app (h s operator vars)
		      (map (lambda (x) (h s x vars)) operands)))
		  (else (error 'convert "illegeal representation ~s" exp)))))
	   (filter (lambda (formals s vars k)
		     (let loop ((s s) (vars vars) (s1 '()) (vars1 '()))
		       (cond
			 ((null? s) (k s1 vars1))
			 ((memq (caar s) formals)
			  (loop (cdr s) (cdr vars) s1 vars1))
			 (else
			   (loop (cdr s) (cdr vars) (cons (car s) s1)
			     (cons (car vars) vars1)))))))
	   (rename (lambda (formals s vars k)
		     (let loop ((fs formals) (newfs '()) (s s) (vars vars))
		       (cond
			 ((null? fs) (k (reverse newfs) s vars))
			 (else
			   (let ((v (rename-var (car fs) vars)))
			     (if (eq? (car fs) v)
				 (loop (cdr fs) (cons v newfs) s vars)
				 (loop (cdr fs) (cons v newfs)
				   (cons (cons (car fs) (make-varref v)) s)
				   (cons (list v) vars))))))))))
    (lambda (s exp)
      (h s exp (map (lambda (x) (free-vars (cdr x))) s)))))