206 lines
7.5 KiB
Racket
206 lines
7.5 KiB
Racket
#lang racket
|
|
;; Written by Don Felgar, edited by Greg Pettyjohn
|
|
;;
|
|
;; Multiple-choice quiz Racket 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
|
|
(require racket/runtime-path)
|
|
(define-runtime-path *data-file*
|
|
(list 'lib
|
|
"web-server/default-web-root/htdocs/servlets/examples/english-measure-questions.rkt"))
|
|
(define *questions-per-quiz* 5)
|
|
|
|
(require web-server/servlet
|
|
mzlib/list
|
|
mzlib/etc)
|
|
|
|
(provide (all-defined-out))
|
|
(define interface-version 'v1)
|
|
(define timeout +inf.0)
|
|
|
|
;; Accessors into question sexp's
|
|
(define question-text car)
|
|
(define question-choices cadr)
|
|
(define question-answer caddr)
|
|
(define question-explanation cadddr)
|
|
|
|
(define quiz (file->value *data-file*))
|
|
(define quiz-intro (first quiz))
|
|
(define all-questions (second 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 (or/c 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.
|
|
(define (start initial-request)
|
|
(run-quiz))
|