;;; 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 'nest)
      (run-test  2 'alternate)
      (run-test  3 'all-same?)
      (run-test  4 'remove-leading)
      (run-test  5 'subst-first)
      (run-test  6 'translate)
      (run-test  7 'sandwich-first)
      (run-test  8 'count)
      (run-test  9 'union)
      (run-test 10 'intersect)
      (display-score)
)))

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

;;; 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)
      (write-char #\ )
      (write-quote 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 testname)
    (begin
      (newline)
      (display "===== ")
      (display number)
      (display " ")
      (display testname)
      (display " =====")
      (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 #2
;;;

;;;;; 1

(define test-nest
  (lambda ()
    (begin
      (test 'nest '(0) '())
      (test 'nest '(1) '(()))
      (test 'nest '(3) '(((()))))
)))

;;;;; 2

(define test-alternate
  (lambda ()
    (begin
      (test 'alternate '(()) '())
      (test 'alternate '((1)) '(1))
      (test 'alternate '((1 2)) '(1))
      (test 'alternate '((1 2 3)) '(1 3))
      (test 'alternate '((1 2 3 4)) '(1 3))
      (test 'alternate '((1 2 3 4 5)) '(1 3 5))
      (test 'alternate '((a (b c) (d (e f)) g '() 1 "two" 3 4)) 
                       '(a (d (e f)) '() "two" 4))
)))

;;;;; 3

(define test-all-same?
  (lambda ()
    (begin
      (test 'all-same? '(()) #t)
      (test 'all-same? '((1)) #t)
      (test 'all-same? '((1 1 1 1 1)) #t)
      (test 'all-same? '((1 1 1 2 1)) #f)
      (test 'all-same? '(((a b) (a b) (a b))) #t)
      (test 'all-same? '(((a b) (a b) (a a))) #f)
)))

;;;;; 4

(define test-remove-leading
  (lambda ()
    (begin
      (test 'remove-leading '(x ()) '())
      (test 'remove-leading '(x (a b c x y z)) '(x y z))
      (test 'remove-leading '(x (a b c)) '())
      (test 'remove-leading '((p q) (a (p q) b (p q) c)) '((p q) b (p q) c))
)))

;;;;; 5

(define test-subst-first
  (lambda ()
    (begin
      (test 'subst-first '(dog mouse ()) '())
      (test 'subst-first '(dog cat   (my cat is smart)) '(my dog is smart))
      (test 'subst-first '(dog mouse (my cat is smart)) '(my cat is smart))
      (test 'subst-first '(x (a (b (c))) (a b ((a (b (c)))) d (a (b (c))) e (a (b (c)))))
                         '(a b ((a (b (c)))) d x e (a (b (c)))))
)))

;;;;; 6

(define test-translate
  (lambda ()
    (begin
      (test 'translate '(mouse ()) '())
      (test 'translate '(cat ((dog chien) (cat chat))) 'chat)
      (test 'translate '(chair ((table desk) (chair stool) (lamp light))) 'stool)
      (test 'translate '(maison ((maison house) (house maison) (mansion casa))) 'house)
)))

;;;;; 7

(define test-sandwich-first
  (lambda ()
    (begin
      (test 'sandwich-first '(meat bread ()) '())
      (test 'sandwich-first '(meat bread (bread bread)) '(bread meat bread))
      (test 'sandwich-first '(meat bread (bread)) '(bread))
      (test 'sandwich-first '(meat bread (bread cheese bread bread)) 
                            '(bread cheese bread meat bread))
      (test 'sandwich-first '(meat bread (bread cheese bread bread pickle bread bread)) 
                            '(bread cheese bread meat bread pickle bread bread))
      (test 'sandwich-first '(meat bread (bread cheese bread pickle bread)) 
                            '(bread cheese bread pickle bread))
)))

;;;;; 8

(define test-count
  (lambda ()
    (begin
      (test 'count '(x ()) 0)
      (test 'count '(x (a b x c x x d)) 3)
      (test 'count '(x (a b c d e f)) 0)
      (test 'count '((p q) (a (p q) (b ((p q) c)) d)) 2)
)))

;;;;; 9

(define test-union
  (lambda ()
    (begin
      (test 'union '(() ()) '())
      (test 'union '((a b c) ()) '(a b c))
      (test 'union '(() (a b c)) '(a b c))
      (test 'union '((a b (c)) (b (c) d)) '(a b (c) d))
      (test 'union '((a a a) (a a a a a)) '(a))
)))

;;;;; 10

(define test-intersect
  (lambda ()
    (begin
      (test 'intersect '(() ()) '())
      (test 'intersect '((a b c) ()) '())
      (test 'intersect '(() (a b c)) '())
      (test 'intersect '((a b (c)) (a (c) d)) '(a (c)))
      (test 'intersect '((a b b c) (b c c d)) '(b c))
      (test 'intersect '((a b c) ((c) d e)) '())
      (test 'intersect '((a a a) (a a a a a)) '(a))
)))