;;; Michael Wollowski
;;; 6.ss

(define make-slist-leaf-iterator
  (lambda (ls)
    (let ([stack (make-stack)])
      (stack 'push ls)
      (letrec ([iterator (lambda ()
			   (if (stack 'empty?)
			       #f
			       (let ([top (stack 'pop)])
				 (if (null? top)
				     (iterator)
				     (if (symbol? (car top))
					 (begin (stack 'push (cdr top))
						(car top))
					 (begin (stack 'push (cdr top))
						(stack 'push (car top))
						(iterator)))))))])
	iterator))))


(define make-stack
  (lambda ()
    (let ([stk '()])
      (lambda (msg  . args )
	(case msg
	  [(empty?) (null? stk)]
	  [(push)   (set! stk (cons (car args) stk))]
	  [(pop)    (let ([top (car stk)])
		      (set! stk (cdr stk))
		      top)]
	  [else (error 'stack "illegal message to stack object: ~a" msg)])))))



(define subst-leftmost
  (lambda (n o l p)
    (let ([done #f])
      (letrec ([sl2 (lambda (new old lst pred?)
		      (if (null? lst)
			  '()
			  (if (atom? (car lst))
			      (if (pred? (car lst) old)
				  (begin
				    (set! done #t)
				    (cons new (cdr lst)))
				  (cons (car lst) (sl2 new old (cdr lst) pred?)))
			      (let ([newls (sl2 new old (car lst) pred?)])
				(if (not done)
				    (cons newls (sl2 new old (cdr lst) pred?))
				    (cons newls (cdr lst)))))))])
	(sl2 n o l p)))))


; #4
(define (getlexicalinfo x ls)
  (if (null? ls)
      'free
      (if (eqv? x (caar ls))
	  (cdar ls)
	  (getlexicalinfo x (cdr ls)))))

(define (inclexicaldepth ls)
  (let build ((left ls) (built '()))
    (if (null? left)
	built
	(build (cdr left) (append built (list (list (caar left) (+ (cadar left) 1) (caddar left))))))))

(define (addlexicalinfo bound new)
  (let ((newbinds
	 (let build ((left new) (p 0) (built '()))
	   (if (null? left)
	       built
	       (build (cdr left) (+ p 1) (append built (list (list (car left) 0 p)))))))
	(oldbinds
	 (let build ((left new) (built bound))
	   (if (null? left)
	       built
	       (build (cdr left) (remv '() (map (lambda (x) (if (eqv? (car x) (car left)) '() x)) built)))))))
    (append newbinds oldbinds)))

(define (lexical-address-help expr bound)
  (cond
   ((symbol? expr)
    (let ((info (getlexicalinfo expr bound)))
      (if (eqv? info 'free)
	  (list ': 'free expr)
	  (list ': (car info) (cadr info)))))
   ((eqv? (car expr) 'lambda)
    (list 'lambda (cadr expr)
	  (lexical-address-help (caddr expr) (addlexicalinfo (inclexicaldepth bound) (cadr expr)))))
   ((eqv? (car expr) 'if) (cons 'if (map (lambda (x) (lexical-address-help x bound)) (cdr expr))))
   (else (map (lambda (x) (lexical-address-help x bound)) expr))))

(define (lexical-address expr) (lexical-address-help expr '()))

; #5
(define (getlexicalname x ls)
  (if (null? ls)
      (error 'getlexicalname "no such lexical item")
      (if (and (eqv? (car x) (cadar ls)) (eqv? (cadr x) (caddar ls)))
	  (caar ls)
	  (getlexicalname x (cdr ls)))))

(define (un-lexical-address-help expr bound)
  (cond
   ((eqv? (car expr) ':)
    (if (eqv? (cadr expr) 'free)
	(caddr expr)
	(getlexicalname (cdr expr) bound)))
   ((eqv? (car expr) 'lambda)
    (list 'lambda (cadr expr)
	  (un-lexical-address-help (caddr expr) (addlexicalinfo (inclexicaldepth bound) (cadr expr)))))
   ((eqv? (car expr) 'if) (cons 'if (map (lambda (x) (un-lexical-address-help x bound)) (cdr expr))))
   (else (map (lambda (x) (un-lexical-address-help x bound)) expr))))

(define (un-lexical-address expr) (un-lexical-address-help expr '()))