;; Written by Don Felgar, edited by Greg Pettyjohn
;;
;; Multiple-choice quiz PLT servlet sample.
;;
;;
;; Question sexp interface:
;; Questions = (listof intro-text (listof question))
;; intro-text = string explaining what test is about
;; question = (question-text choices correct-answer explanation)
;; question-text = string, the actual question
;; choices = (listof string), possible answers to the question
;; correct-answer = integer, index into choices
;;

;; Configuration
(define *data-file* "./english-measure-questions.ss")
(define *questions-per-quiz* 5)


(require (lib "unitsig.ss")
         (lib "servlet-sig.ss" "web-server")
         (lib "servlet-helpers.ss" "web-server")
         (lib "list.ss")
         (lib "etc.ss"))

(unit/sig () (import servlet^)

 ;; Accessors into question sexp's
 (define question-text car)
 (define question-choices cadr)
 (define question-answer caddr)
 (define question-explanation cadddr)

 (define quiz (load *data-file*))
 (define quiz-intro (car quiz))
 (define all-questions (cadr quiz))

 ;; ask-question: question number number -> (listof (cons symbol string))
 ;; Page for asking quiz question.
 ;; result contains a binding for 'answer
 (define (ask-question question-sexp question-number n-questions)
   (request-bindings
    (send/suspend
     (lambda (k-url)
       (let ((answer-num -1))
         `(html
           (head
            (title "Quiz Servlet")
            (body
             (p ,(format "Question ~A of ~A" (add1 question-number)
                         n-questions))
             (p ,(question-text question-sexp))
             (form ((method "post") (action ,k-url))
                   ,@(map (lambda (choice)
                            (set! answer-num (add1 answer-num))
                            `(p
                              ,(choice-descriptor answer-num) ". "
                              (input ((type "radio")
                                      (name "answer")
                                      (value ,(number->string
                                               answer-num))))
                              ,choice))
                          (cadr question-sexp))
                   (input ((type "submit")
                           (value "Next"))))))))))))

 ;; ((listof question-sexp) size) -> (listof question-sexp)
 ;; Choose a subset (without duplicates) of given size from a given list
 ;; assume subset-size <= (length questions)
 (define (random-question-set questions subset-size)
   (let choose-questions ([questions questions]
                          [chosen '()])
     (if (= (length chosen) subset-size)
       chosen
       (let ([qstn (list-ref questions (random (length questions)))])
         (choose-questions
          (filter
           (lambda (q)
             (not (eq? qstn q)))
           questions)
          (cons qstn chosen))))))

 ;; choice-descriptor: number -> character
 ;; Map 0 to "A", 1 to "B", etc
 (define (choice-descriptor number)
   (string (integer->char (+ (char->integer #\A) number))))

 ;; begin-quiz: -> request
 ;; request bindings are not currently used
 (define (begin-quiz)
   (send/suspend
    (lambda (k-url)
      `(html
        (head
         (title "Quiz Servlet"))
        (body
         (p ,quiz-intro)
         (form ((method "post") (action ,k-url))
               (input ((type "submit")
                       (value "Begin Quiz")))))))))

 ;; Compare list of questions to answers.
 ;; ((listof question-sexp) (listof integer|false)) -> (listof integer)
 (define (score-quiz questions answers)
   (foldr
    (lambda (question answer csw)
      (let ([correct-answer (question-answer question)])
        (apply
         (lambda (correct skipped wrong)
           (cond
            [(not answer)
             (list correct (add1 skipped) wrong)]
            [(= answer correct-answer)
             (list (add1 correct) skipped wrong)]
            [else
             (list correct skipped (add1 wrong))]))
         csw)))
    (list 0 0 0) questions answers))

 ;; end-quiz: (listof question) (listof (union number false)) -> request
 ;; request bindings are not currently used.
 (define (end-quiz questions answers)
   (send/forward
    (lambda (k-url)
      (let* ((score (score-quiz questions answers))
             (correct (car score))
             (skipped (cadr score))
             (wrong (caddr score))
             (xml
              `(html
                (head
                 (title "Quiz Servlet"))
                (body
                 (p ,(format "Your score: ~A/~A"
                             correct
                             (+ correct wrong skipped)))
                 (p ,(format "Correct: ~A" correct))
                 (p ,(format "Skipped: ~A" skipped))
                 (p ,(format "Wrong: ~A" wrong))
                 (table ((border "5"))
                        (tr (td "Question") (td "Correct Answer")
                            (td "Your Answer") (td "Explanation"))
                        ,@(map
                           (lambda (q a)
                             `(tr
                               (td ,(question-text q))
                               (td ,(format "~A. ~A"
                                            (choice-descriptor
                                             (question-answer q))
                                            (list-ref (question-choices q)
                                                      (question-answer q))))
                               (td ,(if a
                                      (format "~A. ~A" (choice-descriptor a)
                                              (list-ref
                                               (question-choices q) a))
                                      "Skipped"))
                               (td ,(question-explanation q))))
                           questions answers))
                 (form ((method "get")
                        (action ,k-url))
                       (input ((type "submit")
                               (value "New Quiz"))))))))
        xml))))

 ;; Return the first value for key in bindings, if it at least one
 ;; exists, otherwise #f.
 (define (binding-value key bindings)
   (and (exists-binding? key bindings)
        (extract-binding/single key bindings)))

 ;; run-quiz: -> void
 ;; run quizes until the student gets tired
 (define (run-quiz)
   (let ([*questions-per-quiz*
          (if (> *questions-per-quiz* (length all-questions))
            (begin
              (display (format "~A ~A ~A ~A\n"
                               "Configuration error.  *questions-per-quiz*:"
                               *questions-per-quiz*
                               "for a question list of size"
                               (length all-questions)))
              (length all-questions))
            *questions-per-quiz*)])

     (let ([questions (random-question-set all-questions
                                           *questions-per-quiz*)])
       (begin-quiz)
       (let ([answers
              (build-list (length questions)
                          (lambda (question-number)
                            (let ([answer
                                   (binding-value 'answer
                                                  (ask-question
                                                   (list-ref questions question-number)
                                                   question-number
                                                   *questions-per-quiz*))])
                              (and answer (string->number answer)))))])
         (end-quiz questions answers))))
   (run-quiz))

 ;; Entry point into servlet.
 (run-quiz)

 )