;;; File:
;;;   grading.scm
;;; Author:
;;;   Samuel A. Rebelsky
;;; Summary:
;;;   A variety of procedures to help grade students, relying primarily
;;;   on my standard format for recording grades.
;;; Usage:
;;;   1. Save your grades into a file.
;;;   2. Load this program.
;;;   3. Type (grade filename)
;;; File Format:
;;;   Each line has the form
;;;     LastName,Thing,Grade,Notes
;;; Disclaimer:
;;;   The documentation here is evolving.

; +--------------------+----------------------------------------------
; | Primary Procedures |
; +--------------------+

(define grade
  (lambda (fname)
    (let ((student (make-student))
          (grades (read-lines fname)))
      (map (lambda (line) (process-grade line student)) grades)
      (display-student student))))

(define process-grade
  (lambda (line student)
    (let ((components (split-string line ",")))
      ; (display-line "Processing '" line "'")
      (cond
        ((or (starts-with "exam" (cadr components))
             (starts-with "final" (cadr components)))
         (student ':add-exam! (string->number (caddr components))))
        ((starts-with "hw" (cadr components))
         (student ':add-homework! (string->symgrade (caddr components))))
        ((starts-with "project" (cadr components))
         (student ':add-project! (caddr components)))
        ((or (starts-with "extra" (cadr components))
             (starts-with "ec" (cadr components)))
         (student ':add-ec! (caddr components)))
        ((string-ci=? "participation" (cadr components))
         (student ':set-participation! (string->number (caddr components))))
        ((or (starts-with "numeric" (cadr components))
             (starts-with "letter" (cadr components)))
         (display "Skipping numeric or letter grade.") (newline))
        (else
         (display-line "Error!  Cannot process '" line "'"))))))

; +---------------------+---------------------------------------------
; | String Manipulation |
; +---------------------+

(define starts-with 
  (lambda (pattern str)
    (let ((patlen (string-length pattern)))
      (and (>= (string-length str) patlen)
           (string-ci=? pattern (substring str 0 patlen))))))

(define split-string
  (lambda (str sep)
    (let ((seplen (string-length sep))
          (len (string-length str)))
      (let kernel ((start 0)
                   (pos 0))
        (cond
          ((> (+ seplen pos) len)
           (list (substring str start len)))
          ((string=? sep (substring str pos (+ pos seplen)))
           (cons (substring str start pos)
                 (kernel (+ pos seplen) (+ pos seplen))))
          (else (kernel start (+ pos 1))))))))

; +-----------------+-------------------------------------------------
; | Student Objects |
; +-----------------+

(define make-student
  (lambda ()
    (let ((set-field! (lambda (field val) (vector-set! field 0 val)))
          (get-field (lambda (field) (vector-ref field 0))))
      (let ((homework (vector null))
            (exams (vector null))
            (projects (vector null))
            (participation (vector 0))
            (ec (vector null)))
        (lambda (message . params)
          (cond
            ((eq? message ':type)
             'student)
            ((eq? message ':->string)
             "#<student>")
            ((eq? message ':get-homework)
             (get-field homework))
            ((eq? message ':get-exams)
             (get-field exams))
            ((eq? message ':get-projects)
             (get-field projects))
            ((eq? message ':get-participation)
             (get-field participation))
            ((eq? message ':get-ec)
             (get-field ec))
            ((eq? message ':set-participation!)
             (set-field! participation (car params)))
            ((eq? message ':add-homework!)
             (set-field! homework
                         (append (get-field homework)
                                 params)))
            ((eq? message ':add-exam!)
             (set-field! exams
                         (append (get-field exams)
                                 params)))
            ((eq? message ':add-project!)
             (set-field! projects
                         (append (get-field projects)
                                 params)))
            ((eq? message ':add-ec!)
             (set-field! ec
                        (append (get-field ec)
                                params)))
            (else
             (error "#<student>: invalid message"))))))))

; +-----------------+-------------------------------------------------
; | Grading Helpers |
; +-----------------+

(define count-student-ec
  (lambda (student)
    (length (student ':get-ec))))

(define numgrade->letter
  (lambda (numgrade)
    (cond
      ((>= numgrade 94) "A")
      ((>= numgrade 90) "A-")
      ((>= numgrade 87) "B+")
      ((>= numgrade 84) "B")
      ((>= numgrade 80) "B-")
      ((>= numgrade 77) "C+")
      ((>= numgrade 70) "C")
      ((>= numgrade 60) "D")
      (else "F"))))

(define string->symgrade
  (lambda (str)
    (cond
      ((string-ci=? str "Plus") 'plus)
      ((string-ci=? str "Check Plus") 'check-plus)
      ((string-ci=? str "Check") 'check)
      ((string-ci=? str "Check Minus") 'check-minus)
      ((string-ci=? str "Minus") 'minus)
      ((string-ci=? str "Zero") 'zero)
      ((string-ci=? str "0") 'zero)
      (else (error (string-append "Invalid grade: " str))))))

(define symgrade->number
  (lambda (sym)
    (cond
      ((eq? sym 'plus) 120)
      ((eq? sym 'check-plus) 95)
      ((eq? sym 'check) 85)
      ((eq? sym 'check-minus) 80)
      ((eq? sym 'minus) 75)
      (else 0))))

(define letgrade->number
  (lambda (letter)
    (cond
      ((equal? letter "A+") 100)
      ((equal? letter "A") 96)
      ((equal? letter "A-") 92)
      ((equal? letter "B+") 88)
      ((equal? letter "B") 85)
      ((equal? letter "B-") 82)
      ((equal? letter "C+") 78)
      ((equal? letter "C") 75)
      ((equal? letter "D") 65)
      ((equal? letter "F") 50)
      (else 0))))

(define evaluate-student-homework
  (lambda (student)
    (let ((homework (student ':get-homework)))
      (cond
        ((null? homework) 0)
        ((null? (cdr homework)) (symgrade->number (car homework)))
        (else
         (average (remove-smallest (map symgrade->number homework))))))))

(define evaluate-student-projects
  (lambda (student)
    (let ((projects (student ':get-projects)))
      (if (null? projects) 0
          (average (map letgrade->number projects))))))

(define evaluate-student-exams
  (lambda (student)
    (let ((exams (student ':get-exams)))
      (cond
        ((null? exams) 0)
        ((null? (cdr exams)) (car exams))
        (else
         (average (remove-smallest exams)))))))

(define compute-grade
  (lambda (student)
    (+ (* .15 (student ':get-participation))
       (* .25 (evaluate-student-homework student))
       (* .45 (evaluate-student-exams student))
       (* .15 (evaluate-student-projects student))
       (* .5 (min 6 (count-student-ec student))))))


; +---------------------+---------------------------------------------
; | Input |
; +---------------------+

(define eol-char?
  (lambda (ch)
    (let ((eol-char (string-ref "\n" 0)))
      (eq? ch eol-char))))

;;; Procedure:
;;;   read-line
;;; Parameters:
;;;   input-port, an input port
;;; Purpose:
;;;   Reads one line from the input port.
;;; Produces:
;;;   line, a string.
;;; Preconditions:
;;;   input-port is open for reading.
;;; Postconditions:
;;;   One line has been read.
(define read-line
  (let ((cr (string-ref "\r" 0)))
    ; The kernel reads a list of characters until hitting the newline.
    (letrec ((kernel
              (lambda (input-port)
                (let ((ch (read-char input-port)))
                  (cond
                    ; At the end of line, there are no more characters.
                    ((or (eof-object? ch) (eol-char? ch))
                     null)
                    ; Drop carriage returns.  (Macs and PCs tend to insert
                    ; them before newlines.)
                    ((eq? ch cr) (kernel input-port))
                    (else (cons ch (kernel input-port))))))))
      (lambda (input-port)
        (list->string (kernel input-port))))))

;;; Procedure:
;;;   read-lines
;;; Parameters:
;;;   fname, a string
;;; Purpose:
;;;   Reads all the lines from the file.
;;; Produces:
;;;   lines, a list of strings string.
;;; Preconditions:
;;;   fname names a readable file.
;;; Postconditions:
;;;   (list-ref lines i) represents line i of file fname.
(define read-lines
  (letrec ((kernel 
            (lambda (input-port)
              (if (eof-object? (peek-char input-port))
                  (begin
                    (close-input-port input-port)
                    null)
                  (cons (read-line input-port)
                        (kernel input-port))))))
    (lambda (fname)
      (kernel (open-input-file fname)))))

; +---------------------+---------------------------------------------
; | Output |
; +---------------------+

;;; Procedure:
;;;   display-category
;;; Parameters:
;;;   category, a string
;;;   lst, a list
;;; Purpose:
;;;   Display all the values for a particular category.
(define display-category
  (lambda (cat lst)
    (letrec ((kernel
              (lambda (lst)
                (if (null? (cdr lst))
                    (begin
                      (display (car lst))
                      (newline))
                    (begin
                      (display (car lst))
                      (display ", ")
                      (kernel (cdr lst)))))))
      (if (null? lst)
          (display-line "No " cat ".")
          (begin
            (display cat)
            (display ": ")
            (kernel lst))))))

;;; Procedure:
;;;   display-line
;;; Parameters:
;;;   val0, val2, ... valn: 0 or more values.
;;; Purpose:
;;;   Displays all of the values, followed by a carriage return.
(define display-line
  (letrec ((kernel
            (lambda (remaining)
              (if (null? remaining)
                  (newline)
                  (begin
                    (display (car remaining))
                    (kernel (cdr remaining)))))))
    (lambda vals
      (kernel vals))))

;;; Procedure:
;;;   display-student
;;; Parameters:
;;;   student, a student
;;; Purpose:
;;;   Print out information on the student.
;;; Produces:
;;;   Nothing; called for the side effect.
(define display-student
  (lambda (student)
    (let ((numgrade (compute-grade student)))
      (display-line "Grade Record")
      (display-category "  Homework" (student ':get-homework))
      (display-category "  Exams" (student ':get-exams))
      (display-category "  Projects" (student ':get-projects))
      (display-line "  Participation: " (student ':get-participation))
      (display-category "  Extra Credit" (student ':get-ec))
      (display-line "Numeric Grade: " numgrade)
      (display-line "Likely Letter Grade: " (numgrade->letter numgrade)))))

; +------------+------------------------------------------------------
; | Arithmetic |
; +------------+

;;; Purpose:
;;;   remove-smallest
;;; Parameters:
;;;   nums, a list of real numbers
;;; Purpose:
;;;   Removes the smallest value in nums.
;;; Produces:
;;;   newnums, a list of real numbers.
;;; Preconditions:
;;;   nums is nonempty.
;;; Postconditions:
;;;   newnums is a permutation of (cons (smallest nums) nums)
(define remove-smallest
  (lambda (nums)
    (let kernel ((remaining (cdr nums))
                 (smallest-so-far (car nums)))
      (cond
        ((null? remaining)
         null)
        ((< (car remaining) smallest-so-far)
         (cons smallest-so-far 
               (kernel (cdr remaining) (car remaining))))
        (else 
         (cons (car remaining)
               (kernel (cdr remaining) smallest-so-far)))))))

(define average
  (lambda (nums)
    (/ (apply + nums) (length nums))))