; Solutions for CS 441 Assignment #2
; By Paul Martino and Andrew Wright

; (load "sets.scm")

;; Part 1

(define-record Const  (value))
(define-record Var    (name))
(define-record Lam    (formals body))
(define-record If     (test then else))
(define-record Ap     (fun args))
(define-record Let    (bindings body))
(define-record Let*   (bindings body))
(define-record Letrec (bindings body))
(define-record Set!   (name body))     ; for assignment 3
(define-record Dlet   (bindings body)) ; for assignment 3

(define parse
  (lambda (sexp)
    (cond ((member sexp '(#t #f ()))
           (make-Const sexp))
          ((or (number? sexp) (string? sexp) (char? sexp))
           (make-Const sexp))
          ((symbol? sexp)
           (make-Var sexp))
          ((list? sexp) 
           (cond ((and (equal? 'lambda (car sexp))
                       (= 3 (length sexp))
                       (andmap symbol? (cadr sexp)))
                  (if (not (check-distinct (cadr sexp)))
                      (error "lambda formals not distinct"))
                  (make-Lam
                    (cadr sexp)
                    (parse (caddr sexp))))
               	 ((and (equal? 'if (car sexp)) (= 4 (length sexp)))
                  (make-If
                    (parse (cadr sexp))
                    (parse (caddr sexp)) 
                    (parse (cadddr sexp))))
		 ((and (eq? (car sexp) 'quote)
                       (= 2 (length sexp)) 
		       (symbol? (cadr sexp)))
                  (make-Const
                    (cadr sexp)))
		 ((and (equal? 'let (car sexp)) (= 3 (length sexp)))
		  (make-Let
                    (map parse-binding (cadr sexp))
                    (parse (caddr sexp))))
		 ((and (equal? 'let* (car sexp)) (= 3 (length sexp)))
		  (make-Let*
                    (map parse-binding (cadr sexp))
                    (parse (caddr sexp))))
		 ((and (equal? 'letrec (car sexp)) (= 3 (length sexp)))
		  (make-Letrec
                    (map parse-binding (cadr sexp))
                    (parse (caddr sexp))))
		 ((and (equal? 'dynamic-let (car sexp)) (= 3 (length sexp)))
		  (make-Dlet
                    (map parse-binding (cadr sexp))
                    (parse (caddr sexp))))
                 ((and (equal? 'set! (car sexp))
                       (= 3 (length sexp))
                       (symbol? (cadr sexp)))
                  (make-Set!
                    (cadr sexp)
                    (parse (caddr sexp))))
                 (else
                   (if (member (car sexp) '(lambda if quote let let* letrec))
                       (printf "Warning: ~a parsed as a variable" (car sexp)))
                   (make-Ap
                     (parse (car sexp))
                     (map parse (cdr sexp))))))
          (else (error "syntax error")))))

(define parse-binding
  (lambda (sexp)
    (if (and (list? sexp) (= 2 (length sexp)) (symbol? (car sexp)))
        (list (car sexp) (parse (cadr sexp)))
        (error "syntax error in binding"))))

(define check-distinct
  (lambda (names)
    (if (null? names)
        #t
        (and (not (member (car names) (cdr names)))
             (check-distinct (cdr names))))))

(define andmap
  (lambda (f l)
    (if (null? l)
        (and)
        (and (f (car l)) (andmap f (cdr l))))))

;; Part 2

(define unparse
  (lambda (exp)
    (variant-case exp
      (Const (value)
        (if (symbol? value)
            (list 'quote value)
            value))
      (Var (name) name)
      (Lam (formals body)
           (list 'lambda formals (unparse body)))
      (Ap (fun args)
          (cons (unparse fun) (map unparse args)))
      (If (test then else)
          (list 'if (unparse test) (unparse then) (unparse else))) 
      (Let (bindings body)
        (list 'let (map unparse-binding bindings) (unparse body)))
      (Let* (bindings body)
        (list 'let* (map unparse-binding bindings) (unparse body)))
      (Letrec (bindings body)
        (list 'letrec (map unparse-binding bindings) (unparse body)))
      (Dlet (bindings body)
        (list 'let* (map unparse-binding bindings) (unparse body)))
      (Set! (name body)
        (list 'set! name (unparse body))))))

(define unparse-binding
  (lambda (b)
    (list (car b) (unparse (cadr b)))))

;; Part 3

(define compose
  (lambda (f g)
    (lambda (x)
      (f (g x)))))

(define free-vars
  (lambda (exp)
    (variant-case exp
      (Const (value)
        (set))
      (Var (name)
           (set name))
      (Lam (formals body)
           (difference (free-vars body) (list->set formals)))
      (Let (bindings body)
        (union
          (foldl union (set) (map (compose free-vars cadr) bindings))
          (difference (free-vars body) (list->set (map car bindings)))))
      (Let* (bindings body)
        (if (null? bindings)
            (free-vars body)
            (let ((x (car (car bindings)))
                  (e (cadr (car bindings))))
              (union
                (free-vars e)
                (difference
                  (free-vars (make-Let* (cdr bindings) body))
                  (set x))))))
      (Letrec (bindings body)
        (difference
          (foldl union (free-vars body) (map (compose free-vars cadr) bindings))
          (list->set (map car bindings))))
      (If (test then else)
          (union
            (free-vars test)
            (free-vars then)
            (free-vars else)))
      (Ap (fun args)
          (foldl union
	    (free-vars fun)
	    (map free-vars args))))))

;; Based on what I said in class

(define bound-vars
  (lambda (exp)
    (variant-case exp
      (Const (value)
        (set))
      (Var (name)
           (set))
      (Lam (formals body)
           (union
             (list->set formals)
             (bound-vars body)))
      (Let (bindings body)
        (foldl union
	  (union
	    (bound-vars body)
	    (list->set (map car bindings)))
          (map (compose bound-vars cadr) bindings)))
      (Let* (bindings body)
        (foldl union
	  (union
	    (bound-vars body)
	    (list->set (map car bindings)))
          (map (compose bound-vars cadr) bindings)))
      (Letrec (bindings body)
        (foldl union
	  (union
	    (bound-vars body)
	    (list->set (map car bindings)))
          (map (compose bound-vars cadr) bindings)))
      (If (test then else)
          (union
            (bound-vars test)
            (bound-vars then)
            (bound-vars else)))
      (Ap (fun args)
          (foldl union
	    (bound-vars fun)
	    (map bound-vars args))))))

;; Based on the book

(define bound-vars-eopl
  (lambda (exp)
    (variant-case exp
      (Const (value)
        (set))
      (Var (name)
           (set))
      (Lam (formals body)
           (union
             (intersect
               (list->set formals)
               (free-vars body))
             (bound-vars-eopl body)))
      (Let (bindings body)
        (foldl union
	  (union
	    (bound-vars-eopl body)
	    (intersect
	      (list->set (map car bindings))
	      (free-vars body)))
          (map (compose bound-vars-eopl cadr) bindings)))
      (Let* (bindings body)
        (if (null? bindings)
            (bound-vars-eopl body)
            (let ((x (car (car bindings)))
                  (e (cadr (car bindings)))
                  (next (make-Let* (cdr bindings) body)))
              (union
		(union
		  (bound-vars-eopl next)
		  (intersect
		    (set x)
		    (free-vars next)))
		(bound-vars-eopl e)))))
      (Letrec (bindings body)
	(foldl union
	  (union
	    (bound-vars-eopl body)
	    (intersect
	      (list->set (map car bindings))
	      (foldl union
		(free-vars body)
		(map (compose free-vars cadr) bindings))))
	  (map (compose bound-vars-eopl cadr) bindings)))
      (If (test then else)
          (union
            (bound-vars-eopl test)
            (bound-vars-eopl then)
            (bound-vars-eopl else)))
      (Ap (fun args)
          (foldl union
	    (bound-vars-eopl fun)
	    (map bound-vars-eopl args))))))