; file:        Eval1.scm
; author:      Robert Keller
; purpose:     Evaluator for a 2-valued logic language
; description: This defines the Eval function for a language that evaluates logic functions.
;              The current version has:
;                 constants: 1 for true, 0 for false
;                 variables: any symbol can be a variable
;                 functions: not is 1-ary
;                            and is arbitrary-arity
;                            or  is arbitrary-arity
;                 special forms: (let ( (var1 exp1) ... ) result)

(load "tester.scm")

; Eval is the top-level evaluation function.
; exp is an expression in the logic language
; env is the environment giving bindings for any variables
; Note case-sensitivity: eval is a Scheme built-in; Eval is our function.

(define (Eval exp env) 
	(if (list? exp)
            (Eval-composite exp env) ; e.g. (and 0 1)
	    (Eval-basic exp env)))   ; e.g. 0, 1, x


; Define logic constants and discriminators; avoid magic numbers in other code.

(define logic-true  1)
(define logic-false 0)

(define (true? x) (equal? logic-true x))
(define (false? x) (equal? logic-false x))
(define (constant? x) (or (true? x) (false? x)))
(define (variable? var) (symbol? var))


; This is the default base environment.

(define base ())


; Eval-basic evaluates expressions that are not lists.

(define (Eval-basic exp env)
   (cond
      ((constant? exp) exp)
      ((variable? exp) (get-value exp env))
      (else (Eval-error “unrecognized” exp))))


; Eval-composite evaluates expressions that are lists.

(define (Eval-composite exp env)
  (if (null? exp) 
      (Eval-error "empty list is meaningless" exp)
      (Eval-operator (first exp) (rest exp) env)))


; Eval-operator evaluates composite expressions 
; where the operator is the first thing in the list.
; actuals means the actual arguments of the expression.

(define (Eval-operator operator actuals env)
  (case operator
    ('not    (Eval-not    actuals env))
    ('and    (Eval-and    actuals env))
    ('or     (Eval-or     actuals env))
    ('let    (Eval-let    actuals env))
    ('lambda (Eval-lambda actuals env))
    (else 
     (let (
           (closure-value (Eval operator env))
           )
       (Eval-closure-application closure-value actuals env)))))


; Eval-not evaluates expressions of the form (not exp).

(define (Eval-not actuals env)
  (if (length1? actuals)
      (if (true? (Eval (first actuals) env))
          logic-false
          logic-true)
      (Eval-error "wrong arguments to not operator" actuals)))


; Eval-and evaluates expressions of the form (and exp1 exp2 ...).
; Any number of argument expressions is acceptable.
; If there are no arguments, the result is logic-true.
; Evaluation proceeds left-to-right, and stops when a logic-false occurs.

(define (Eval-and actuals env)
  (if (null? actuals)
      logic-true
      (if (true? (Eval (first actuals) env))
          (Eval-and (rest actuals) env)
          logic-false)))


; Eval-or evaluates expressions of the form (or exp1 exp2 ...).
; Any number of argument expressions is acceptable.
; If there are no arguments, the result is logic-false.
; Evaluation proceeds left-to-right, and stops when a logic-true occurs.

(define (Eval-or actuals env)
  (if (null? actuals)
      logic-false
      (if (false? (Eval (first actuals) env))
          (Eval-or (rest actuals) env)
          logic-true)))


; Eval-let evaluates a let construct, of the form (let ( (var1 exp1) ... ) result-expression).
; The value is that of result-expression, in the context of the given environment, 
; modified by layering bindings for var1 ... atop the existing environment.
; Note that the variables should not have duplicates.

(define (Eval-let actuals env)
  (if (length2? actuals)
      (let* (
             (equations (first actuals))
             (result-exp (second actuals))
             )
        (if (well-formed? equations)
            (let* (
                  (lhs-vars (map first equations))
                  (rhs-vals (map (lambda (eqn) (Eval (second eqn) env)) equations))
                  (new-env (add-bindings lhs-vars rhs-vals env))
                  )
              (Eval result-exp new-env))
            (Eval-error "error in equations of let" (cons 'let actuals))))
      (Eval-error "let construct must be a list of length two" (cons 'let actuals))))


; Eval-let evaluates a lambda construct. Two forms are possible:
;     (lambda (var ...) body) representing a "raw" function expression
;     (lambda (var ...) body environment) representing a "closure"
; The second case is self-evaluating.
; In the first case, the result is a closure representing the corresponding function.
; This is done by capturing the current environment in the result.

(define (Eval-lambda lambda-parts env)
  (case (length lambda-parts)
    
    ;; raw lambda expression
    ('2 (let* (
              (formals (first lambda-parts))
              (body (second  lambda-parts))
            )
        (list 'lambda formals body env)  ;; capture the environment
        ))
    
    ;; already-evaluated closure, leave as is
    ('3 (cons 'lambda lambda-parts))
    
    (else (Eval-error "error in lambda expression" (cons 'lambda lambda-parts)))))

; Eval-closure-application evaluates the application of a closure to some arguments.
; The other type of application is that of a built-in function, which is handled differently.
; When applying a closure, we form a new environment by adding to the static environment
; in the closure bindings of the formal arguments to their actuals.
; The body is evaluated in this new environment.

(define (Eval-closure-application closure actuals env)
  (let* (
        (actual-values (map (lambda (x) (Eval x env)) actuals))
        (formals (second closure))
        (body (third closure))
        (static-environment (fourth closure))
        (body-environment (add-bindings formals actual-values static-environment))
        )
    (Eval body body-environment)))


; get-value gets the value of a variable in the environment.

(define (get-value var env)
  (let (
        (found (assoc var env))
        )
    (if found
        (second found)
        (Eval-error "unbound variable" var))))


; add-bindings adds to the outer environment bindings that result
; from equating each var to a corresponding val.

(define (add-bindings vars vals env)
  (if (null? vars)
      env
      (add-bindings (rest vars) 
                    (rest vals) 
                    (cons (list (first vars) (first vals)) env))))

; well-formed? checks that the equations part of a let 
; is as it should be.

(define (well-formed? equations)
  (and
   (each? length2? equations)
   (unique-symbols? (map first equations))))


; unique-symbols? checks that the list of vars does not contain duplicates.

(define (unique-symbols? vars)
  (and
   (foldr (lambda (x y) (and x y)) #t (map symbol? vars))
   (no-duplicates? (sort vars symbol<?))))


; symbol<? compares two symbols alphabetically for sorting.

(define (symbol<? x y)
  (string<? (symbol->string x) (symbol->string y)))


; no-duplicates? checks that a sorted-list of symbols does not have duplicates.

(define (no-duplicates? sorted-list)
  (or
   (null? sorted-list)
   (null? (rest sorted-list))
   (and (not (equal? (first sorted-list) (second sorted-list)))
        (no-duplicates? (rest sorted-list)))))


; (each? P L) checks whether each element in a list L satisfies predicate P.
   
(define (each? P L)
  (if (null? L)
      #t
      (and (P (first L)) (each? P (rest L)))))
             

; Eval-error is an interface for error messages.
; Currently it just calls the built-in error function, which throws an exception, 
; printing a message, then stopping.

(define (Eval-error msg exp)
  (error msg exp))


; length1? is true just when its argument is a list of one element.

(define (length1? x)
  (and (list? x) (not (null? x)) (null? (rest x))))


; length2? is true just when its argument is a list of two elements.

(define (length2? x)
  (and (list? x) (not (null? x)) (not (null? (rest x))) (null? (rest (rest x)))))

; Here are our test cases so far.


(test (Eval 0 base) logic-false)
(test (Eval 1 base) logic-true)

(test (Eval '(not 0) base) logic-true)
(test (Eval '(not 1) base) logic-false)

(test (Eval '(and 0 0) base) logic-false)
(test (Eval '(and 0 1) base) logic-false)
(test (Eval '(and 1 0) base) logic-false)
(test (Eval '(and 1 1) base) logic-true)

(test (Eval '(or 0 0) base) logic-false)
(test (Eval '(or 0 1) base) logic-true)
(test (Eval '(or 1 0) base) logic-true)
(test (Eval '(or 1 1) base) logic-true)

(test (Eval '(not (not 0)) base) logic-false)
(test (Eval '(not (not 1)) base) logic-true)
(test (Eval '(not (not (not 0))) base) logic-true)
(test (Eval '(not (not (not 1))) base) logic-false)

(test (Eval '(and (not 0) (not 0)) base) logic-true)
(test (Eval '(and (not 0) (not 1)) base) logic-false)
(test (Eval '(and (not 1) (not 0)) base) logic-false)
(test (Eval '(and (not 1) (not 1)) base) logic-false)

(test (Eval 'x '((x 0))) logic-false)
(test (Eval 'y '((x 0) (y 1))) logic-true)
(test (Eval '(not x) '((x 0) (y 1))) logic-true)
(test (Eval '(not y) '((x 0) (y 1))) logic-false)

(test (Eval '(let ((x 0)) x) base) logic-false)
(test (Eval '(let ((x 0) (y 1)) y) base) logic-true)

(test (Eval '(let ((x 0)) (not x)) base) logic-true)
(test (Eval '(let ((x 0) (y 1)) (not y)) base) logic-false)
(test (Eval '(let ((x 0) (y 1)) (and x y)) base) logic-false)
(test (Eval '(let ((x 0) (y 1)) (or x y)) base) logic-true)
(test (Eval '(let ((x 0) (y 1)) 
               (let ((u (and x y)) (v (or x y))) 
                 (and (not u) v))) base) logic-true)

(test (Eval '(lambda (x y) (or x y)) ()) '(lambda (x y) (or x y) ()))
(test (Eval '(lambda (x y) (or x y)) '((b 1))) '(lambda (x y) (or x y) ((b 1))))
(test (Eval '(let ((f (lambda (x y) (or x y)))) (f 0 1)) ()) logic-true)
(test (Eval '(let ((b 1)) (let ((f (lambda (x) (or b x)))) (f 0))) ()) logic-true)
(test (Eval '(let ((f (lambda(x) (or x 1)))) (let ((g f)) (g 0))) ()) logic-true)
(test (Eval '(let ((b 1)) (let ((f (lambda (x) (or b x)))) (f (and 0 (or 1 0))))) ()) logic-true)


(tester 'show)

; Read-Eval-Print Loop

;; Prompt the user to enter an expression.

(define (prompt)
  (newline)
  (display "> "))

;Loop without error handler

(define (simple-read-eval-print)
  (begin
    (prompt)
    (let (
          (expression (read))
          )
      (if (eof-object? expression)
          expression
          (begin
           (print (Eval expression ()))
           (simple-read-eval-print)
           ))
      )
    ))

;Loop with error handler

;; Define error handler

(define (error-handler x)
  (display (list "*** error:"  x)))

(define (read-eval-print)
  (begin
    (prompt)
    (let (
          (expression (read))
          ) 
      (if (eof-object? expression)
          expression
          (begin
           (with-handlers (((lambda(x) #t) error-handler))
             (print (Eval expression ())))
           (read-eval-print)
           )
          )
      )
    ))