;; ------------------------------------------
;; D.S. Blank, Fall 2002
;; Programming Languages, BMC
;; HW#5: Lexical Address Functions
;; ------------------------------------------

;; Takes a scheme expression and environment; returns scheme
;; expression with bound variables replaced with "address"

(define lexical-address
  (lambda (element env)
    (cond
     ((not (list? element)) (la-pos element env 0 0))
     ((null? element) '())
     ((eq? 'lambda (car element)) 
      (list 'lambda 
	    (cadr element) 
	    (lexical-address (caddr element) 
			     (cons (cadr element) env))))
     (else (la-list element env)))))

;; la-pos returns the position in a list of lists of a matching symbol
;; if found, otherwise just return symbol

(define la-pos
  (lambda (symbol env depth pos)
    (cond
     ((null? env) symbol)
     ((null? (car env)) (la-pos symbol (cdr env) (+ 1 depth) 0))
     ((eq? (caar env) symbol) (list ': depth pos))
     (else (la-pos symbol (cons (cdar env) (cdr env)) depth (+ 1 pos))))))

;; la-list takes a list and applies lexical-address to each element
;; of the list (returned as a list)

(define la-list
  (lambda (lst env)
    (cond
     ((null? lst) '())
     (else (cons (lexical-address (car lst) env) (la-list (cdr lst) env))))))

;; Short-cut:

(define la 
  (lambda (sexp)
    (lexical-address sexp '())))

;; Given a lexical address expression (one that has bound variables
;; replaced with (: i j) format, replace bound syntax with variable
;; name

(define unlexical-address
  (lambda (element env)
    (cond
     ((not (list? element)) element) ;; free!
     ((null? element) '())
     ((eq? 'lambda (car element)) 
      (list 'lambda 
	    (cadr element) 
	    (unlexical-address (caddr element) 
			       (cons (cadr element) env))))
     ((eq? ': (car element))
      (lookup (cadr element) (caddr element) env))
     (else (ula-list element env)))))

;; function that takes position i and j, and returns variable
;; name from environment

(define lookup
  (lambda (depth pos env)
    (cond
     ((and (= depth 0) (= pos 0))
      (caar env))
     ((= depth 0)
      (lookup depth (- pos 1) (cons (cdar env) (cdr env))))
     (else (lookup (- depth 1) pos (cdr env))))))

;; Same as la-list, but recur with unlexical-address

(define ula-list
  (lambda (lst env)
    (cond
     ((null? lst) '())
     (else (cons (unlexical-address (car lst) env) 
		 (ula-list (cdr lst) env))))))

;; Short-cut:

(define ula
  (lambda (sexp)
    (unlexical-address sexp '())))