Permalink
Browse files

Delay evaluation of (function ...) objects in hint

sequences until last possible moment.  This takes care
of some stale hint sequences.  Also add some error tests.
  • Loading branch information...
1 parent 4cbfbaa commit e9fee0d7dbf22705fa5ff7aa3fb20c33646c1b0d @bvds committed Mar 10, 2012
Showing with 104 additions and 91 deletions.
  1. +2 −2 Documentation/server.html
  2. +12 −3 Help/Commands.cl
  3. +7 −6 Help/Entry-API.cl
  4. +6 −4 Help/NextStepHelp.cl
  5. +7 −2 Help/SolutionGraph.cl
  6. +7 −1 Help/database.cl
  7. +49 −40 Help/whatswrong.cl
  8. +14 −33 HelpStructs/TutorTurn.cl
@@ -163,12 +163,12 @@
You can use the following to run the help server:
<pre>
(rhelp)
-(start-help :db "andes_test" :password "my-db-pass") ;set database password
+(start-help :db "andes_test") ;see db_user_password above
(setf *simulate-loaded-server* nil) ;not necessary in stable branch
(setf webserver:*debug* nil) ;not necessary in stable branch
;; Create thread to monitor memory usage.
(sb-thread:make-thread
- (lambda () (loop for i from 1 to 77 do
+ (lambda () (loop for i from 1 to 177 do
(format webserver:*stdout* "~%~A sessions~%"
(hash-table-count webserver::*sessions*))
(gen-stats webserver:*stdout*) (sleep 120))))
View
@@ -240,14 +240,23 @@
;; dispatch the response to the responder function.
;; Since handle-student-response is wrapped by return-turn, the
;; result will be logged, and *last-turn-response* will be updated.
- (prog1 (apply *last-turn-response*
- (list response-code))
+ (let ((response (apply *last-turn-response*
+ (list response-code))))
;; Retire this response.
;; This prevents the student from getting the same hint repeatedly
;; by clicking on "explain-more."
;; If there are multiple-choice responses, it may no longer
;; make sense to retire old ones.
- (setf *last-turn-response* nil)))
+ (setf *last-turn-response* nil)
+
+ ;; Result may be a tutor turn or a function that
+ ;; evaluates to one.
+ (when (functionp response) (setf response (funcall response)))
+ (if (or (null response) (turn-p response))
+ response
+ (warn 'log-condition:log-warn
+ :tag (list 'invalid-last-turn-response response)
+ :text "*last-turn-response* invalid form"))))
;; Student types text, but there is no responder
;; from last term.
View
@@ -665,7 +665,7 @@
:assoc `((no-label . ,(StudentEntry-type entry)))
:diagnosis (cons 'no-label (StudentEntry-type entry))
:state +incorrect+
- ;; Student gets unsolicited hint if they have not mastered skill.
+ ;; Student gets unsolicited hint if they have not mastered skill.
:spontaneous (incremented-property-test 'object-with-label 3)))
(defun with-text-handler ()
@@ -1254,11 +1254,11 @@
;; being processed further. Return appropriate turn with unsolicited
;; error message in this case.
(when (studentEntry-ErrInterp entry)
- (when *debug-grade* (warn `webserver:log-warn
+ (when *debug-grade* (warn `log-condition:log-warn
:text "Not grading update 1"
:tag (list 'not-grading 1 entry)))
(return-from Check-NonEq-Entry
- (ErrorInterp-remediation (studentEntry-ErrInterp entry))))
+ (ErrorInterp-remediate (studentEntry-ErrInterp entry))))
;; else have a real student entry to check
(when *debug-help*
@@ -1277,7 +1277,7 @@
(StudentEntry-GivenEqns Entry))
(setf result (Check-Vector-Given-Form Entry))
(when (not (eq (turn-coloring result) +color-green+))
- (when *debug-grade* (warn `webserver:log-warn
+ (when *debug-grade* (warn `log-condition:log-warn
:text "Not grading update 2"
:tag (list 'not-grading 2 entry)))
(return-from Check-NonEq-Entry result))) ; early exit
@@ -1726,14 +1726,14 @@
(make-ErrorInterp :diagnosis diagnosis
:intended intended
:remediation rem)))
-
(make-incorrect-reply entry rem :spontaneous spontaneous)))
((and (null state) spontaneous)
(let ((rem (make-hint-seq hints :assoc assoc)))
(setf (studentEntry-ErrInterp entry)
(make-ErrorInterp :diagnosis diagnosis
:remediation rem))
+ (when (functionp rem) (setf rem (funcall rem)))
(setf (turn-id rem) (StudentEntry-id entry))
rem))
@@ -1759,11 +1759,12 @@
(make-red-turn entry))))
(defun make-incorrect-reply (entry rem &key spontaneous)
- (setf (turn-id rem) (StudentEntry-id entry))
(if (or spontaneous
;; Turn on experiment effect; see Bug #1940.
(random-help-experiment:help-mod-p 'give-spontaneous-hint))
(progn
+ (when (functionp rem) (setf rem (funcall rem)))
+ (setf (turn-id rem) (StudentEntry-id entry))
;; Only turn red if rem is this reply.
(setf (turn-coloring rem) +color-red+)
;; Add log message to return
View
@@ -981,10 +981,12 @@
;; Clear out any old value because next-step-help doesn't
;; always assign a new value.
(setf *help-last-entries* nil)
- (cond ((nsh-next-call-set?) (nsh-execute-next-call))
- ((nsh-continue-last-node?) (nsh-prompt-last-node))
- ((not (nsh-student-has-done-work?)) (nsh-prompt-start))
- (t (nsh-prompt-next))))
+ (let ((result
+ (cond ((nsh-next-call-set?) (nsh-execute-next-call))
+ ((nsh-continue-last-node?) (nsh-prompt-last-node))
+ ((not (nsh-student-has-done-work?)) (nsh-prompt-start))
+ (t (nsh-prompt-next)))))
+ (if (functionp result) (funcall result) result)))
View
@@ -515,10 +515,15 @@
(defun sg-pair-eqn-entries (Eqns Entries)
- (let ((tmp))
+ (let (tmp)
(dolist (E Eqns)
(setq tmp (sg-find-eqn->entry (cadr E) Entries))
- (if (null tmp) (error "Unmatched eqn entry found in setup ~A." (cadr E)))
+ (unless tmp
+ (error 'log-condition:log-error
+ :text "Eqn not found in Entries. Can't load problem."
+ :tag (list 'sg-setup-eqn-entries
+ (cadr E)
+ (mapcar #'SystemEntry-prop Entries))))
(setf (nth 2 E) tmp))))
View
@@ -267,7 +267,13 @@ list of characters and replacement strings."
;; By default, cl-json turns camelcase into dashes:
;; Instead, we are case insensitive, preserving dashes.
(*json-identifier-name-to-lisp* #'string-upcase))
-
+
+ (unless (listp result)
+ (warn 'log-condition:log-warn
+ :tag (list 'get-matching-sessions-result result)
+ :text "get-matching-sessions-result got invalid result.")
+ (return-from get-matching-sessions))
+
;; Filter out turns where the reply contains a timeout error.
;; Unless the bug causing the timeout has been fixed, these errors
;; prevent a student from reopening a problem.
View
@@ -49,53 +49,57 @@
(defun do-whats-wrong (student)
"Given the id selected by the student in what's wrong help, returns a
tutor turn containing the associated error interpretation."
-
- ;; For Modified help experiment.
- ;; Need a way to do this kind of stuff that is
- ;; "pluggable". Bug #1940
- (random-help-experiment:set-current-object (StudentEntry-id student))
-
- (diagnose student)
- (setf *help-last-entries*
- (ErrorInterp-intended (StudentEntry-ErrInterp student)))
- (ErrorInterp-Remediation (StudentEntry-ErrInterp student)))
-
-
-;;; Given a student entry, returns an ErrorInterp struct. If the
-;;; entry has been diagnosed before, or is an equation entry (in which
-;;; case parse-andes will have taken care of it) then just repeat the
-;;; hint sequence by returning the old error interpretation. If the
-;;; student entry is incorrect, then we have a new error that needs to
-;;; be given an interpretation. If the student's entry is premature
-;;; or forbidden, then we need to construct an error interpretation
-;;; that explains why. If the entry is acceptable to color-by-numbers
+
+ ;; For Modified help experiment. Need a way to do this
+ ;; kind of stuff that is "pluggable". Bug #1940
+ (random-help-experiment:set-current-object (StudentEntry-id student))
+
+ (diagnose student)
+ (setf *help-last-entries*
+ (ErrorInterp-intended (StudentEntry-ErrInterp student)))
+ (let ((turn (ErrorInterp-Remediate (StudentEntry-ErrInterp student))))
+ ;; If entry is already colored, don't send color
+ (when (eql (StudentEntry-state student) +incorrect+)
+ (setf (turn-coloring turn) nil))
+ turn))
+
+
+;;; Given a student entry, returns an ErrorInterp struct.
+;;; The student may have made other entries since the error
+;;; was made, so we need to re-evaluate the error, so that
+;;; up-to-date hints are given.
+;;;
+;;; There is a possibility that subesequent student actions
+;;; may warrrent changing the StudentEntry-State. In that
+;;; case, the help given will be inorrect.
+
+;;; If the student entry is incorrect, then we have a new
+;;; error that needs to be given an interpretation. If the
+;;; student's entry is premature or forbidden, then we need
+;;; to construct an error interpretation that explains why.
+;;; If the entry is acceptable to color-by-numbers
;;; but not relevant to the solution (a yellow error), then say so.
;;; These are the only student entry states that should occur.
(defun diagnose (student)
"Given a student entry, sets the error interpretation."
- (if (StudentEntry-ErrInterp student)
- ;; Even if the error interpretation originally caused the entry to
- ;; turn colors make sure that this time it is just a plain dialog
- ;; turn and does no coloring
- (setf (turn-coloring (ErrorInterp-Remediation
- (studentEntry-ErrInterp student))) NIL)
+ (unless (StudentEntry-ErrInterp student)
(setf (StudentEntry-ErrInterp student)
(let ((state (StudentEntry-State student)))
(cond
- ((eq state +premature-entry+)
- (explain-premature-entry student))
- ((eq state +premature-subst+)
- (explain-premature-subst student))
- ((eq state +forbidden+)
- (explain-forbidden student))
- ((not (eq state +incorrect+))
- (make-failed-error-interpretation))
- ((and (eq 'eqn (car (StudentEntry-Prop student)))
- (not (solver-equation-redp
- (studentEntry-ParsedEqn student))))
- (yellow-error student))
- (T (new-error student)))))))
-
+ ((eq state +premature-entry+)
+ (explain-premature-entry student))
+ ((eq state +premature-subst+)
+ (explain-premature-subst student))
+ ((eq state +forbidden+)
+ (explain-forbidden student))
+ ((not (eq state +incorrect+))
+ (make-failed-error-interpretation))
+ ((and (eq 'eqn (car (StudentEntry-Prop student)))
+ (not (solver-equation-redp
+ (studentEntry-ParsedEqn student))))
+ (yellow-error student))
+ (T (new-error student)))))))
+
(defun make-failed-error-interpretation (&optional (fn-msg 'no-error-interpretation))
"Returns an error interpretaton indicate that Andes could not understand the student's error"
@@ -589,6 +593,11 @@
(defun call-ww-turn-generator (ei)
;; wrapper attaches function name as assoc info to turn
(let ((result-turn (eval (ErrorInterp-hints ei))))
+
+ ;; This can be either turn struct or function that evaluates to one.
+ (when (functionp result-turn)
+ (setf result-turn (funcall result-turn)))
+
(setf (turn-assoc result-turn)
(alist-warn (list (ErrorInterp-diagnosis ei))))
result-turn))
View
@@ -263,7 +263,7 @@
;; <Specs> is a list of hint specifications of the form
;; (<class> <string> . <vars>)
;; where:
-;; <Class> is one of STRING KCD MINILESSON or EVAL or FUNCTION
+;; <Class> is one of STRING KCD MINILESSON or FUNCTION
;; <String> is a format string complete with ~A's.
;; <Vars> is alist of operator vars that will be
;; substituted into the string via a format.
@@ -279,11 +279,6 @@
;; called this function will be called and in so doing terminate
;; the hint sequence irrespective of what follows the function.
;;
-;; For some damn reason functionp is not working the compilation
-;; step prevents it from succeeding. Accordingly there is a new
-;; hintspec type called 'function this will then call the element
-;; immediately following on on the rest of the elements in the
-;; hintspec.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; continuations
;; As long as there are more hints in the stack for the
@@ -310,7 +305,7 @@
;; <type> is one of {Point, Teach, Apply} and
;; <Class> is one of {String, KCD, MiniLesson, etc.}
-;; Returns nil or a turn struct.
+;; Returns ((func args ...) . prefix) or a turn struct.
(defun make-hint-seq (Hints &key (Prefix nil) (Assoc nil) (OpTail nil))
"make the appropriate hint sequence."
@@ -345,15 +340,14 @@
((eq (car Hint) 'String) (make-string-hseq Hint rest Prefix Assoc OpTail))
((eq (car Hint) 'KCD) (error "KCD's have been removed."))
((eq (car Hint) 'Minilesson) (make-minil-hseq Hint Rest Assoc OpTail))
- ((eq (car Hint) 'Eval) (make-eval-hseq Hint Rest))
((eq (car Hint) 'Function)
(unless (and *backwards-hints-hook*
(funcall *backwards-hints-hook*))
(warn 'log-condition:log-warn
:tag (list 'hints-after-function rest)
:text "Hints in sequence after function inaccessible."))
(make-function-hseq (cdr Hint) Prefix))
- (t (Error 'log-condition:log-error :tag 'problem-load-failed
+ (t (Error 'log-condition:log-error
:tag (list 'unrecognized-hint-type 'next hint)
:text "Unrecognized hint type supplied."))))
@@ -370,8 +364,7 @@
((eq (car Hint) 'String) (make-string-end-hseq Hint Prefix Assoc))
((eq (car Hint) 'KCD) (error "KCD's have been removed."))
((eq (car Hint) 'Minilesson) (make-minil-end-hseq (cadr Hint) Assoc))
- ((eq (car Hint) 'Eval) (make-eval-hseq (cadr Hint)))
- ((eq (car Hint) 'function) (make-function-hseq (cdr Hint) Prefix))
+ ((eq (car Hint) 'function) (make-function-hseq (cdr Hint) Prefix))
(t (Error 'log-condition:log-error
:tag (list 'unrecognized-hint-type 'end hint)
:text "Unrecognized hint type supplied."))))
@@ -647,32 +640,20 @@
;;--------------------------------------------------------------
-;; Eval hints.
-;; Occasionally it is necessary to embed code within the hints
-;; so that the step hints can modify themselves based upon the
-;; problem state or the student's location. The format for the
-;; Hints is (Eval <Contents>) where <Contents> is a set of lisp
-;; code that will be funcalled via a progn for legal reasons.
-(defun make-eval-hseq (Hint &optional (Rest nil))
- "Call the hseq function with args and return."
- (make-hint-seq (cons (func-eval (cdr Hint)) Rest)))
-
-
-;;--------------------------------------------------------------
;; function hints
;; Occasionally it is necessary to call a specific function
;; The function hint types are function expressions that will
-;; be evaluated at runtime and should return a tutor turn.
+;; be evaluated at runtime and should return a tutor turn.
(defun make-function-hseq (Hint &optional (Prefix ""))
- "Call the specified function."
- (let ((result (apply (car Hint) (cdr Hint))))
- (when (eq (type-of result) 'turn) ; succeeded w/turn
- ; prepend prefix to existing text in result turn.
- (setf (turn-text result)
- (strcat Prefix (turn-text result))))
- result)) ; return value
-
-
+ "Create lambda expression for specified function."
+ #'(lambda ()
+ (let ((result (apply (car Hint) (cdr Hint))))
+ (if (turn-p result)
+ ;; prepend prefix to existing text in result turn.
+ (setf (turn-text result)
+ (strcat Prefix (turn-text result)))
+ (warn "make-function-hseq given non-turn ~A." hint))
+ result)))
;;---------------------------------------------------------------

0 comments on commit e9fee0d

Please sign in to comment.