;;; Automatic Grader for Scheme Procedures
;;; by Ron Mak

(define count-of-tests 0)
(define count-of-errors 0)

;;;
;;; Testing procedures
;;;

;;; Main procedure
;;; Enter (test-all) to test all procedures of Assignment #2.
(define test-all
  (lambda ()
    (begin
      (set! count-of-tests 0)
      (set! count-of-errors 0)
      (run-test 1)
      (run-test 2)
      (run-test 3)
      (run-test 4)
      (run-test 5)
      (display-score)
)))

;;; Run a test, given its number and name.
(define run-test
  (lambda (test-number)
    ((eval (string->symbol (string-append "test-" 
                                         (number->string test-number)))))
))

;;; The flag which is sent to the continuation 
;;; whenever an exception is raised by a test procedure.
(define exception-flag '!!!)

;;; Run procedure test-proc under an exception handler.
(define try
  (lambda (test-proc)
    (call/cc
      (lambda (continuation)  ; Capture the continuation of test-proc.
        (with-exception-handler
          (lambda (except)  ; The exception handler.
            (if (or (error? except) (violation? except)) 
              (continuation exception-flag)  ; Whenever an exception is raised,
              (raise except)))               ;   the continuation gets the flag.
          test-proc))  ; Run procedure test-proc.
)))        

;;; Dynamically generate a test procedure from its name and argument list.
;;; Example: (make-test-proc myproc '(a b c)) 
;;;              ==> (lambda () (apply myproc '(a b c)))        
(define make-test-proc
  (lambda (proc-name arg-list)
    (eval (list 'lambda '() (list 'apply proc-name (list 'quote arg-list))))
))

;;; Test the procedure named proc-name with arguments arg-list
;;; and compare the result to correct-result.
(define test
  (lambda (proc-name arg-list correct-result)
    (begin
      (set! count-of-tests (add1 count-of-tests))
      
      ; Display a call to the test procedure as a standard list expression.
      (write-char #\()
      (write proc-name)
      (display " '")
      (write (car arg-list))
      (write-char #\ )
      (write (cadr arg-list))
      (write-char #\))
      (newline)
      (display "    ==> ")
      
      ; Call the test procedure under an exception handler.
      (let ((test-result (try (make-test-proc proc-name arg-list))))
        (begin
          (write test-result)
          (if (equal? test-result correct-result)  ; Check the result.
              (display " CORRECT")  ; Correct result.
              (begin  ; Either an incorrect result or an exception was raised.
                (set! count-of-errors (add1 count-of-errors))
                (display (if (equal? test-result exception-flag)
                             " *** EXCEPTION: should be: "
                             " *** ERROR: should be: "))
                (write correct-result))))
        (newline)))
))

;;;
;;; Display procedures
;;;

;;; Display the members of a list '(a b c) individually as 'a 'b 'c
(define write-quote
  (lambda (lst)
    (if (not (null? lst))
        (begin
          (write-char #\')
          (write (car lst))
          (if (not (null? (cdr lst))) (write-char #\ ))
          (write-quote (cdr lst))))
))

;;; Display a header for a test, given its number and name.
(define display-test
  (lambda (number f)
    (begin
      (newline)
      (display "===== ")
      (display number)
      (display " =====")
      (newline)
      (display " f(x) = ")
      (display f)
      (newline)
      (display "f'(x) = ")
      (display (deriv f 'x))
      (newline)
      (newline)
)))

;;; Display the number of errors and the score.
(define display-score
  (lambda ()
    (begin
      (newline)
      (display "=====================================")
      (newline)
      (display count-of-errors);
      (display " errors out of ")
      (display count-of-tests)
      (display " tests. SCORE: ")
      (display (round (* (/ 100 count-of-tests) (- count-of-tests count-of-errors))))
      (newline)
      (display "=====================================")
      (newline)
)))

;;;
;;; Tests for Assignment #3
;;;

(define a 1)
(define b 1)
(define c 2)
(define d 3)

;;;;; 1

;;;  f(x) = 2x + 7   f(0) = 7   f(1) = 9
;;; f'(x) = 2       f'(0) = 2  f'(1) = 2

(define test-1
  (lambda ()
    (let ((f '(2 x + 7)))
      (begin
        (display-test 1 f)
        (test 'evaluate (cons f '(0)) 7)
        (test 'evaluate (cons f '(1)) 9)
        (test 'evaluate-deriv (cons f '(0)) 2)
        (test 'evaluate-deriv (cons f '(1)) 2)
))))

;;;;; 2

;;;  f(x) = 3x^2   f(0) = 0   f(1) = 3
;;; f'(x) = 6x    f'(0) = 0  f'(1) = 6

(define test-2
  (lambda ()
    (let ((f '(3 x ^ 2)))
      (begin
        (display-test 2 f)
        (test 'evaluate (cons f '(0)) 0)
        (test 'evaluate (cons f '(1)) 3)
        (test 'evaluate-deriv (cons f '(0)) 0)
        (test 'evaluate-deriv (cons f '(1)) 6)
))))

;;;;; 3

;;;  f(x) =  5ax^3 + 4bx^2 + 1   f(0) = 1   f(2) = 57
;;; f'(x) = 15ax^2 + 8bx        f'(0) = 0  f'(2) = 76

(define test-3
  (lambda ()
    (let ((f '(5 a x ^ 3 + 4 b x ^ 2 + 1)))
      (begin
        (display-test 3 f)
        (test 'evaluate (cons f '(0)) 1)
        (test 'evaluate (cons f '(2)) 57)
        (test 'evaluate-deriv (cons f '(0)) 0)
        (test 'evaluate-deriv (cons f '(2)) 76)
))))

;;;;; 4

;;;  f(x) =  ax^5 +  bx^4 + 2x^3 +  6x^2 + 3x + 7   f(0) = 7   f(1) = 20
;;; f'(x) = 5ax^4 + 4bx^3 + 6x^2 + 12x   + 3       f'(0) = 3  f'(1) = 30

(define test-4
  (lambda ()
    (let ((f '(a x ^ 5 + b x ^ 4 + 2 x ^ 3 + 6 x ^ 2 + 3 x + 7)))
      (begin
        (display-test 4 f)
        (test 'evaluate (cons f '(0)) 7)
        (test 'evaluate (cons f '(1)) 20)
        (test 'evaluate-deriv (cons f '(0)) 3)
        (test 'evaluate-deriv (cons f '(1)) 30)
))))

;;;;; 5

;;;  f(x) =   2ax^6 +  3bx^5 + 2cx^3 + dx + 4   f(0) = 4   f(2) = 266
;;; f'(x) =  12ax^5 + 15bx^4 + 6cx^2 + d       f'(0) = 3  f'(2) = 675

(define test-5
  (lambda ()
    (let ((f '(2 a x ^ 6 + 3 b x ^ 5 + 2 c x ^ 3 + d x + 4)))
      (begin
        (display-test 5 f)
        (test 'evaluate (cons f '(0)) 4)
        (test 'evaluate (cons f '(2)) 266)
        (test 'evaluate-deriv (cons f '(0)) 3)
        (test 'evaluate-deriv (cons f '(2)) 675)
))))