; vim:set ai lisp sm mat=2 sw=2:
; $Id: prefix.ss,v 1.9 2005/05/30 20:09:53 jteach Exp $
(module prefix mzscheme
  (require (lib "servlet.ss" "web-server")
           (lib "xml.ss" "xml")
           ;; for build-list
           (lib "etc.ss")   
           (lib "list.ss")
           (prefix srfi: (lib "19.ss" "srfi"))
           ;; For prefix->infix, generate-expression, and equivalent-exprs?:
           "lib/mjadud/prefix-infix.ss"
           "lib/decimals.ss")
  (provide (all-defined))
  
  (define LOGFILE #f)
  
  (define interface-version 'v1)
  (define timeout (* 60 5))   ;; 5-minute timeout.
  
  ;;;; Helper functions for making the web pages.
  
  ;; -> xexpr
  ;; provides the stylesheet
  (define (stylesheet)
    `(style [(type "text/css")]
            "
td.problemcell {
        height: 72px;
        background-color: white;
        color: black;
        border: thin solid green;
        font-family: Courier;
        text-align: right;
        padding: 10px;
}

form {
        margin: 1cm;
}

h1 {    color: red;
        text-align: center;
}
body {  background-color: #c0c0c0;
        font-family: Arial, Helvetica;
        margin: 1cm;
}
.correct {
        color: green;
}
.answered {
        color: blue;
}
.percentcorrect {
        color: green;
}
.probtime {
        color: blue;
}
.timesproblem {
        font-family: fixed;
}
"))
  
  ;; string symbol -> xexpr
  ;; generates a body's attribute for onload focus on a form widget given
  ;; by the form name and variable symbol.
  (define (onload-focus formname var)
    `(onload ,(string-append "document." formname "." var ".focus();")))
  
  ;; string listof[string] -> xexpr
  ;; Creates an HTML form widget for choosing an item from a list; the value
  ;; bound to the form variable will be a string containing a zero-based index
  ;; into the list.
  (define (make-selection-list var-name ls)
    `(select ((name ,var-name))
             ,@(build-list (length ls)
                           (lambda (i)
                             `(option ((value ,(number->string i)))
                                      ,(list-ref ls i))))))
  
  ;;;; Pages and requesting:
  
  (define LEVELS '(1 2 3 4 5 6 7 8 9 10))
  (define PROBCOUNTS '(10 15 20 6))
  ;; : -> request
  (define (send-metainfo-request-page)
    (send/forward
     (lambda (k-url)
       `(html
         (head
          (title "Algebraic-to-Prefix Test")
          ,(stylesheet))
         (body (,(onload-focus "problem" "answer"))
               (center
                (h1 "Quiz Setup")
                (p "Choose which level of quiz you want, and how many problems:")
                (form ((name "problem")
                       (method "POST")
                       (action ,k-url))
                      (p "Your name, or Identification code:" (br)
                         (input ([type "text"] [size "50"] [name "id"])))
                      (p "Level:"
                         ,(make-selection-list "level"
                                               (map number->string LEVELS)))
                      (p "Number of Problems:"
                         ,(make-selection-list "probcount"
                                               (map number->string PROBCOUNTS)))
                      (input ((type "Submit")
                              (name "Enter")
                              (value "Enter")))
                      )))))))
  
  ;; : -> string X num[1-3] X num[10,15,20]
  (define (get-quiz-metainfo)
    (let* ((bs (request-bindings (send-metainfo-request-page)))
           (id (extract-binding/single 'id bs))
           (l-i (string->number (extract-binding/single 'level bs)))
           (pc-i (string->number (extract-binding/single 'probcount bs))))
      (if (and l-i pc-i id
               (integer? l-i)
               (integer? pc-i)
               (< -1 l-i (length LEVELS))
               (< -1 pc-i (length PROBCOUNTS)))
          (values id
                  (list-ref LEVELS l-i)
                  (list-ref PROBCOUNTS pc-i))
          ;; Problem; try again:
          (get-quiz-metainfo))))
  
  (define ANSWER-LENGTH "50")
  
  ;; send-problem-page : xexpr int boolean -> request
  ;; Takes an infix expression, the number of the problem, and a boolean
  ;; telling whether there was an error in the first problem given.
  (define (send-problem-page infix-xexpr n trying-again?)
    (send/forward
     (lambda (k-url)
       `(html
         (head
          (title "Algebraic-to-Prefix Test")
          ,(stylesheet))
         (body (,(onload-focus "problem" "answer"))
               (center
                (h1 "Problem #" ,(number->string n))
                ,(if trying-again?
                     `(p "Sorry, there was an error reading your answer."
                         (br)
                         "(Maybe there was a missing parenthesis?)"
                         (br)
                         "Please try again: ")
                     "")
                (p "Write this arithmetic expression as a"
                   " prefix expression: ")
                (form ((name "problem")
                       (method "POST")
                       (action ,k-url))
                      (table ((style "margin-bottom: 16pt;"))
                             (tr (td ((class "problemcell")
                                      (style "text-align: center;"))
                                     ,infix-xexpr)))
                      (input ((type "text")
                              (length ,ANSWER-LENGTH)
                              (maxlength ,ANSWER-LENGTH)
                              (name "answer")))
                      (input ((type "Submit")
                              (name "Enter")
                              (value "Enter"))))))))))
  
  ;; show-success-page : xexpr expr -> void
  ;; Displays a page showing the user got the right answer.
  (define (show-success-page infix-xexpr user-expr)
    (send/forward
     (lambda (k-url)
       `(html
         (head
          (title "Algebraic-to-Prefix Test")
          ,(stylesheet))
         (body (,(onload-focus "cform" "cbutton"))
               (center
                (h1 "Correct!")
                (p "Yes:"
                   (br)
                   (div ((class "problem"))
                        ,infix-xexpr)
                   (br)
                   "is the same as:"
                   (br)
                   (code ,(format "~a" user-expr)))
                (form ((name "cform")
                       (method "POST")
                       (action ,k-url))
                      (input ((type "Submit")
                              (name "cbutton")
                              (value "Continue"))))))))
     ))
  
  ;; show-error-page : xexpr expr expr -> void
  ;; Displays a page showing the user got the wrong answer.
  (define (show-error-page infix-xexpr prefix-expr user-answer)
    (send/forward
     (lambda (k-url)
       `(html
         (head
          (title "Algebraic-to-Prefix Test")
          ,(stylesheet))
         (body (,(onload-focus "cform" "cbutton"))
               (center
                (h1 "Incorrect.")
                (p "Sorry!"
                   (br)
                   "This was the expression:"
                   (div ((class "problem"))
                        ,infix-xexpr)
                   (br)
                   "Your answer was: "
                   (code ,(format "~a" user-answer))
                   (br)
                   "The answer should be:"
                   (br)
                   (code ,(format "~a" prefix-expr)))
                (form ((name "cform")
                       (method "POST")
                       (action ,k-url))
                      (input ((type "Submit")
                              (name "cbutton")
                              (value "Continue"))))))))))
  
  ;; request-answer : xexpr int -> number
  ;; Prompts the user for the answer to the nth problem.
  (define (request-answer infix-xexpr n)
    (let loop ((trying-again? #f))
      (let* ((bs (request-bindings
                  (send-problem-page infix-xexpr n trying-again?)))
             (ans
              (with-handlers (((lambda (x) #t) (lambda (e) (loop #t))))
                (read
                 (open-input-string (extract-binding/single 'answer bs))))))
        (if (eof-object? ans)
            (loop #t)
            ans))))

  ;; record-result : string int int int listof[str] listof[expr] -> void
  (define (record-result id given-level correct all wrong-infix wrong-prefix)
    (let ([op (open-output-file LOGFILE 'text 'append)])
      (fprintf op "User ~a took the test on ~a at level ~a and scored ~a/~a~n" 
               id (srfi:date->string (srfi:current-date) "~c") given-level correct all)
      (when (not (or (null? wrong-infix) (null? wrong-prefix)))
        (fprintf op "\tProblems with incorrect answers follow:~n")
        (for-each (lambda (pi pp)
                    (fprintf op "\t~a = ~a~n" (filter (lambda (x) (not (equal? x 'nbsp))) (cddr pi)) pp))
                  wrong-infix wrong-prefix))
      (close-output-port op)))
  
  ;; end-with : string int int int listof[str] listof[expr] -> void
  ;; Shows the end page with statistics on the user's performance.
  (define (end-with id given-level correct all wrong-infix wrong-prefix)
    (record-result id given-level correct all wrong-infix wrong-prefix)
    (let ((cs (number->string correct))
          (as (number->string all)))
      (send/finish
       `(html
         (head
          (title "Done!")
          ,(stylesheet))
         (body
          (h1 "Finished!")
          (h2 "Stats:")
          (p "You answered "
             (span ((class "correct")) ,cs)
             " correctly out of "
             (span ((class "answered")) ,as)
             " total, or "
             (span ((class "percentcorrect"))
                   ,(string-append
                     (number->format-decimal (* 100.0 (/ correct all)) 1)
                     "%.")))
          (hr ((width "100%")))
          ,@(if (not (null? wrong-infix))
                `((h2 "Problems Missed")
                  (p "These are the problems you missed:")
                  (ul ,@(map (lambda (ie pe)
                               `(li (code ,ie)
                                    (br)
                                    (code "== " ,(format "~a" pe))))
                             wrong-infix
                             wrong-prefix))
                  (hr ((width "100%"))))
                '())
          (form (input ((type "button")
                        (onClick "window.close()")
                        (value "Close this Window"))))
          )))))
  
  
  ;;;; Main program body:
  
  ;; expr-quiz : string int[non-neg] boolean boolean boolean int+ -> void
  ;; Runs the user through a quiz on infix/prefix expressions,
  ;; with the number of questions specified by question-count and the
  ;; expression complexity specified by nestlevel (0 being a number,
  ;; 1 being the simplest possible compound expression, and so on).
  ;; The boolean options are self-explanatory.
  (define (expr-quiz id given-level nestlevel using-variables? using-negatives? using-expt?
                     question-count)
    (let loop ((correct 0)
               (answered 0)
               (wrong-infix '())
               (wrong-prefix '()))
      (if (= answered question-count)
          (end-with id given-level correct answered wrong-infix wrong-prefix)
          (let* ((prefix-expr
                  (generate-expression nestlevel using-variables?
                                       using-negatives? using-expt?))
                 (infix-xexpr (prefix->infix-xexpr prefix-expr))
                 ;; Now prompt the user with a problem:
                 (user-answer (request-answer infix-xexpr (add1 answered))))
            (if (equivalent-exprs? prefix-expr user-answer)
                (begin (show-success-page infix-xexpr user-answer)
                       (loop (add1 correct)
                             (add1 answered)
                             wrong-infix
                             wrong-prefix))
                (begin (show-error-page infix-xexpr prefix-expr user-answer)
                       (loop correct
                             (add1 answered)
                             (cons infix-xexpr wrong-infix)
                             (cons prefix-expr wrong-prefix))))))))
  
  ;; : -> void
  (define (initialize-quiz)
    (let-values (((id level question-count) (get-quiz-metainfo)))
      (cond
        ((<= 1 level 3) 
         (expr-quiz id level level #f #f #f question-count))
        ((<= 4 level 5)
         (expr-quiz id (- level 3) #t #f #f question-count))       ;; add vars
        ((<= 6 level 7)
         (expr-quiz id (- level 5) #t #t #f question-count))       ;; add negs
        ((<= 8 level 10)
         (expr-quiz id (- level 7) #t #t #t question-count))       ;; add expt
        (else   ;; shouldn't happen
         (expr-quiz id 5 #t #t #t 1)))))
  
  (define (generate-start path-to-log)
    (lambda (intial-request)
      (fluid-let ([LOGFILE path-to-log])
        (initialize-quiz)))))