(print-gensym #f)
(load "match.ss")

(load "expand-only.ss")

(current-expand
  (let ([make-expander
          (lambda (e)
            (define expand
              (case-lambda
                [(x) (expand x (interaction-environment) #f)]
                [(x env-spec) (expand x env-spec #f)]
                [(x env-spec records?) (expand x env-spec records? #f)]
                [(x env-spec records? compiling-a-file)
                 (import \#system)
                 (if (and (pair? x) (equal? (car x) "noexpand"))
		   (cadr x)
		   (if records?
		     ($cprep (e x))
		     (e x)))]))
            expand)]
        [beta-reduce-apps
          (lambda (e)
            (sc-expand
              `(let-syntax
		 ([app
		    (syntax-rules (lambda)
		      [(_ (lambda (Id ...) Body0 Body ...) Exp ...)
		       (let-syntax ([Id (identifier-syntax Exp)] ...)
			 Body0 Body ...)]
		      [(_ X Exp ...) (no-app X Exp ...)])])
                 ,(sc-expand e))))]
        [install-apps
          (lambda (e)
            (sc-expand
              `(let-syntax
		 ([no-app
		    (syntax-rules ()
		      [(_ X Exp ...) (app X Exp ...)])])
                 ,(sc-expand e))))]
        [remove-apps
          (lambda (e)
            (sc-expand
              `(let-syntax
		 ([app
		    (syntax-rules ()
		      [(_ X Exp ...) (X Exp ...)])])
                 ,(sc-expand e))))]
        [alpha-equiv?
          (letrec
	    ([find-matching-binding
	       (lambda (name env)
		 (cond
		   [(null? env) name]
		   [(find-matching-binding-from-rib name (caar env) (cdar env))
		    => (lambda (binding) binding)]
		   [else (find-matching-binding name (cdr env))]))]
	     [find-matching-binding-from-rib
	       (lambda (name fmls1 fmls2)
		 (cond
		   [(and (symbol? fmls1) (symbol? fmls2))
		    (if (eqv? fmls1 name) fmls2 #f)]
		   [(and (pair? fmls1) (pair? fmls2))
		    (if (eqv? (car fmls1) name)
		      (car fmls2)
		      (find-matching-binding-from-rib name (cdr fmls1) (cdr fmls2)))]
		   [else #f]))]
	     [alpha-equiv^?
	       (lambda (e1 e2 env)
		 (match `(,e1 ,e2)
		   [(,x1 ,x2) (guard (symbol? x1) (symbol? x2))
		    (eqv? (find-matching-binding x1 env) x2)]
		   [(,c1 ,c2) (guard (not (pair? c1)) (not (pair? c2))) #t]
		   [((quote . ,x) (quote . ,y)) #t]
		   [((lambda ,fmls1 ,b1 ,b*1 ...) (lambda ,fmls2 ,b2 ,b*2 ...))
		    (guard (= (length `(,b*1 ...)) (length `(,b*2 ...))))
		    (andmap
		      (let ([new-env (cons (cons fmls1 fmls2) env)])
			(lambda (b1 b2)
			  (alpha-equiv^? b1 b2 new-env)))
		      `(,b1 ,b*1 ...)
		      `(,b2 ,b*2 ...))]
		   [((case-lambda [,fmls1* ,b1 ,b*1 ...] ...)
		     (case-lambda [,fmls2* ,b2 ,b*2 ...] ...))
		    (guard
		      (= (length `([,fmls1* ,b1 ,b*1 ...] ...))
			(length `([,fmls2* ,b2 ,b*2 ...] ...))))
		    (andmap
		      (lambda (fmls1 fmls2 b1* b2*)
			(andmap
			  (let ([new-env (cons (cons fmls1 fmls2) env)])
			    (lambda (b1 b2)
			      (alpha-equiv?^ b1 b2 new-env)))
			  b1* b2*))
		      `(,fmls1* ...)
		      `(,fmls2* ...)
		      `((,b1 ,b*1 ...) ...)
		      `((,b2 ,b*2 ...) ...))]
		   [((if ,t1 ,c1 ,a1) (if ,t2 ,c2 ,a2))
		    (and
		      (alpha-equiv^? t1 t2 env)
		      (alpha-equiv^? c1 c2 env)
		      (alpha-equiv^? a1 a2 env))]
		   [((,define-or-set!1 ,x1 ,b1) (,define-or-set!2 ,x2 ,b2))
		    (guard
		      (eqv? define-or-set!1 define-or-set!2)
		      (memq define-or-set!1 '(define set!)))
		    (and (alpha-equiv^? x1 x2 env) (alpha-equiv^? b1 b2 env))]
		   [((begin ,b1 ,b*1 ...) (begin ,b2 ,b*2 ...))
		    (guard (= (length `(,b*1 ...)) (length `(,b*2 ...))))
		    (andmap
		      (lambda (b1 b2)
			(alpha-equiv^? b1 b2 env))
		      `(,b1 ,b*1 ...)
		      `(,b2 ,b*2 ...))]
		   [((,letrec-name1 ([,x1 ,g1] ...) ,b1 ,b*1 ...)
		     (,letrec-name2 ([,x2 ,g2] ...) ,b2 ,b*2 ...))
		    (guard
		      (eqv? letrec-name1 letrec-name2)
		      (memq letrec-name1 '(letrec letrec*))
		      (= (length `(,b*1 ...)) (length `(,b*2 ...))))
		    (let ([x1* `(,x1 ...)]
			  [x2* `(,x2 ...)])
		      (let ([new-env (cons (cons x1* x2*) env)])
			(and
			  (andmap
			    (lambda (g1 g2)
			      (alpha-equiv^? g1 g2 new-env))
			    `(,g1 ...)
			    `(,g2 ...))
			  (andmap
			    (lambda (b1 b2)
			      (alpha-equiv^? b1 b2 new-env))
			    `(,b1 ,b*1 ...)
			    `(,b2 ,b*2 ...)))))]
		   [((,foreign1 ,conv1 ,name1 (,input-type1 ...) ,output-type1)
		     (,foreign2 ,conv2 ,name2 (,input-type2 ...) ,output-type2))
		    (guard
		      (eqv? foreign1 foreign2)
		      (memv foreign1 '(\#foreign-procedure \#foreign-callable)))
		    #t]
		   [((,prim ,x ...) (,prim ,y ...))
		    (guard (eqv? prim '\#primitive))
		    (andmap
		      (lambda (x y)
			(alpha-equiv^? x y env))
		      `(,x ...)
		      `(,y ...))]
		   [((app ,rator1 ,rand1 ...) (app ,rator2 ,rand2 ...))
		    (guard (= (length `(,rand1 ...)) (length `(,rand2 ...))))
		    (and
		      (alpha-equiv^? rator1 rator2 env)
		      (andmap
			(lambda (rand1 rand2)
			  (alpha-equiv^? rand1 rand2 env))
			`(,rand1 ...)
			`(,rand2 ...)))]
		   [((,rator1 ,rand1 ...) (,rator2 ,rand2 ...))
		    (guard (= (length `(,rand1 ...)) (length `(,rand2 ...))))
		    (and
		      (alpha-equiv^? rator1 rator2 env)
		      (andmap
			(lambda (rand1 rand2)
			  (alpha-equiv^? rand1 rand2 env))
			`(,rand1 ...)
			`(,rand2 ...)))]
		   [,else #f]))])
            (lambda (e1 e2)
              (alpha-equiv^? e1 e2 '())))])
    (make-expander
      (letrec
	([expand/app
	   (lambda (e0)
	     (let ([e1 (beta-reduce-apps e0)])
	       (let ([e2 (install-apps e1)])
		 (if (alpha-equiv? e2 e0)
		   (remove-apps e2)
		   (expand/app e2)))))])
        expand/app))))

(define-syntax lets
  (syntax-rules ()
    [(_ ([Id Exp] ...) Body0 Body ...)
     (app (lambda (Id ...) Body0 Body ...) Exp ...)]))

(define-syntax let*s
  (syntax-rules ()
    [(_ ([Id Exp]) Body0 Body ...)
     (lets ([Id Exp]) Body0 Body ...)]
    [(_ ([Id Exp] [Id1 Exp1] ...) Body0 Body ...)
     (lets ([Id Exp])
       (let*s ([Id1 Exp1] ...) Body0 Body ...))]))

(define foo
  (expand
    '(lets ([x (lambda (y) (+ y y))])
       (app x 8))))

(define goo
  (expand
    '(app (lambda (a b c) (+ a (+ b c))) 1 2 3)))

(define hoo
  (expand
    '(lets ([x (lambda (y) (+ y y))])
       'x)))

(define ioo
  (expand
    '(lets ([x 3] [y 4])
       (lets ([x (+ x x)] [z 5])
         (+ x y z)))))

(define joo
  (expand
    '(app (lambda (x) (app (lambda (y) (+ x y)) 5)) 6)))

(define koo
  (expand
    '(app (app (lambda (x) (lambda (y) (+ x y))) 5) 6)))

(define loo
  (expand
    '(lambda (f) (app f 1 2))))

(define moo
  (expand
    '(app (lambda (f) (app f 1 2)) (lambda (r s) (+ r s)))))

(define noo
  (expand
    '(lets ([f (lambda (r s) (+ r s))])
       (lets ([g (lambda (q) (app f q (app f 1 2)))])
         (app g 5)))))

(define oops
  (expand
    '(lets ([Y (lambda (le)
                 (app
                   (lambda (f) (app f f))
                   (lambda (f)
                     (app le
                       (lambda (x)
                         (app (f f) x))))))])
       Y)))

(define woops
  (expand
    '(app (lambda (f) (app f f)) (lambda (q) (q q)))))

(define zoops
  (expand
    '(lambda (f) (lambda (x) (app f x)))))

; > foo
; (+ 8 8)
; > goo
; (+ 1 (+ 2 3))
; > hoo
; 'x
; > ioo
; (+ (+ 3 3) 4 5)
; > joo
; (+ 6 5)
; > koo
; (+ 5 6)
; > loo
; (lambda (f) (f 1 2))
; > moo
; (+ 1 2)
; > noo
; (+ 5 (+ 1 2))
; > oops
; (lambda (le)
;   (le (lambda (x)
;         (((lambda (f) (le (lambda (x) ((f f) x))))
;           (lambda (f) (le (lambda (x) ((f f) x)))))
;          x))))
; > woops
; ((lambda (q) (q q)) (lambda (q) (q q)))
; > zoops
; (lambda (f) (lambda (x) (f x)))