(define (print . objs) (for-each display objs) (newline))

(define (make-rw-env parent-store)
  (define *store* parent-store)
  (lambda (msg . args)
    (case msg
      ((names)    (map car *store*))
      ((extend)   (make-rw-env *store*))
      ((enter)    (let* ((n (car args))
                         (v (cadr args)))
                    (set! *store* (cons (cons n v)
                                       *store*))))
      ((lookup)   (let* ((n (car args))
                         (v (assq n *store*)))
                    (if v
                        (cdr v)
                        n))))));'not-defined))))))

(define (make-var-intr)
  (let ((*backing* (make-rw-env '())))
    (lambda (msg . args)
      (case msg
        ((enter) (*backing* 'enter (car args) 'void))
        (else    (apply *backing* (cons msg args)))))))

(define (digger)
  (define *max-v* -1)
  (define (next-v)
    (set! *max-v* (+ 1 *max-v*))
    (string->symbol (string-append "v" (number->string *max-v*))))

  (define (dig sexp rw-env var-intr)
    (if (not (pair? sexp))
        (cond
          ((symbol? sexp) (dig-identifier sexp rw-env var-intr))
          (else           sexp))
        (case (car sexp)
          ((lambda) (dig-lambda sexp rw-env var-intr))
          ((let)    (dig-let sexp rw-env var-intr))
          (else     (dig-invocation sexp rw-env var-intr)))))

  (define (dig-identifier sexp rw-env var-intr)
    (rw-env 'lookup sexp))

  (define (dig-lambda sexp rw-env var-intr)
    (let ((param-names   (cadr sexp))
          (proc-rw-env   (rw-env 'extend))
          (body          (cddr sexp))
          (proc-var-intr (make-var-intr)))

      (for-each (lambda (n) (proc-rw-env 'enter n (next-v))) param-names) ; GENERALIZE!

      (let ((rewritten-body (map (lambda (s)
                                   (dig s proc-rw-env proc-var-intr))
                                 body)))
       `(lambda
          ,(map (lambda (n) (dig-identifier n proc-rw-env  var-intr)) param-names) ;UGLY!
            (letrec ,(map (lambda (n) `(,n 'void)) (proc-var-intr 'names))
              ,@rewritten-body)))))

  (define (dig-let sexp rw-env var-intr)
    (let* ((let-rw-env   (rw-env 'extend))
           (var-names    (map car (cadr sexp)))
           (rw-var-names (map (lambda (ignore) (next-v)) var-names))
           (var-vals     (map cadr (cadr sexp)))
           (body         (cddr sexp)))

      (for-each (lambda (n rwv)
                  (let-rw-env 'enter n rwv)
                  (var-intr 'enter rwv))
                var-names
                rw-var-names)

      (let* ((rewritten-vals  (map (lambda (s) (dig s rw-env var-intr))
                                   var-vals))
             (set!-statements (map (lambda (n v) (list 'set! n v))
                                   rw-var-names
                                   rewritten-vals))
             (rewritten-body  (map (lambda (s) (dig s let-rw-env var-intr))
                                   body)))
       `(begin
          ,@set!-statements
          ,@rewritten-body))))

  (define (dig-invocation sexp rw-env var-intr)
    (map (lambda (s) (dig s rw-env var-intr)) sexp))

  (lambda (q)
    (let ((qo (dig q (make-rw-env '()) 'no-var-intr)))
      (print "in:  " q)
      (print "out: " qo)
      (print "res-eval-in:  " (eval q (scheme-report-environment 5)))
      (print "res-eval-out: " (eval qo (scheme-report-environment 5))))))

((digger) (quote

((lambda (a b c)
  (let ((d (* a b c)))
    (let ((a (let ((a (+ a 111))) (+ a 9)))
          (b (let ((a 3)
                   (b (* a 222))
                   (k (+ a b c)))
               (+ a b k))))
      (+ a b (let ((d 222)) d) (* c d))))) 99 3 4)

))


;;; RESULTS

; in
((lambda (a b c)
  (let ((d (* a b c)))
    (let ((a (let ((a (+ a 111))) (+ a 9)))
          (b (let ((a 3)
                   (b (* a 222))
                   (k (+ a b c)))
               (+ a b k))))
      (+ a b (let ((d 222)) d) (* c d))))) 99 3 4)

; out
((lambda (v0 v1 v2)
   (letrec ((v10 (quote void))
            (v9  (quote void))
            (v8  (quote void))
            (v7  (quote void))
            (v6  (quote void))
            (v5  (quote void))
            (v4  (quote void))
            (v3  (quote void)))
     (begin
       (set! v3 (* v0 v1 v2))
       (begin
         (set! v4 (begin
                    (set! v6 (+ v0 111))
                    (+ v6 9)))
         (set! v5 (begin
                    (set! v7 3)
                    (set! v8 (* v0 222))
                    (set! v9 (+ v0 v1 v2))
                    (+ v7 v8 v9)))
         (+ v4 v5 (begin (set! v10 222) v10) (* v2 v3)))))) 99 3 4)

; res-eval-in
27280

; res-eval-out
27280