[Clojure] SICP 4.1: The Metacircular Evaluator

ch4_1.clj

(ns sicp.ch4-1
  (:refer-clojure :exclude [apply eval true? false?]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Evaluator data structures (ch.4.1.3, 4)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; procedure
(defn tagged-list? [exp tag]
  (if (seq? exp)
    (= (first exp) tag)
    false))
(defn primitive-procedure? [proc]
  (tagged-list? proc :primitive))
(defn primitive-implementation [proc]
  (second proc))
(def primitive-procedures
  [(list :car first)
   (list :cdr #(if (empty? (rest %)) nil (rest %)))
   (list :cons cons)
   (list :null? nil?)
   (list :+ +)
   (list :- -)
   (list :* *)
   (list :/ /)])
(defn primitive-procedure-names []
  (map first primitive-procedures))
(defn primitive-procedure-objects []
  (map #(list :primitive (second %)) primitive-procedures))
(def apply-in-underlying-scheme clojure.core/apply)
(defn apply-primitive-procedure [proc args]
  (apply-in-underlying-scheme
   (primitive-implementation proc) args))

(defn make-procedure [parameters body env]
  (list :procedure parameters body env))
(defn compound-procedure? [p]
  (tagged-list? p :procedure))
(defn procedure-parameters [p] (nth p 1))
(defn procedure-body [p] (nth p 2))
(defn procedure-environment [p] (nth p 3))

;;; environments
(defn enclosing-environment [env] (rest env))
(defn first-frame [env] (first env))
(def the-empty-environment '())
(defn make-frame [variables values]
  (let [atom-values (map atom values)]
    (atom (list variables atom-values))))
(defn frame-variables [frame] (first @frame))
(defn frame-values [frame] (first (rest @frame)))
(defn add-binding-to-frame! [var val frame]
  (reset! frame (list (cons var (frame-variables frame))
                      (cons (atom val) (frame-values frame)))))
(defn extend-environment [vars vals base-env]
  (if (= (count vars) (count vals))
    (cons (make-frame vars vals) base-env)
    (throw (RuntimeException. (str "Inconsistent length")))))
(defn lookup-variable-value [var env]
  (letfn [(env-loop [env]
            (letfn [(scan [vars vals]
                      (cond (empty? vars) (env-loop (enclosing-environment env))
                            (= var (first vars)) @(first vals)
                            :else (scan (rest vars) (rest vals))))]
              (if (= env the-empty-environment)
                (throw (RuntimeException. (str "Unbound variable: " var)))
                (let [frame (first-frame env)]
                  (scan (frame-variables frame)
                        (frame-values frame))))))]
    (env-loop env)))
(defn set-variable-value! [var val env]
  (letfn [(env-loop [env]
            (letfn [(scan [vars vals]
                      (cond (empty? vars) (env-loop (enclosing-environment env))
                            (= var (first vars)) (reset! (first vals) val)
                            :else (scan (rest vars) (rest vals))))]
              (if (= env the-empty-environment)
                (throw (RuntimeException. (str "Unbound variable: " var)))
                (let [frame (first-frame env)]
                  (scan (frame-variables frame)
                        (frame-values frame))))))]
    (env-loop env)))
(defn define-variable! [var val env]
  (let [frame (first-frame env)]
    (letfn [(scan [vars vals]
              (cond (empty? vars) (add-binding-to-frame! var val frame)
                    (= var (first vars)) (reset! (first vals) val)
                    :else (scan (rest vars) (rest vals))))]
      (scan (frame-variables frame)
            (frame-values frame)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Expressions (ch.4.1.2)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(declare eval)
(declare apply)

(defn self-evaluating? [exp]
  (cond (number? exp) true
        (string? exp) true
        :else false))

(defn variable? [exp]
  (keyword? exp))

(defn quoted? [exp]
  (tagged-list? exp :quote))
(defn text-of-quotation [exp]
  (first (rest exp)))

(defn assignment? [exp]
  (tagged-list? exp :set!))
(defn assignment-variable [exp] (nth exp 1))
(defn assignment-value [exp] (nth exp 2))
(defn eval-assignment [exp env]
  (set-variable-value! (assignment-variable exp)
                       (eval (assignment-value exp) env)
                       env)
  :ok)

(defn lambda? [exp]
  (tagged-list? exp :lambda))
(defn lambda-parameters [exp]
  (nth exp 1))
(defn lambda-body [exp]
  (nth exp 2))
(defn make-lambda [parameters body]
  (list :lambda parameters body))

;;; Exercise 4.6
(defn let? [exp]
  (tagged-list? exp :let))
(defn let-parameters [exp]
  (nth exp 1))
(defn let-vars [exp]
  (map first (let-parameters exp)))
(defn let-values [exp]
  (map second (let-parameters exp)))
(defn let-body [exp]
  (nth exp 2))
(defn let->combination [exp]
  (let [vars (let-vars exp)
        values (let-values exp)
        body (let-body exp)]
    (cons (make-lambda vars (list body)) values)))

(defn definition? [exp]
  (tagged-list? exp :define))
(defn definition-variable [exp]
  (if (keyword? (nth exp 1))
    (nth exp 1)
    (first (nth exp 1))))
(defn definition-value [exp]
  (if (keyword? (nth exp 1))
    (nth exp 2)
    (make-lambda (rest (nth exp 1))
                 (rest (rest exp)))))
(defn eval-definition [exp env]
  (define-variable! (definition-variable exp)
    (eval (definition-value exp) env)
    env)
  :ok)

(defn true? [x]
  (not (= x false)))
(defn false? [x]
  (= x false))

(defn if? [exp] (tagged-list? exp :if))
(defn if-predicate [exp] (nth exp 1))
(defn if-consequence [exp] (nth exp 2))
(defn if-alternative [exp]
  (if (< 3 (count exp))
    (nth exp 3)
    false))
(defn make-if [predicate consequence alternative]
  (list :if predicate consequence alternative))
(defn eval-if [exp env]
  (if (true? (eval (if-predicate exp) env))
    (eval (if-consequence exp) env)
    (eval (if-alternative exp) env)))

;;; Exercise 4.4
(defn and? [exp] (tagged-list? exp :and))
(defn and-conds [conds] (rest conds))
(defn empty-cond? [conds] (empty? conds))
(defn next-cond [conds] (first conds))
(defn rest-cond [conds] (rest conds))
(defn eval-and [conds env]
  (if (empty-cond? conds)
    true
    (and (true? (eval (next-cond conds) env)) (eval-and (rest-cond conds) env))))

(defn or? [exp] (tagged-list? exp :or))
(defn or-conds [conds] (rest conds))
(defn eval-or [conds env]
  (if (empty-cond? conds)
    false
    (or (true? (eval (next-cond conds) env)) (eval-and (rest-cond conds) env))))

(defn begin? [exp]
  (tagged-list? exp :begin))
(defn begin-actions [exp]
  (rest exp))
(defn last-exp? [seq]
  (empty? (rest seq)))
(defn first-exp [seq]
  (first seq))
(defn rest-exps [seq]
  (rest seq))
(defn eval-sequence [exps env]
  (cond (last-exp? exps) (eval (first-exp exps) env)
        :else (do
                (eval (first-exp exps) env)
                (eval-sequence (rest-exps exps) env))))

(defn make-begin [seq] (list :begin seq))
;;; Cond uses this to make one expression from a sequence of exps
(defn sequence->exp [seq]
  (cond (empty? seq) seq
        (last-exp? seq) (first-exp seq)
        :else (make-begin seq)))

(defn cond? [exp]
  (tagged-list? exp :cond))
(defn cond-clauses [exp] (rest exp))
(defn cond-predicate [clause] (first clause))
(defn cond-actions [clause] (rest clause))
(defn cond-else-clause? [exp]
  (= (cond-predicate exp) :else))
;;; Exercise 4.5
(defn cond-extended? [exp]
  (= (second exp) :=>))
(defn cond-extended-actions [exp]
  (nth exp 2))
(defn expand-clauses [clauses]
  (if (empty? clauses)
    false
    (let [first (first clauses) rest (rest clauses)]
      (if (cond-else-clause? first)
        (if (empty? rest)
          (sequence->exp (cond-actions first))
          (throw (RuntimeException. (str "else clause isn't last"))))
        (make-if (cond-predicate first)
                 (if (cond-extended? first)
                   (list (cond-extended-actions first) (cond-predicate first))
                   (sequence->exp (cond-actions first)))
                 (expand-clauses rest))
        ))))
(defn cond->if [exp]
  (expand-clauses (cond-clauses exp)))

(defn application? [exp] (coll? exp))
(defn operator [exp] (first exp))
(defn operands [exp] (rest exp))
(defn no-operands? [ops] (empty? ops))
(defn first-operand [ops] (first ops))
(defn rest-operands [ops] (rest ops))
(defn list-of-values [exps env]
  (if (no-operands? exps)
    '()
    (cons (eval (first-operand exps) env)
          (list-of-values (rest-operands exps) env))))

;;; eval
(defn eval [exp env]
  (cond (self-evaluating? exp) exp
        (variable? exp) (lookup-variable-value exp env)
        (quoted? exp) (text-of-quotation exp)
        (assignment? exp) (eval-assignment exp env)
        (definition? exp) (eval-definition exp env)
        (if? exp) (eval-if exp env)
        (and? exp) (eval-and (and-conds exp) env)
        (or? exp) (eval-or (or-conds exp) env)
        (lambda? exp) (make-procedure (lambda-parameters exp)
                                      (lambda-body exp)
                                      env)
        (let? exp) (eval (let->combination exp) env)
        (begin? exp) (eval-sequence (begin-actions exp) env)
        (cond? exp) (eval (cond->if exp) env)
        (application? exp) (apply (eval (operator exp) env)
                                  (list-of-values (operands exp) env))
        :else (throw (RuntimeException. (str "Unknown expression type: " exp)))))

;;; apply
(defn apply [procedure arguments]
  (cond (primitive-procedure? procedure) (apply-primitive-procedure procedure arguments)
        (compound-procedure? procedure) (eval-sequence
                                         (procedure-body procedure)
                                         (extend-environment
                                          (procedure-parameters procedure)
                                          arguments
                                          (procedure-environment procedure)))
        :else (throw (RuntimeException. (str "Unknown procedure type: " procedure)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Tokenizer/Parser (NA)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn tokenize [input]
  (let [pos (atom 0)]
    (letfn [(peek-ch [] (if (nil? (get input @pos)) nil (str (get input @pos))))
            (next-ch [] (let [ch (peek-ch)]
                          (reset! pos (+ @pos 1))
                          ch))]
      (letfn [(next-chunk [] (let [ch (peek-ch)]
                               (cond
                                 (nil? ch) nil
                                 (or (= ch "(") (= ch ")") (= ch "\"") (= ch " ")) nil
                                 :else (do
                                         (next-ch)
                                         (str ch (next-chunk))))))
              (next-token [] (let [ch (next-ch)]
                               (cond
                                 (nil? ch) nil
                                 (or (= ch "(") (= ch ")") (= ch "\"") (= ch "'")) ch
                                 (= ch " ") (next-token)
                                 :else (str ch (next-chunk)))))]
        next-token))))

(defn parse [input]
  (let [tokens (tokenize input)]
    (letfn [(parse-string []
              (let [next (tokens)]
                (if (= next "\"")
                  nil
                  (str next (parse-string)))))
            (parse-symbol []
              (let [next (tokens)]
                (if (= next "(")
                  (list :quote (parse-main))
                  (list :quote (parse-num-or-kw next)))))
            (parse-num-or-kw [token]
              (if (number? (read-string token))
                (read-string token)
                (keyword token)))
            (parse-main []
              (let [token (tokens)]
                (cond
                  (nil? token) '()
                  (= token "(") (cons (parse-main) (parse-main))
                  (= token ")") '()
                  (= token "\"") (cons (parse-string) (parse-main))
                  (= token "'") (cons (parse-symbol) (parse-main))
                  :else (cons (parse-num-or-kw token) (parse-main)))))]
      (first (parse-main)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; REPL (ch.4.1.4)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn setup-environment []
  (let [initial-env (extend-environment (primitive-procedure-names)
                                        (primitive-procedure-objects)
                                        the-empty-environment)]
    (define-variable! :true true initial-env)
    (define-variable! :false false initial-env)
    initial-env))
(def the-global-environment (setup-environment))

(def input-prompt ";;; M-Eval input:")
(def output-prompt ";;; M-Eval value:")
(defn prompt-for-input [string]
  (println) (println string) (println))
(defn announce-output [string]
  (println) (println string) (println))
(defn user-print [object]
  (if (compound-procedure? object)
    (println (list :compound-procedure (procedure-parameters object) (procedure-body object)))
    (println object)))
(defn driver-loop []
  (prompt-for-input input-prompt)
  (letfn [(input [] (let [line (read-line)]
                      (if (= line "")
                        ""
                        (str line (input)))))]
    (let [output (eval (parse (input)) the-global-environment)]
    (announce-output output-prompt)
    (user-print output)))
  (driver-loop))

(defn -main [& args]
  (driver-loop))

ch4_1_test.clj

(ns sicp.ch4-1-test
  (:use [clojure.test :refer :all]
        [sicp.ch4-1 :refer :all]))

(deftest true-false-test
  (testing "true?"
    (is (true? true))
    (is (not (true? false)))
    (is (true? :abc)))
  (testing "false?"
    (is (false? false))
    (is (not (false? true)))
    (is (not (false? :abc)))))

(deftest primitive-procedures-test
  (testing "primitive-procedure?"
    (is (primitive-procedure? (list :primitive :test nil)))
    (is (not (primitive-procedure? (list :procedure :test nil)))))
  (testing "primitive-implementation"
    (is (= :test (primitive-implementation (list :primitive :test)))))
  (testing "primitive-procedures"
    (is (= :car (first (first primitive-procedures))))
    (is (= first (second (first primitive-procedures)))))
  (testing "primitive-procedures-names"
    (is (= :car (first (primitive-procedure-names)))))
  (testing "primitive-procedures-objects"
    (is (= (list :primitive first) (first (primitive-procedure-objects)))))
  (testing "apply-primitive-procedure"
    (is (= (list 1 2) (apply-primitive-procedure (list :primitive cons) (list 1 (list 2)))))))

(deftest procedures-test
  (testing "make-procedure"
    (is (= (list :procedure (list :v1) nil '()) (make-procedure (list :v1) nil '()))))
  (testing "compound-procedure?"
    (is (compound-procedure? (list :procedure :params :body :env)))
    (is (not (compound-procedure? (list :primitive :params :body :env)))))
  (testing "procedure-parameters"
    (is (= :params (procedure-parameters (list :procedure :params :body :env)))))
  (testing "procedure-body"
    (is (= :body (procedure-body (list :procedure :params :body :env)))))
  (testing "procedure-environment"
    (is (= :env (procedure-environment (list :procedure :params :body :env))))))
  
(deftest environments-test
  (testing "enclosing-environment"
    (is (= (list :e2) (enclosing-environment (list :e1 :e2)))))
  (testing "first-frame"
    (is (= :e1 (first-frame (list :e1 :e2)))))
  (testing "the-empty-environment"
    (is (= '() the-empty-environment)))
  (testing "make-frame"
    (is (= :var1 (first (first @(make-frame (list :var1) (list :val1))))))
    (is (= :val1 @(first (second @(make-frame (list :var1) (list :val1)))))))
  (testing "frame-variables"
    (is (= (list :var1) (frame-variables (make-frame (list :var1) (list :val1))))))
  (testing "frame-values"
    (is (= :val1 @(first (frame-values (make-frame (list :var1) (list :val1)))))))
  (testing "add-binding-to-frame!"
    (let [frame (make-frame (list :var1) (list :val1))]
      (add-binding-to-frame! :var2 :val2 frame)
      (is (= (list :var2 :var1) (frame-variables frame)))
      (is (= :val2 @(first (frame-values frame))))))
  (testing "extend-environment"
    (let [env (extend-environment (list :var1) (list :val1) (list (make-frame (list :var2) (list :val2))))]
      (is (= (list :var1) (first @(first env))))
      (is (= (list :var2) (first @(second env))))))
  (testing "lookup-variable-value"
    (let [env (extend-environment (list :var1 :var3) (list :val1 :val3) (list (make-frame (list :var2) (list :val2))))]
      (is (= :val1 (lookup-variable-value :var1 env)))
      (is (= :val2 (lookup-variable-value :var2 env)))
      (is (= :val3 (lookup-variable-value :var3 env)))
      (is (thrown? RuntimeException (lookup-variable-value :undefined env)))))
  (testing "set-variable-value!"
    (let [env (extend-environment (list :var1) (list :val1) (list (make-frame (list :var2) (list :val2))))]
      (set-variable-value! :var1 :val3 env)
      (set-variable-value! :var2 :val4 env)
      (is (= :val3 (lookup-variable-value :var1 env)))
      (is (= :val4 (lookup-variable-value :var2 env)))
      (is (thrown? RuntimeException (set-variable-value! :undefined :v env)))))
  (testing "define-variable!"
    (let [env (list (make-frame (list :var1) (list :val1)))]
      (define-variable! :var2 :val2 env)
      (is (= :val2 (lookup-variable-value :var2 env)))
      (define-variable! :var1 :val3 env)
      (is (= :val3 (lookup-variable-value :var1 env))))))

(deftest eval-test
  (testing "self-evaluating?"
    (is (self-evaluating? 1))
    (is (self-evaluating? "a"))
    (is (not (self-evaluating? :a))))
  (testing "variable?"
    (is (variable? :a))
    (is (not (variable? "a"))))
  (testing "quoted?"
    (is (quoted? (list :quote nil)))
    (is (not (quoted? (list :not-quote)))))
  (testing "text-of-quotation"
    (is (= "a" (text-of-quotation (list :quote "a")))))
  (testing "assignment?"
    (is (assignment? (list :set!))))
  (testing "assignment-variable"
    (is (= :var (assignment-variable (list :set! :var :val)))))
  (testing "assignment-value"
    (is (= :val (assignment-value (list :set! :var :val)))))
  (testing "eval-assignment"
    (let [env (list (make-frame (list :var1 :var2) (list 1 2)))]
      (eval-assignment (list :set! :var1 3) env)
      (is (= 3 (lookup-variable-value :var1 env)))
      (eval-assignment (list :set! :var2 :var1) env)
      (is (= 3 (lookup-variable-value :var2 env)))
      (is (thrown? RuntimeException (eval-assignment (list :set! :var3 3) env)))))
  (testing "lambda?"
    (is (lambda? (list :lambda))))
  (testing "lambda-parameters"
    (is (= :params (lambda-parameters (list :lambda :params :body)))))
  (testing "lambda-body"
    (is (= :body (lambda-body (list :lambda :params :body)))))
  (testing "make-lambda"
    (is (= (list :lambda :params :body) (make-lambda :params :body))))
  (testing "definition?"
    (is (definition? (list :define))))
  (testing "definition-variable"
    (is (= :var1 (definition-variable (list :define :var1))))
    (is (=  :var1 (definition-variable (list :define (list :var1))))))
  (testing "definition-value"
    (is (= 1 (definition-value (list :define :var1 1))))
    (is (= (list :lambda (list :param) (list :body)) (definition-value (list :define (list :var1 :param) :body)))))
  (testing "eval-definition"
    (let [env (list (make-frame (list :var1) (list 1)))]
      (eval-definition (list :define :var2 2) env)
      (is (= 2 (lookup-variable-value :var2 env)))
      (eval-definition (list :define :var3 :var2) env)
      (is (= 2 (lookup-variable-value :var3 env)))))
  (testing "if?"
    (is (if? (list :if))))
  (testing "if-predicate"
    (is (= :pred (if-predicate (list :if :pred)))))
  (testing "if-consequence"
    (is (= :conseq (if-consequence (list :if :pred :conseq)))))
  (testing "if-alternative"
    (is (= :alt (if-alternative (list :if :pred :conseq :alt))))
    (is (= false (if-alternative (list :if :pred :conseq)))))
  (testing "make-if"
    (is (= (list :if :pred :conseq :alt) (make-if :pred :conseq :alt))))
  (testing "eval-if"
    (is (= 1 (eval-if (make-if 1 1 0) '())))
    (is (= 0 (eval-if (make-if :v1 1 0) (list (make-frame (list :v1) (list false)))))))
  (testing "begin?"
    (is (begin? (list :begin))))
  (testing "begin-actions"
    (is (= (list :action1) (begin-actions (list :begin :action1)))))
  (testing "last-exp?"
    (is (not (last-exp? (list :action1 :action2))))
    (is (last-exp? (list :action1))))
  (testing "first-exp"
    (is (= :action1 (first-exp (list :action1 :action2)))))
  (testing "rest-exps"
    (is (= (list :action2) (rest-exps (list :action1 :action2)))))
  (testing "eval-sequence"
    (is (= 3 (eval-sequence (list 0 1 2 3) '()))))
  (testing "make-begin"
    (is (= (list :begin (list 0 1)) (make-begin (list 0 1)))))
  (testing "sequence->exp"
    (is (= (list :begin (list 0 1)) (sequence->exp (list 0 1))))
    (is (= '() (sequence->exp '())))
    (is (= 0 (sequence->exp (list 0)))))
  (testing "cond?"
    (is (cond? (list :cond))))
  (testing "cond-clauses"
    (is (= (list :c1 :a1) (cond-clauses (list :cond :c1 :a1)))))
  (testing "cond-predicate"
    (is (= :c1 (cond-predicate (list :c1 :a1)))))
  (testing "cond-actions"
    (is (= (list :a1 :a2) (cond-actions (list :c1 :a1 :a2)))))
  (testing "cond-else-clause?"
    (is (cond-else-clause? (list :else :a1))))
  (testing "expand-clauses"
    (is (= (list :if :c1 :a1 false) (expand-clauses (list (list :c1 :a1)))))
    (is (= :a2 (expand-clauses (list (list :else :a2)))))
    (is (= (list :if :c1 :a1 :a2) (expand-clauses (list (list :c1 :a1) (list :else :a2)))))
    (is (= (list :if :c1 :a1 (list :if :c2 :a2 :a3)) (expand-clauses (list (list :c1 :a1) (list :c2 :a2) (list :else :a3)))))
    )
  (testing "cond->if"
    (is (= (list :if :c1 :a1 false) (cond->if (list :cond (list :c1 :a1))))))
  (testing "application?"
    (is (application? (list 1))))
  (testing "operator"
    (is (= :+ (operator (list :+ :1 :1)))))
  (testing "operands"
    (is (= (list :1 :1) (operands (list :+ :1 :1)))))
  (testing "no-operands?"
    (is (not (no-operands? (list :1 :1))))
    (is (no-operands? '())))
  (testing "first-operand"
    (is (= :1 (first-operand (list :1 :1)))))
  (testing "rest-operands"
    (is (= (list :1) (rest-operands (list :1 :1)))))
  (testing "list-of-values"
    (is (= (list 1 2) (list-of-values (list :var1 :var2) (list (make-frame (list :var1 :var2) (list 1 2)))))))
  (testing "eval"
    (let [env (list (make-frame (list :var1) (list 1)))]
      (is (= 1 (eval 1 env)))
      (is (= 1 (eval :var1 env)))
      (is (= :a (eval (list :quote :a) env)))
      ;; assignment
      (eval (list :set! :var1 2) env)
      (is (= 2 (eval :var1 env)))
      (eval (list :set! :var1 1) env)
      ;; define
      (eval (list :define :var2 2) env)
      (is (= 2 (eval :var2 env)))
      ;; if
      (eval (list :if 1 (list :set! :var1 2) :set! :var1 3) env)
      (is (= 2 (eval :var1 env)))
      (eval (list :set! :var1 1) env)
      ;; lambda
      (is (= (list :procedure :params :body env) (eval (list :lambda :params :body) env)))
      ;; begin
      (is (= 2 (eval (list :begin :var1 :var2) env)))
      ;; cond
      (is (= 2 (eval (list :cond (list :var1 :var2)) env)))
      ;; application
      (eval (list :define (list :f) (list :set! :var1 2)) env)
      (eval (list :f) env)
      (is (= 2 (eval :var1 env)))
      (eval (list :set! :var1 1) env)
      (is (thrown? RuntimeException (eval nil env)))
      )))

(deftest apply-test
  (testing "apply primitive proc"
    (is (= '(1 2) (apply (list :primitive cons) (list 1 '(2))))))
  (testing "apply compound proc"
    (is (= 1 (apply (list :procedure (list :var1) (list :var1) '()) (list 1))))
    (is (= 1 (apply (list :procedure (list :var1) (list (list :define :var2 :var1) :var2) '()) (list 1))))))

(deftest parse-and-eval-test
  (let [the-global-environment (setup-environment)]
    (letfn [(ev [input] (eval (parse input) the-global-environment))]
      (testing "self-eval"
        (is (= 1 (ev "1")))
        (is (= "str" (ev "\"str\""))))
      (testing "lookup-var"
        (ev "(define var1 1)")
        (is (= 1 (ev "var1"))))
      (testing "quoted"
        (is (= :sym (ev "'sym")))
        (is (= (list :a :b) (ev "'(a b)"))))
      (testing "assignment"
        (ev "(define var1 1)")
        (is (= 1 (ev "var1")))
        (ev "(set! var1 2)")
        (is (= 2 (ev "var1")))
        (ev "(define var2 var1)")
        (is (= 2 (ev "var2"))))
      (testing "if"
        (is (= :t (ev "(if true 't 'f)")))
        (is (= :f (ev "(if false 't 'f)"))))
      (testing "and"
        (is (ev "(and true 1 'a)"))
        (is (not (ev "(and true false)")))
        (is (ev "(and)")))
      (testing "or"
        (is (ev "(or true false)"))
        (is (not (ev "(or false false)")))
        (is (not (ev "(or)"))))
      (testing "lambda"
        (is (= :procedure (first (ev "(lambda (x) (* x x))"))))
        (is (= (list :x) (second (ev "(lambda (x) (* x x))"))))
        (is (= (list :* :x :x) (second (rest (ev "(lambda (x) (* x x))"))))))
      (testing "let"
        (is (= 3 (ev "(let ((v1 1) (v2 2)) (+ v1 v2))"))))
      (testing "begin"
        (ev "(define var1 1)")
        (ev "(define var2 1)")
        (ev "(begin (set! var1 2) (set! var2 2)")
        (is (= 2 (ev "var1")))
        (is (= 2 (ev "var2"))))
      (testing "cond"
        (is (= 1 (ev "(cond (false 0) (true 1))")))
        (is (= 2 (ev "(cond (false 0) (false 1) (else 2))"))))
      (testing "extended-cond"
        (is (= 2 (ev "(cond ((cdr '(1 2 3)) => car) (else false))")))
        (is (= 1 (ev "(cond (false => car) (else 1))"))))
      (testing "apply primitive"
        (is (= :a (ev "(car '(a b c))")))
        (is (= 1 (ev "(car '(1 2 3))")))
        (is (= (list :b :c) (ev "(cdr '(a b c))")))
        (is (= (list :a :b :c) (ev "(cons 'a '(b c))")))
        (is (= 3 (ev "(+ 1 2)")))
        (is (= 1 (ev "(- 2 1)")))
        (is (= 6 (ev "(* 2 3)")))
        (is (= 2 (ev "(/ 6 3)")))
        (is (= false (ev "(null? 'a)")))
        (is (= true (ev "(null? (cdr '(a)))"))))
      (testing "apply procedure"
        (ev "(define (append x y) (if (null? x) y (cons (car x) (append (cdr x) y))))")
        (is (= (list 1 2 3) (ev "(append '(1 2) '(3))")))
        (is (= (list :a :b :c) (ev "(append '(a b c) '())"))))
      )))