; COSC 152
; Fall 2006
; Dennis Brylow
;
; Lecture 19 Demo
; Lexical Address with Abstract Syntax Tree.

; AST data structures, with lexical address variants
(define-datatype exp exp?
  (lit-exp (datum number?))
  (var-exp (id symbol?))
  (if-exp (test-exp exp?)
	  (true-exp exp?)
	  (false-exp exp?))
  (lambda-exp (ids (list-of symbol?))
	      (body exp?))
  (app-exp (rator exp?)
	   (rands (list-of exp?)))
  (lex-info (id symbol?)
            (depth number?)
            (position number?))
  (free-info (id symbol?))
  )

; Manual parse function
; Converts concrete syntax into abstract syntax.
(define parse
  (lambda (x)
    (cond
      ((null? x) (eopl:error 'parse "Can't parse ~s." x))
      ((number? x) (lit-exp x))
      ((symbol? x) (var-exp x))
      ((not (pair? x)) (eopl:error 'parse "Can't parse ~s." x))
      ((eqv? (car x) 'if)
       (if-exp (parse (cadr x)) 
	       (parse (caddr x)) 
	       (parse (cadddr x))))
      ((eqv? (car x) 'lambda)
       (lambda-exp (cadr x)
		   (parse (caddr x))))
      (else
       (app-exp (parse (car x))
		(map parse (cdr x))))
      )))
                
; Converts abstract syntax into concrete syntax.
(define unparse
  (lambda (x)
    (cases exp x
      (lit-exp (datum) datum)
      (var-exp (id)    id)
      (if-exp (test-exp true-exp false-exp)
	      (list 'if (unparse test-exp)
		    (unparse true-exp) (unparse false-exp)))
      (lambda-exp (ids body)
		  (list 'lambda ids (unparse body)))
      (app-exp (rator rands)
	       (cons (unparse rator) (map unparse rands)))
      (lex-info (id dep pos) (list id ': dep pos))
      (free-info (id) (list id 'free))
    )))
      
; Environment data structure for calculating
;  lexical address of variable references.
(define empty-env 
  (lambda () '()))

(define extend-env
  (lambda (vars env)
    (cons vars env)))

; new apply-env returns AST structures instead of concrete syntax.
(define apply-env
  (lambda (a env)
    (letrec ([apply-env-helper 
              (lambda (a env depth)
                (if (null? env)
                    (free-info a)
                    (if (member a (car env))
                        (lex-info a depth (list-index a 0 (car env)))
                        (apply-env-helper a (cdr env) (+ 1 depth))
                        )))]
             [list-index 
              (lambda (a index lst)
                (if (null? lst)
                    #f
                    (if (eqv? a (car lst))
                        index
                        (list-index a (+ 1 index) (cdr lst)))))])
      (apply-env-helper a env 0))))

; Helper function takes AST and environment, returns new AST with
;  var references replaced by lexical addresses.
(define lex-addr
  (lambda (expression env)
    (cases exp expression
      (lit-exp (datum) (lit-exp datum))
      (var-exp (id)    (apply-env id env))
      (if-exp  (test true false) (if-exp (lex-addr test env)
					 (lex-addr true env)
					 (lex-addr false env)))
      (lambda-exp (ids body)
		  (lambda-exp ids (lex-addr body (extend-env ids env))))
      (app-exp (rator rands)
	       (app-exp (lex-addr rator env)
			(map (lambda (x) (lex-addr x env)) rands))) 
      (lex-info (id dep pos) expression)
      (free-info (id) expression)
      )))

; Top level lexical-address can handle AST or concrete syntax as input.
(define lexical-address
  (lambda (expression)
    (if (exp? expression)
        (lex-addr expression (empty-env))
        (unparse (lex-addr (parse expression) (empty-env))))))