Skip to content

Commit

Permalink
In open-problem, consolidate replies from old sessions
Browse files Browse the repository at this point in the history 
and use logged values for matches to student definitions.
This greatly speeds up open-problem and removes
issues with timeouts and truncated server replies on open-problem.
  • Loading branch information
@bvds
bvds committed Jun 18, 2012
1 parent f46e1c0 commit 02fea32
Show file tree
Hide file tree
Showing 7 changed files with 372 additions and 164 deletions.
99 changes: 66 additions & 33 deletions Help/Entry-API.cl
View file
Expand Up @@ -116,6 +116,26 @@
"Last two characters of a string" "Last two characters of a string"
(subseq x (max 0 (- (length x) 2)))) (subseq x (max 0 (- (length x) 2))))


(defun format-props (sysentries &key allowed-tools)
"Find guesses or sysentries associated with given tools, returning an alist of models and props."
(mapcar
#'(lambda (x) (cons (expand-vars (SystemEntry-model x))
(SystemEntry-prop x)))
(remove-if #'(lambda (prop) (not (member (car prop) allowed-tools)))
sysentries
:key #'SystemEntry-prop)))

(defun matches-from-guesses (guesses allowed-tools)
(mapcar
;; This could be made faster by borrowing the
;; SystemEntry-model from any matching SystemEntry instead
;; of constructing a new one.
#'(lambda (prop) (match:make-best :prop prop))
(remove-if
#'(lambda (prop) (not (member (car prop) allowed-tools)))
(mapcar #'read-from-string guesses))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ;;;;
;;;; Match student phrase to Ontology ;;;; Match student phrase to Ontology
Expand All @@ -132,12 +152,27 @@
;; valued. Thus, if we want to do better, than we demand the ;; valued. Thus, if we want to do better, than we demand the
;; bound be decreased by 1. ;; bound be decreased by 1.


(defun match-student-phrase0 (student tool-prop &key (defun match-student-phrase0 (student tool-prop &key
guesses
all-scalars all-scalars
(cutoff-fraction 0.4) (cutoff-fraction 0.4)
;; If larger, too slow on benchmarks ;; If larger, too slow on benchmarks
(cutoff-max 3.7)) (cutoff-max 3.7))
"Match student phrase to Ontology, returning best matches for tool or other tool." "Match student phrase to Ontology, returning best matches for tool or other tool."

;; When guesses are provided, we will assume they are correct and
;; complete, and ignore any sysentries. This is appropriate
;; when the guesses are from the old server replies when
;; rerunning old sessions.
;;
(when (and guesses (eql t (car guesses)))
(let ((allowed-tools (remove tool-prop *tool-props-with-definitions*)))
(return-from match-student-phrase0
(values
(matches-from-guesses (cdr guesses) (list tool-prop))
(matches-from-guesses (cdr guesses) allowed-tools)
0))))

;; :cutoff-fraction is fractional length of student phrase to ;; :cutoff-fraction is fractional length of student phrase to
;; use as bound, adding 1 for the tool. This should be adjusted to ;; use as bound, adding 1 for the tool. This should be adjusted to
;; balance type 1 and type 2 errors: ;; balance type 1 and type 2 errors:
Expand All @@ -154,9 +189,7 @@
;; :cutoff-max is maximum allowed score to use as bound. This should ;; :cutoff-max is maximum allowed score to use as bound. This should
;; be adjusted to so that very long student phrases can ;; be adjusted to so that very long student phrases can
;; be matched quickly enough. ;; be matched quickly enough.
(let* ((sysentries (remove (cons tool-prop '?rest) *sg-entries* (let* ((initial-cutoff (min (* cutoff-fraction (length student))
:key #'SystemEntry-prop :test-not #'unify))
(initial-cutoff (min (* cutoff-fraction (length student))
cutoff-max)) cutoff-max))
;; To speed up best-wrong-match for long phrases, maybe reduce ;; To speed up best-wrong-match for long phrases, maybe reduce
;; max cutoff a bit. ;; max cutoff a bit.
Expand All @@ -173,27 +206,25 @@
(mapcar #'(lambda (x) (mapcar #'(lambda (x)
(cons (expand-vars (new-english-find x)) (cons (expand-vars (new-english-find x))
(list nil x))) (list nil x)))
(mapcar #'qvar-exp (problem-varindex *cp*))) (mapcar #'qvar-exp (problem-varindex *cp*)))
(mapcar #'(lambda (x) (format-props *sg-entries*
(cons (expand-vars (SystemEntry-model x)) :allowed-tools (list tool-prop)))
(SystemEntry-prop x)))
sysentries))
:cutoff initial-cutoff)) :cutoff initial-cutoff))
;; The value of the best correct match or the initial cutoff. ;; The value of the best correct match or the initial cutoff.
;; This is used to determine cutoffs for wrong quantity searches. ;; This is used to determine cutoffs for wrong quantity searches.
(wrong-bound (if best (- (best-value best) 1) initial-cutoff)) (wrong-bound (if best (- (best-value best) 1) initial-cutoff))
wrong-tool-best) wrong-tool-best)

(when nil ;debug print (when nil ;debug print
(format t "Best match to ~s is~% ~S~% from ~S~%" (format webserver:*stdout*
"Best match to ~s is~% ~S~%"
(when student (match:word-string student)) (when student (match:word-string student))
(mapcar (mapcar
#'(lambda (x) (cons (match:best-value x) #'(lambda (x) (cons (match:best-value x)
(expand-vars (new-english-find (expand-vars (new-english-find
(reduce-prop (reduce-prop
(match:best-prop x)))))) (match:best-prop x))))))
best) best)))
(mapcar #'systementry-prop sysentries)))


;; Attempt to detect a wrong tool error. ;; Attempt to detect a wrong tool error.
;; The strategy is to treat the choice of tool as being ;; The strategy is to treat the choice of tool as being
Expand All @@ -205,19 +236,12 @@
;; wrong-tool-best less than best score minus 1 or no best. ;; wrong-tool-best less than best score minus 1 or no best.
;; this certainly should be given wrong tool help. ;; this certainly should be given wrong tool help.
(when (>= wrong-bound 0) (when (>= wrong-bound 0)
(let* ((allowed-tools (remove tool-prop *tool-props-with-definitions*)) (let ((allowed-tools (remove tool-prop *tool-props-with-definitions*)))
(sysentries (remove-if
#'(lambda (x) (not (member
(car (SystemEntry-prop x))
allowed-tools)))
*sg-entries*)))
(setf wrong-tool-best (setf wrong-tool-best
(match:best-model-matches (match:best-model-matches
student student
(mapcar #'(lambda (x) (format-props *sg-entries*
(cons (expand-vars (SystemEntry-model x)) :allowed-tools allowed-tools)
(SystemEntry-prop x)))
sysentries)
;; If there is no match in best, then the help is ;; If there is no match in best, then the help is
;; pretty weak. In that case, just find anything ;; pretty weak. In that case, just find anything
;; below the cutoff. ;; below the cutoff.
Expand All @@ -234,6 +258,8 @@
;; take shortest matching proposition. ;; take shortest matching proposition.
;; need to pre-order quantities so that shorter propositions ;; need to pre-order quantities so that shorter propositions
;; are matched first... ;; are matched first...
;;
;; Assume guesses contain all viable props.
(when (or (null best) (>= (best-value best) 1)) (when (or (null best) (>= (best-value best) 1))
(update-bound (update-bound
best best
Expand All @@ -252,6 +278,8 @@
;; the wrong tool has also been used. ;; the wrong tool has also been used.
;; Must be better than any quantity in solution, but allow ;; Must be better than any quantity in solution, but allow
;; for ties with one plus any quantity not in solution. ;; for ties with one plus any quantity not in solution.
;;
;; Assume guesses contain all viable props.
(when (and (>= wrong-cutoff-max 1) (when (and (>= wrong-cutoff-max 1)
(>= wrong-bound 0) (>= wrong-bound 0)
(or (null best) (>= (best-value best) 1))) (or (null best) (>= (best-value best) 1)))
Expand Down Expand Up @@ -279,7 +307,7 @@
(- (best-value wrong-tool-best) 1) (- (best-value wrong-tool-best) 1)
wrong-bound)))))))) wrong-bound))))))))


(values best wrong-tool-best wrong-bound sysentries))) (values best wrong-tool-best wrong-bound)))


(defun match-student-phrase (entry tool-prop) (defun match-student-phrase (entry tool-prop)
"Match student phrase to Ontology, returning best match prop, tutor turn (if there is an error) and any unsolicited hints." "Match student phrase to Ontology, returning best match prop, tutor turn (if there is an error) and any unsolicited hints."
Expand All @@ -288,10 +316,15 @@
(let ((student (match:word-parse (let ((student (match:word-parse
(pull-out-quantity (StudentEntry-symbol entry) (pull-out-quantity (StudentEntry-symbol entry)
(StudentEntry-text entry)))) (StudentEntry-text entry))))
;; Was previously calculated in match-student-phrase0
(no-tool-sysentries
(notany #'(lambda (x) (eql tool-prop (car (SystemEntry-prop x))))
*sg-entries*))
hints) hints)


(multiple-value-bind (best wrong-tool-best best-correct sysentries) (multiple-value-bind (best wrong-tool-best best-correct)
(match-student-phrase0 student tool-prop) (match-student-phrase0 student tool-prop
:guesses (StudentEntry-guesses entry))


;; If there isn't a good match to solution quantities, ;; If there isn't a good match to solution quantities,
;; try another tool and non-solution quanitities. ;; try another tool and non-solution quanitities.
Expand Down Expand Up @@ -326,7 +359,7 @@
tool-prop tool-prop
(mapcar #'match:best-prop wrong-tool-best)) hints)) (mapcar #'match:best-prop wrong-tool-best)) hints))


((null sysentries) (no-tool-sysentries
(values nil (nothing-to-match-ErrorInterp entry tool-prop) hints)) (values nil (nothing-to-match-ErrorInterp entry tool-prop) hints))


((null best) ((null best)
Expand Down Expand Up @@ -357,9 +390,9 @@
(unless prop (warn "Null prop for correct match")) (unless prop (warn "Null prop for correct match"))
;; Return the best fit entry. ;; Return the best fit entry.
(values prop nil hints))) (values prop nil hints)))

(t (t
(let ((props (mapcar #'match:best-prop best))) (let ((props (mapcar #'match:best-prop best)))
(values nil (too-many-matches-ErrorInterp entry props) hints))))))) (values nil (too-many-matches-ErrorInterp entry props) hints)))))))


;; Debug printout: ;; Debug printout:
Expand Down Expand Up @@ -472,9 +505,9 @@
;; Should use props to inform starting point ;; Should use props to inform starting point
;; for NSH. ;; for NSH.
'(function next-step-help))) '(function next-step-help)))
:assoc `((too-many-matches . ,full-props)) :assoc `((too-many-matches . ,(length full-props)))
:state +incorrect+ :state +incorrect+
:diagnosis '(definition-has-too-many-matches)))) :diagnosis `(definition-has-too-many-matches . ,full-props))))




(defun wrong-tool-ErrorInterp (entry tool-prop full-props) (defun wrong-tool-ErrorInterp (entry tool-prop full-props)
Expand Down Expand Up @@ -987,7 +1020,7 @@


;; finally return entry ;; finally return entry
(check-noneq-entry entry :unsolicited-hints hints)) (check-noneq-entry entry :unsolicited-hints hints))
(t (t
(setf (StudentEntry-prop entry) nil) (setf (StudentEntry-prop entry) nil)
(setf (turn-result tturn) (append (turn-result tturn) hints)) (setf (turn-result tturn) (append (turn-result tturn) hints))
tturn))))) tturn)))))
Expand Down Expand Up @@ -1038,7 +1071,7 @@


;; finally return entry ;; finally return entry
(check-noneq-entry entry :unsolicited-hints hints)) (check-noneq-entry entry :unsolicited-hints hints))
(t (t
(setf (StudentEntry-prop entry) nil) (setf (StudentEntry-prop entry) nil)
(setf (turn-result tturn) (append (turn-result tturn) hints)) (setf (turn-result tturn) (append (turn-result tturn) hints))
tturn))))) tturn)))))
Expand Down
2 changes: 1 addition & 1 deletion Help/Interface.cl
View file
Expand Up @@ -253,7 +253,7 @@


;; if there is assoc info in the turn, add to reply ;; if there is assoc info in the turn, add to reply
;; :assoc has the format of an alist. ;; :assoc has the format of an alist.
;; Still need to properly logs into "student" and "tutor", Bug #1870 ;; Still need to properly log into "student" and "tutor", Bug #1870
(when (and turn (turn-assoc turn)) (when (and turn (turn-assoc turn))
(alist-warn (turn-assoc turn)) (alist-warn (turn-assoc turn))
(push `((:action . "log") (:log . "tutor") (push `((:action . "log") (:log . "tutor")
Expand Down
99 changes: 46 additions & 53 deletions Help/database.cl
View file
Expand Up @@ -274,50 +274,39 @@ list of characters and replacement strings."
:text "get-matching-sessions-result got invalid result.") :text "get-matching-sessions-result got invalid result.")
(return-from get-matching-sessions)) (return-from get-matching-sessions))


;; Filter out turns where the reply contains a timeout error. (loop for line in result
;; Unless the bug causing the timeout has been fixed, these errors with client and server
;; prevent a student from reopening a problem. when
(setf result (and (second line)
(remove-if ;; Decode client post, if it exists
#'(lambda (x) ;; A post with no json sent gets translated into nil;
;; find client turn such that associated server ;; see write-transaction.
;; reply does not have a timeout error. (setf client (errors-to-warnings
(and x (second line)
(server-reply-has-timeout (decode-json-from-string (second line))))
;; Actually, we only need to decode the ;; pick out the solution-step and get-help methods
;; top-level list. (member (cdr (assoc :method client))
;; Sometimes result gets truncated on very long methods :test #'string-equal)
;; backtraces. It might be better to just search ;; Filter out turns where the reply contains a timeout error.
;; the string for the timeout message? ;; Unless the bug causing the timeout has been fixed,
(errors-to-warnings x (decode-json-from-string x))))) ;; these errors prevent a student from reopening a problem.
result (server-reply-has-no-timeout
:key #'car)) (setf server

(errors-to-warnings
;; parse json in each member of result (first line)
;; pick out post and client-id ;; Actually, we only need to decode the
(setf result ;; top-level list.
(mapcar ;; Sometimes result gets truncated on
;; A post with no json sent gets translated into nil; ;; very long backtraces.
;; see write-transaction. (when (first line)
#'(lambda (x) (decode-json-from-string (first line)))))))
(let ((y (second x))) collect
(cons (and y (list server client (third line))))))
(errors-to-warnings
y
(decode-json-from-string y))) (defun server-reply-has-no-timeout (reply)
(third x))))
result))

;; pick out the solution-step and get-help methods
(remove-if #'(lambda (x) (not (member (cdr (assoc :method x))
methods
:test #'equal)))
result
:key #'car))))

(defun server-reply-has-timeout (reply)
"Test whether a server reply includes a timeout error." "Test whether a server reply includes a timeout error."
(some #'(lambda (x) (and (string-equal (cdr (assoc :action x)) "log") (notany #'(lambda (x) (and (string-equal (cdr (assoc :action x)) "log")
(string-equal (cdr (assoc :error-type x)) (string-equal (cdr (assoc :error-type x))
"timeout"))) "timeout")))
(cdr (assoc :result reply)))) (cdr (assoc :result reply))))
Expand Down Expand Up @@ -455,18 +444,22 @@ list of characters and replacement strings."
;; variables. ;; variables.
;; A global cache would need periodic flushing. ;; A global cache would need periodic flushing.
(defun get-start-tID (client-id) (defun get-start-tID (client-id)
(let ((result (let* ((sel (format nil "SELECT MIN(tID) FROM STEP_TRANSACTION WHERE clientID='~A'"
(query *connection* (truncate-client-id client-id)))
(format nil "SELECT MIN(tID) FROM STEP_TRANSACTION WHERE clientID='~A'" (result (query *connection* sel)))
(truncate-client-id client-id)))))
(if (and (consp result) (consp (car result))) (if (and (consp result) (consp (car result)))
(car (car result)) (car (car result))
(warn 'log-condition:log-warn
:tag (list 'get-start-tID result ;; If there is no entry in STEP_TRANSACTION, then something
*old-client-id* ;; has gone wrong. Determine if session exists.
webserver:*log-id* (let ((nst (query *connection* (format nil "Select count(*) FROM STEP_TRANSACTION WHERE clientID='~A'"
(truncate-client-id client-id)) (truncate-client-id client-id))))
:text "get-start-tID expecting list of lists")))) (npa (query *connection* (format nil "Select count(*) FROM PROBLEM_ATTEMPT WHERE clientID='~A'"
(truncate-client-id client-id)))))
(warn 'log-condition:log-warn
:tag (list 'get-start-tID client-id nst npa)
:text "get-start-tID dif not find matching entry")))))


(defun get-session-starting-tID () (defun get-session-starting-tID ()
"Get any existing tID associated with the start of the current session. If client-id is a string, use that session." "Get any existing tID associated with the start of the current session. If client-id is a string, use that session."
Expand Down

0 comments on commit 02fea32

Please sign in to comment.