lista7.rkt

#lang racket

;; arithmetic expressions

(define (const? t)
  (number? t))

(define (op? t)
  (and (list? t)
       (member (car t) '(+ - * / = > >= <= <))))

(define (op-op e)
  (car e))

(define (op-args e)
  (cdr e))

(define (op-cons op args)
  (cons op args))

(define (op->proc op)
  (cond [(eq? op '+) +]
        [(eq? op '*) *]
        [(eq? op '-) -]
        [(eq? op '/) /]
        [(eq? op '=) =]
        [(eq? op '>) >]
        [(eq? op '>=) >=]
        [(eq? op '<=) <=]
        [(eq? op '<) <]))

;; lets

(define (let-def? t)
  (and (list? t)
       (= (length t) 2)
       (symbol? (car t))))

(define (let-def-var e)
  (car e))

(define (let-def-expr e)
  (cadr e))

(define (let-def-cons x e)
  (list x e))

(define (let? t)
  (and (list? t)
       (= (length t) 3)
       (eq? (car t) 'let)
       (let-def? (cadr t))))

(define (let-def e)
  (cadr e))

(define (let-expr e)
  (caddr e))

(define (let-cons def e)
  (list 'let def e))

;; variables

(define (var? t)
  (symbol? t))

(define (var-var e)
  e)

(define (var-cons x)
  x)

;; set

(define empty-set
  (identity null))

(define (add-to-set x s)
  (cond [(null? s) (list x)]
        [(eq? x (car s)) s]
        [else (cons (car s) (add-to-set x (cdr s)))]))

(define (merge-sets s1 s2)
  (cond [(null? s1) s2]
        [else (add-to-set (car s1) (merge-sets (cdr s1) s2))]))

(define (set-member? x s)
  (member x s))
  
(define (set->list s)
  (identity s))

;; free-variables

(define (fv e env)
  (cond [(const? e) empty-set]
        [(op? e) (args-fv (op-args e) env)]
        [(let? e) (merge-sets
                    (fv (let-def-expr (let-def e)) env)
                    (fv (let-expr e)
                        (add-to-set (let-def-var (let-def e))
                                    env)))]
        [(var? e) (if (set-member? (var-var e) env)
                      empty-set
                      (add-to-set (var-var e) empty-set))]))

(define (args-fv xs env)
  (cond [(null? xs) empty-set]
        [else (merge-sets (fv (car xs) env)
                          (args-fv (cdr xs) env))]))

(define (free-vars e)
  (set->list (fv e empty-set)))

(define (get-env-vars env)
  (if (null? env)
      null
      (cons (caar env) (get-env-vars (cdr env)))))

;; boolean

(define (is-true? t)
  (or
   (eq? '#t t)
   (eq? 'true t)
   (eq? '#true t)))

(define (is-false? t)
  (or
   (eq? '#f t)
   (eq? 'false t)
   (eq? '#false t)))

(define (is-if? t)
  (and
   (list? t)
   (= (length t) 4)
   (eq? 'if (car t))))

(define (if-cond t)
  (second t))

(define (if-true t)
  (third t))

(define (if-false t)
  (fourth t))

(define (is-cond? t)
  (and
   (list? t)
   (< 0 (length t))
   (eq? (car t) 'cond)))

(define (cond-cond t)
  (cdr t))

(define (cond-cond-cond t)
  (car t))

(define (cond-cond-expr t)
  (second t))

(define (eval-cond e env)
  (if (null? e)
      (void)
      (if (eval-env (cond-cond-cond (car e)) env)
          (eval-env (cond-cond-expr (car e)) env)
          (eval-cond (cdr e) env))))

(define (is-and? t)
  (and
   (list? t)
   (< 0 (length t))
   (eq? 'and (car t))))

(define (and-pred t)
  (cdr t))

(define (eval-and e env)
  (if (null? e)
      true
      (if
       (not (eval-env (car e) env))
            false
            (eval-and (cdr e) env))))

(define (eval-or e env)
  (if (null? e)
      false
      (if
       (eval-env (car e) env)
            true
            (eval-and (cdr e) env))))

(define (is-or? t)
  (and
   (list? t)
   (< 0 (length t))
   (eq? 'or (car t))))

(define (or-pred t)
  (cdr t))

;; pairs

(define (is-null?? t)
  (and
   (list? t)
   (= 2 (length t))
   (eq? 'null? (car t))))

(define (null?-expr t)
  (second t))

(define (is-null? t)
  (eq? 'null t))

(define (is-pair? t)
  (and
   (list? t)
   (= 2 (length t))
   (eq? (car t) 'pair?)))

(define (pair?-expr t)
  (second t))

(define (is-list? t)
  (and
   (list? t)
   (< 0 (length t))
   (eq? (car t) 'list)))

(define (list-args t)
  (cdr t))

(define (cons? t)
  (and (list? t)
       (= (length t) 3)
       (eq? (car t) 'cons)))

(define (cons-fst e)
  (second e))

(define (cons-snd e)
  (third e))

(define (cons-cons e1 e2)
  (list 'cons e1 e2))

(define (car? t)
  (and (list? t)
       (= (length t) 2)
       (eq? (car t) 'car)))

(define (car-expr e)
  (second e))

(define (cdr? t)
  (and (list? t)
       (= (length t) 2)
       (eq? (car t) 'cdr)))

(define (cdr-expr e)
  (second e))

;; lambdas

(define (lambda? t)
  (and (list? t)
       (= (length t) 3)
       (eq? (car t) 'lambda)
       (list? (cadr t))
       (andmap symbol? (cadr t))))

(define (lambda-vars e)
  (cadr e))

(define (lambda-expr e)
  (caddr e))

;; applications

(define (app? t)
  (and (list? t)
       (> (length t) 0)))

(define (app-proc e)
  (car e))

(define (app-args e)
  (cdr e))

;; expressions

(define (expr? t)
  (or (const? t)
      (and (op? t)
           (andmap expr? (op-args t)))
      (and (let? t)
           (expr? (let-expr t))
           (expr? (let-def-expr (let-def t))))
      (var? t)
      (and (cons? t)
           (expr? (cons-fst t))
           (expr? (cons-snd t)))
      (and (car? t)
           (expr? (car-expr t)))
      (and (cdr? t)
           (expr? (cdr-expr t)))
      (and (lambda? t)
           (expr? (lambda-expr t)))
      (and (app? t)
           (expr? (app-proc t))
           (andmap expr? (app-args t)))))

;; environments

(define empty-env
  null)

(define (add-to-env x v env)
  (cons (list x v) env))

(define (find-in-env x env)
  (cond [(null? env) (+(error "undefined variable" x))]
        [(eq? x (caar env)) (cadar env)]
        [else (find-in-env x (cdr env))]))

;; closures

(define (closure-cons xs expr env)
  (list 'closure xs expr env))

(define (closure? c)
  (and (list? c)
       (= (length c) 4)
       (eq? (car c) 'closure)))

(define (closure-vars c)
  (cadr c))

(define (closure-expr c)
  (caddr c))

(define (closure-env c)
  (cadddr c))

;; evaluator

(define (eval-env e env)
  (cond [(const? e) e]
        [(op? e)
         (apply (op->proc (op-op e))
                (map (lambda (a) (eval-env a env))
                     (op-args e)))]
        [(let? e)
         (eval-env (let-expr e)
                   (env-for-let (let-def e) env))]
        [(is-null? e) '()]
        [(is-null?? e) (null? (eval-env (null?-expr e) env))]
        [(is-pair? e) (pair? (eval-env (pair?-expr e) env))]
        [(is-list? e) (apply list (map (lambda (x) (eval-env x env)) (list-args e)))]
        [(is-true? e) true]
        [(is-false? e) false]
        [(is-if? e)
         (if (eval-env (if-cond e) env)
             (eval-env (if-true e) env)
             (eval-env (if-false e) env))]
        [(is-cond? e)
         (eval-cond (cond-cond e) env)]
        [(is-and? e)
         (eval-and (and-pred e) env)]
        [(is-or? e)
         (eval-or (or-pred e) env)]
        [(var? e) (find-in-env (var-var e) env)]
        [(cons? e)
         (cons (eval-env (cons-fst e) env)
               (eval-env (cons-snd e) env))]
        [(car? e)
         (car (eval-env (car-expr e) env))]
        [(cdr? e)
         (cdr (eval-env (cdr-expr e) env))]
        [(lambda? e)
         (closure-cons (lambda-vars e)
                       (lambda-expr e)
                       (set-intersect (fv (lambda-expr e) env)
                                      (get-env-vars env)))]
        [(app? e)
         (apply-closure
           (eval-env (app-proc e) env)
           (map (lambda (a) (eval-env a env))
                (app-args e)))]))

(define (apply-closure c args)
  (eval-env (closure-expr c)
            (env-for-closure
              (closure-vars c)
              args
              (closure-env c))))

(define (env-for-closure xs vs env)
  (cond [(and (null? xs) (null? vs)) env]
        [(and (not (null? xs)) (not (null? vs)))
         (add-to-env
           (car xs)
           (car vs)
           (env-for-closure (cdr xs) (cdr vs) env))]
        [else (error "arity mismatch")]))

(define (env-for-let def env)
  (add-to-env
    (let-def-var def)
    (eval-env (let-def-expr def) env)
    env))

(define (eval e)
  (eval-env e empty-env))

(define (is-keyword? x)
  (not (not (member x '(let
                         and
                         or
                         null
                         null?
                         lambda
                         +
                         -
                         *
                         /
                         =
                         <=
                         >=
                         <
                         >
                         pair?
                         cons
                         car
                         cdr
                         list
                         cond
                         false
                         true
                         #f
                         #t
                         #true
                         #false
                         if)))))
                                                  
(define (subst e var expr)
  (if (or (is-keyword? var)
          (number? var))
      (error "Not a variable!")
      (if (not (pair? expr))
          (if (and (var? expr)
                   (eq? expr var))
              e
              expr)
          (if (let? expr)
              (list 'let
                    (list (let-def-var (let-def expr))
                          (subst e var (let-def-expr (let-def expr))))
                    (subst e var (let-expr expr)))
              (cons (subst e var (car expr))
                    (subst e var (cdr expr)))))))