; Brian Alliet
; Programming Language Theory
; 4005-710-01

; Turn any sexpression into a string 
(define (sexp->string e)
    (letrec
        ((helper (lambda (e rest)
            (cond
                ((null? e) (cons "()" rest))
                ((pair? e) (cons "(" (finishpair e rest)))
                ((number? e) (cons (number->string e) rest))
                ((symbol? e) (cons (symbol->string e) rest))
                ; FIXME: These don't escape chars correctly (but this doesn't matter for hw5)
                ((char? e) (cons (list->string (list #\# #\\ e)) rest))
                ((string? e) (cons "\"" (cons e (cons "\"" rest))))
                ((vector? e) (cons "#" (helper (vector->list e) rest)))
                ((eq? e #t) (cons "#t" rest))
                ((eq? e #f) (cons "#f" rest))
                (else (cons "--FIXME--" rest)))))
         (finishpair (lambda (e rest)
             (helper (car e) 
                 (cond
                     ((null? (cdr e)) (cons ")" rest))
                     ((pair? (cdr e)) (cons " " (finishpair (cdr e) rest)))
                     (else (cons " . " (helper (cdr e) (cons ")" rest)))))))))
        (apply string-append (helper e '()))))

; Our expressions are just a normal sexpressions
(define expr->string sexp->string)

; Datatype that can old a la-expressions or ula-expression
(define-datatype expression expression?
    (la-expr (e la-expression?))
    (ula-expr (e ula-expression?)))
    
; Lexical spec for lambda expressions
(define lexical-spec
    '((white-sp (whitespace) skip)
      (id (letter (arbno (or letter digit "?"))) symbol)
      (number (digit (arbno digit)) number)))

; Grammar for un-lexical-address expressions
(define ula-grammar
    '((ula-expression (id) ula-symbol-exp)
      (ula-expression ("(" ula-pexpression ")") ula-p-exp)
      (ula-pexpression ("lambda" "(" (arbno id) ")" ula-expression) ula-lambda-exp)
      (ula-pexpression (ula-expression (arbno ula-expression)) ula-app-exp)))
(sllgen:make-define-datatypes lexical-spec ula-grammar)

; Grammar for lexical-address expressions
(define la-grammar
    '((la-expression ("(" la-pexpression ")") la-p-exp)
      (la-pexpression (":" number number) la-bound-symbol-exp)
      (la-pexpression (id "free") la-free-symbol-exp)
      (la-pexpression ("lambda" "(" (arbno id) ")" la-expression) la-lambda-exp)
      (la-pexpression (la-expression (arbno la-expression)) la-app-exp)))
(sllgen:make-define-datatypes lexical-spec la-grammar)

; To parse the above convert them to strings, run them though the sllgen parser, then wrap them
; in an expression data type
(define (parse-la e) (la-expr ((sllgen:make-string-parser lexical-spec la-grammar) (expr->string e))))
(define (parse-ula e) (ula-expr ((sllgen:make-string-parser lexical-spec ula-grammar) (expr->string e))))

; Recursivly convert a ula expression data type to a normal ula-expression
(define (ula-expression->sexp e)
    (cases ula-expression e
        (ula-symbol-exp (e) e)
        (ula-p-exp (e) (cases ula-pexpression e
            (ula-lambda-exp (ids body) (list 'lambda ids (ula-expression->sexp body)))
            (ula-app-exp (f args) (map ula-expression->sexp (cons f args)))))))

; Same for la
(define (la-expression->sexp e)
    (cases la-expression e
        (la-p-exp (e) (cases la-pexpression e
            (la-bound-symbol-exp (x y) (list ': x y))
            (la-free-symbol-exp (x) (list x 'free))
            (la-lambda-exp (ids body) (list 'lambda ids (la-expression->sexp body)))
            (la-app-exp (f args) (map la-expression->sexp (cons f args)))))))

; To unparse an expressons run it though the above functions (after possibly changing its 
; representation)
(define (unparse-ula e)
    (cases expression e
        (la-expr (e) (un-lexical-address (la-expression->sexp e)))
        (ula-expr (e) (ula-expression->sexp e))))

(define (unparse-la e)
    (cases expression e
        (la-expr (e) (la-expression->sexp e))
        (ula-expr (e) (lexical-address (ula-expression->sexp e)))))

; To test for equality just convert them both to the same form and compare
(define (equal-expression? e1 e2) (equal? (unparse-ula e1) (unparse-ula e2)))


; This is just the lexical-address code from hw3

(define (lexical-address expr) 
    (call-with-current-continuation
        (lambda (return) 
            (lexical-address-helper (lambda () (return #f))  0 '() expr))))

(define (lexical-address-helper fail depth env expr)
    (match expr
        ((list 'lambda args body)
            (list 'lambda args (lexical-address-helper
                fail (+ depth 1) (append 
                    (zip (lambda (a p) (cons a (cons depth p))) args (from-to 0 (- (length args) 1)))
                    env) 
                body)))
        ((xs @ (cons _ _)) (map (curry lexical-address-helper fail depth env) xs))
        (sym 
            (if (symbol? sym)
                (match (lookup sym env)
                    ((cons a p) (list ': a p))
                    ('#f (list sym 'free)))
                (fail)))))

(define (un-lexical-address expr) 
    (call-with-current-continuation
        (lambda (return) 
            (un-lexical-address-helper (lambda () (return #f)) '() expr))))

(define (un-lexical-address-helper fail env expr)
    (match expr
        ((list 'lambda args body)
            (list 'lambda args (un-lexical-address-helper fail (append env (list args)) body)))
        ((list ': d p)
            (if (>= d (length env))
                (fail)
                (let ((names (list-ref env d)))
                    (if (>= p (length names))
                        (fail)
                        (list-ref names p)))))
        ((list sym 'free) sym) 
        ((xs @ (cons _ _)) (map (curry un-lexical-address-helper fail env ) xs))
        (_ (fail))))