[system] / branches / rel-2-2-dev / webwork2 / lib / WeBWorK / ContentGenerator / Problem.pm Repository:
ViewVC logotype

Annotation of /branches/rel-2-2-dev/webwork2/lib/WeBWorK/ContentGenerator/Problem.pm

Parent Directory Parent Directory | Revision Log Revision Log

Revision 492 - (view) (download) (as text)
Original Path: trunk/webwork2/lib/WeBWorK/ContentGenerator/Problem.pm

1 : sh002i 449 ################################################################################
2 :     # WeBWorK mod_perl (c) 1995-2002 WeBWorK Team, Univeristy of Rochester
3 :     # $Id$
4 :     ################################################################################
5 :    
6 : malsyned 353 package WeBWorK::ContentGenerator::Problem;
7 : malsyned 396
8 : sh002i 455 =head1 NAME
9 :    
10 :     WeBWorK::ContentGenerator::Problem - Allow a student to interact with a problem.
11 :    
12 :     =cut
13 :    
14 : malsyned 396 use strict;
15 :     use warnings;
16 : sh002i 449 use base qw(WeBWorK::ContentGenerator);
17 :     use CGI qw();
18 : sh002i 455 use WeBWorK::Form;
19 :     use WeBWorK::PG;
20 : sh002i 429 use WeBWorK::Utils qw(ref2string encodeAnswers decodeAnswers);
21 : malsyned 353
22 : sh002i 449 # TODO:
23 :     # 7. make warnings work
24 :    
25 :     ############################################################
26 :     #
27 : sh002i 424 # user
28 :     # key
29 : sh002i 415 #
30 : sh002i 424 # displayMode
31 :     # showOldAnswers
32 :     # showCorrectAnswers
33 :     # showHints
34 :     # showSolutions
35 : sh002i 415 #
36 : sh002i 425 # AnSwEr# - answer blanks in problem
37 :     #
38 : sh002i 429 # redisplay - name of the "Redisplay Problem" button
39 :     # submitAnswers - name of "Submit Answers" button
40 : sh002i 449 #
41 :     ############################################################
42 : gage 392
43 : sh002i 476 sub pre_header_initialize {
44 : sh002i 424 my ($self, $setName, $problemNumber) = @_;
45 :     my $courseEnv = $self->{courseEnvironment};
46 :     my $r = $self->{r};
47 :     my $userName = $r->param('user');
48 : malsyned 353
49 : sh002i 492 # make sure $problemNumber is numeric (see PG.pm)
50 :     die "Problem must be numeric!\n" unless $problemNumber =~ /^\d+$/;
51 :    
52 : sh002i 424 # fix format of setName and problem
53 :     $setName =~ s/^set//;
54 :     $problemNumber =~ s/^prob//;
55 : gage 388
56 : sh002i 429 ##### database setup #####
57 :    
58 : sh002i 449 my $cldb = WeBWorK::DB::Classlist->new($courseEnv);
59 :     my $wwdb = WeBWorK::DB::WW->new($courseEnv);
60 :     my $authdb = WeBWorK::DB::Auth->new($courseEnv);
61 : sh002i 429
62 : sh002i 449 my $user = $cldb->getUser($userName);
63 :     my $set = $wwdb->getSet($userName, $setName);
64 :     my $problem = $wwdb->getProblem($userName, $setName, $problemNumber);
65 : sh002i 429 my $permissionLevel = $authdb->getPermissions($userName);
66 : malsyned 396
67 : sh002i 429 ##### form processing #####
68 :    
69 : sh002i 425 # set options from form fields (see comment at top of file for names)
70 : sh002i 424 my $displayMode = $r->param("displayMode") || $courseEnv->{pg}->{options}->{displayMode};
71 : sh002i 425 my $redisplay = $r->param("redisplay");
72 : sh002i 429 my $submitAnswers = $r->param("submitAnswers");
73 : gage 388
74 : sh002i 449 # coerce form fields into CGI::Vars format
75 :     my $formFields = { WeBWorK::Form->new_from_paramable($r)->Vars };
76 :    
77 :     ##### permissions #####
78 :    
79 :     # what does the user want to do?
80 : sh002i 431 my %want = (
81 :     showOldAnswers => $r->param("showOldAnswers") || $courseEnv->{pg}->{options}->{showOldAnswers},
82 :     showCorrectAnswers => $r->param("showCorrectAnswers") || $courseEnv->{pg}->{options}->{showCorrectAnswers},
83 :     showHints => $r->param("showHints") || $courseEnv->{pg}->{options}->{showHints},
84 :     showSolutions => $r->param("showSolutions") || $courseEnv->{pg}->{options}->{showSolutions},
85 :     recordAnswers => $r->param("recordAnswers") || 1,
86 :     );
87 : sh002i 429
88 : sh002i 431 # are certain options enforced?
89 :     my %must = (
90 :     showOldAnswers => 0,
91 :     showCorrectAnswers => 0,
92 :     showHints => 0,
93 :     showSolutions => 0,
94 :     recordAnswers => mustRecordAnswers($permissionLevel),
95 :     );
96 :    
97 : sh002i 429 # does the user have permission to use certain options?
98 : sh002i 431 my %can = (
99 :     showOldAnswers => 1,
100 :     showCorrectAnswers => canShowCorrectAnswers($permissionLevel, $set->answer_date),
101 :     showHints => 1,
102 :     showSolutions => canShowSolutions($permissionLevel, $set->answer_date),
103 :     recordAnswers => canRecordAnswers($permissionLevel, $set->open_date, $set->due_date,
104 :     $problem->max_attempts, $problem->num_correct + $problem->num_incorrect + 1),
105 :     # num_correct+num_incorrect+1 -- as this happens before updating $problem
106 :     );
107 : sh002i 429
108 :     # final values for options
109 : sh002i 431 my %will;
110 :     foreach(keys %must) {
111 :     $will{$_} = $can{$_} && ($want{$_} || $must{$_});
112 :     }
113 : sh002i 429
114 :     ##### sticky answers #####
115 :    
116 : sh002i 431 if (not $submitAnswers and $will{showOldAnswers}) {
117 :     # do this only if new answers are NOT being submitted
118 : sh002i 429 my %oldAnswers = decodeAnswers($problem->last_answer);
119 :     $formFields->{$_} = $oldAnswers{$_} foreach keys %oldAnswers;
120 :     }
121 :    
122 :     ##### translation #####
123 :    
124 : sh002i 424 my $pg = WeBWorK::PG->new(
125 :     $courseEnv,
126 :     $r->param('user'),
127 :     $r->param('key'),
128 :     $setName,
129 :     $problemNumber,
130 :     { # translation options
131 : sh002i 434 displayMode => $displayMode,
132 :     showHints => $will{showHints},
133 :     showSolutions => $will{showSolutions},
134 :     refreshMath2img => $will{showHints} || $will{showSolutions},
135 : sh002i 431 # try leaving processAnswers on all the time?
136 : sh002i 434 processAnswers => 1, #$submitAnswers ? 1 : 0,
137 : sh002i 424 },
138 :     $formFields
139 :     );
140 : gage 392
141 : sh002i 449 ##### store fields #####
142 :    
143 :     $self->{cldb} = $cldb;
144 :     $self->{wwdb} = $wwdb;
145 :     $self->{authdb} = $authdb;
146 :    
147 :     $self->{user} = $user;
148 :     $self->{set} = $set;
149 :     $self->{problem} = $problem;
150 :     $self->{permissionLevel} = $permissionLevel;
151 :    
152 :     $self->{displayMode} = $displayMode;
153 :     $self->{redisplay} = $redisplay;
154 :     $self->{submitAnswers} = $submitAnswers;
155 :     $self->{formFields} = $formFields;
156 :    
157 :     $self->{want} = \%want;
158 :     $self->{must} = \%must;
159 :     $self->{can} = \%can;
160 :     $self->{will} = \%will;
161 :    
162 :     $self->{pg} = $pg;
163 :     }
164 :    
165 : sh002i 476 #sub header {
166 :     # # *** we need to print $pg->{header_text} here!
167 :     #}
168 :    
169 :     sub path {
170 :     my $self = shift;
171 :     my $args = $_[-1];
172 :     my $setName = $self->{set}->id;
173 :     my $problemNumber = $self->{problem}->id;
174 :    
175 :     my $ce = $self->{courseEnvironment};
176 :     my $root = $ce->{webworkURLs}->{root};
177 :     my $courseName = $ce->{courseName};
178 :     return $self->pathMacro($args,
179 :     "Home" => "$root",
180 :     $courseName => "$root/$courseName",
181 :     $setName => "$root/$courseName/set$setName",
182 :     "Problem $problemNumber" => "",
183 :     );
184 :     }
185 :    
186 :     sub siblings {
187 :     my $self = shift;
188 :     my $setName = $self->{set}->id;
189 :     my $problemNumber = $self->{problem}->id;
190 :    
191 :     my $ce = $self->{courseEnvironment};
192 :     my $root = $ce->{webworkURLs}->{root};
193 :     my $courseName = $ce->{courseName};
194 :    
195 :     my $wwdb = $self->{wwdb};
196 :     my $user = $self->{r}->param("user");
197 :     my @problems;
198 :     push @problems, $wwdb->getProblem($user, $setName, $_)
199 :     foreach ($wwdb->getProblems($user, $setName));
200 :     foreach my $problem (sort { $a->id <=> $b->id } @problems) {
201 :     print CGI::a({-href=>"$root/$courseName/$setName/".$problem->id."/?"
202 :     . $self->url_authen_args}, "Problem ".$problem->id), CGI::br();
203 :     }
204 :     }
205 :    
206 :     sub nav {
207 :     my $self = shift;
208 :     my $args = $_[-1];
209 :     my $setName = $self->{set}->id;
210 :     my $problemNumber = $self->{problem}->id;
211 :    
212 :     my $ce = $self->{courseEnvironment};
213 :     my $root = $ce->{webworkURLs}->{root};
214 :     my $courseName = $ce->{courseName};
215 :    
216 :     my $wwdb = $self->{wwdb};
217 :     my $user = $self->{r}->param("user");
218 :    
219 :     my @links = ("Problem List" => "$root/$courseName/set$setName");
220 :    
221 :     my $prevProblem = $wwdb->getProblem($user, $setName, $problemNumber-1);
222 :     my $nextProblem = $wwdb->getProblem($user, $setName, $problemNumber+1);
223 :     unshift @links, "Previous Problem" => "$root/$courseName/set$setName/prob".$prevProblem->id
224 :     if $prevProblem;
225 :     push @links, "Next Problem" => "$root/$courseName/set$setName/prob".$nextProblem->id
226 :     if $nextProblem;
227 :    
228 :     return $self->navMacro($args, @links);
229 :     }
230 :    
231 : sh002i 449 sub title {
232 :     my $self = shift;
233 : sh002i 476 my $setName = $self->{set}->id;
234 :     my $problemNumber = $self->{problem}->id;
235 :    
236 :     return "$setName : Problem $problemNumber";
237 : sh002i 449 }
238 :    
239 :     sub body {
240 :     my $self = shift;
241 :    
242 : sh002i 476 #$self->prepare(@_);
243 : sh002i 449
244 :     # unpack some useful variables
245 : sh002i 476 my $r = $self->{r};
246 :     my $wwdb = $self->{wwdb};
247 :     my $set = $self->{set};
248 :     my $problem = $self->{problem};
249 :     my $permissionLevel = $self->{permissionLevel};
250 :     my $submitAnswers = $self->{submitAnswers};
251 :     my %will = %{ $self->{will} };
252 :     my $pg = $self->{pg};
253 : sh002i 449
254 :     ##### translation errors? #####
255 :    
256 : sh002i 425 if ($pg->{flags}->{error_flag}) {
257 : sh002i 449 print translationError($pg->{errors}, $pg->{body_text});
258 : sh002i 425 return "";
259 :     }
260 : sh002i 415
261 : sh002i 429 ##### answer processing #####
262 :    
263 :     # if answers were submitted:
264 :     if ($submitAnswers) {
265 : sh002i 431 # store answers in DB for sticky answers
266 : sh002i 429 my %answersToStore;
267 :     my %answerHash = %{ $pg->{answers} };
268 :     $answersToStore{$_} = $answerHash{$_}->{original_student_ans}
269 :     foreach (keys %answerHash);
270 :     my $answerString = encodeAnswers(%answersToStore,
271 :     @{ $pg->{flags}->{ANSWER_ENTRY_ORDER} });
272 :     $problem->last_answer($answerString);
273 :     $wwdb->setProblem($problem);
274 :    
275 : sh002i 449 # store state in DB if it makes sense
276 : sh002i 431 if ($will{recordAnswers}) {
277 :     $problem->attempted(1);
278 :     $problem->status($pg->{state}->{recorded_score});
279 :     $problem->num_correct($pg->{state}->{num_of_correct_ans});
280 :     $problem->num_incorrect($pg->{state}->{num_of_incorrect_ans});
281 :     $wwdb->setProblem($problem);
282 :     }
283 : sh002i 425 }
284 :    
285 : sh002i 429 ##### output #####
286 : sh002i 425
287 : sh002i 431 # attempt summary
288 :     if ($submitAnswers or $will{showCorrectAnswers}) {
289 :     # print this if user submitted answers OR requested correct answers
290 :     print attemptResults($pg, $submitAnswers, $will{showCorrectAnswers},
291 :     $pg->{flags}->{showPartialCorrectAnswers});
292 :     }
293 : gage 392
294 : sh002i 431 # score summary
295 :     my $attempts = $problem->num_correct + $problem->num_incorrect;
296 :     my $attemptsNoun = $attempts != 1 ? "times" : "time";
297 :     my $lastScore = int ($problem->status * 100) . "%";
298 :     my ($attemptsLeft, $attemptsLeftNoun);
299 :     if ($problem->max_attempts == -1) {
300 :     # unlimited attempts
301 :     $attemptsLeft = "unlimited";
302 :     $attemptsLeftNoun = "attempts";
303 :     } else {
304 :     $attemptsLeft = $problem->max_attempts - $attempts;
305 :     $attemptsLeftNoun = $attemptsLeft == 1 ? "attempt" : "attempts";
306 :     }
307 : sh002i 476 my $setClosedMessage;
308 :     if (time < $set->open_date or time > $set->due_date) {
309 :     $setClosedMessage = "This problem set is closed.";
310 :     if ($permissionLevel > 0) {
311 :     $setClosedMessage .= " Since you are a privileged user, additional attempts will be recorded.";
312 :     } else {
313 :     $setClosedMessage .= " Additional attempts will not be recorded.";
314 :     }
315 :     }
316 : sh002i 449 print CGI::p(
317 :     "You have attempted this problem $attempts $attemptsNoun.", CGI::br(),
318 : sh002i 431 $problem->attempted
319 : sh002i 449 ? "Your recorded score is $lastScore." . CGI::br()
320 : sh002i 431 : "",
321 : sh002i 476 "You have $attemptsLeft $attemptsLeftNoun remaining.", CGI::br(),
322 :     $setClosedMessage,
323 : sh002i 431 );
324 :    
325 :     # BY THE WAY..........
326 :     # we have to figure out some way to tell the student if their NEW answer,
327 :     # on THIS attempt, has been recorded. however, this is decided in part by
328 :     # the grader, so is there any way for us to know? we can rule out several
329 :     # cases where the answer is NOT being recorded, because of things decided
330 :     # in &canRecordAnswers...
331 :    
332 : sh002i 449 print CGI::hr();
333 : sh002i 431
334 : sh002i 429 # main form
335 :     print
336 : sh002i 449 CGI::startform("POST", $r->uri),
337 : sh002i 429 $self->hidden_authen_fields,
338 : sh002i 449 CGI::p(CGI::i($pg->{result}->{msg})),
339 :     CGI::p($pg->{body_text}),
340 :     CGI::p(CGI::submit(-name=>"submitAnswers", -label=>"Submit Answers")),
341 :     $self->viewOptions,
342 :     CGI::endform();
343 : sh002i 429
344 : sh002i 424 # debugging stuff
345 : sh002i 435 #print
346 :     # hr(),
347 :     # h2("debugging information"),
348 :     # h3("form fields"),
349 :     # ref2string($formFields),
350 :     # h3("user object"),
351 :     # ref2string($user),
352 :     # h3("set object"),
353 :     # ref2string($set),
354 :     # h3("problem object"),
355 :     # ref2string($problem),
356 :     # h3("PG object"),
357 :     # ref2string($pg, {'WeBWorK::PG::Translator' => 1});
358 : gage 392
359 : sh002i 424 return "";
360 : malsyned 353 }
361 :    
362 : sh002i 431 ##### output utilities #####
363 : sh002i 429
364 :     sub translationError($$) {
365 :     my ($error, $details) = @_;
366 :     return
367 : sh002i 449 CGI::h2("Software Error"),
368 :     CGI::p(<<EOF),
369 : sh002i 429 WeBWorK has encountered a software error while attempting to process this problem.
370 :     It is likely that there is an error in the problem itself.
371 :     If you are a student, contact your professor to have the error corrected.
372 :     If you are a professor, please consut the error output below for more informaiton.
373 :     EOF
374 : sh002i 449 CGI::h3("Error messages"), CGI::blockquote(CGI::pre($error)),
375 :     CGI::h3("Error context"), CGI::blockquote(CGI::pre($details));
376 : sh002i 429 }
377 :    
378 :     sub attemptResults($$$) {
379 : sh002i 425 my $pg = shift;
380 : sh002i 431 my $showAttemptAnswers = shift;
381 : sh002i 425 my $showCorrectAnswers = shift;
382 : sh002i 431 my $showAttemptResults = $showAttemptAnswers && shift;
383 : sh002i 425 my $problemResult = $pg->{result}; # the overall result of the problem
384 :     my @answerNames = @{ $pg->{flags}->{ANSWER_ENTRY_ORDER} };
385 :    
386 : sh002i 449 my $header = CGI::th("answer");
387 :     $header .= $showAttemptAnswers ? CGI::th("attempt") : "";
388 :     $header .= $showCorrectAnswers ? CGI::th("correct") : "";
389 :     $header .= $showAttemptResults ? CGI::th("result") : "";
390 :     $header .= $showAttemptAnswers ? CGI::th("messages") : "";
391 : sh002i 425 my @tableRows = ( $header );
392 :     my $numCorrect;
393 :     foreach my $name (@answerNames) {
394 :     my $answerResult = $pg->{answers}->{$name};
395 : sh002i 429 my $studentAnswer = $answerResult->{student_ans}; # original_student_ans
396 : sh002i 425 my $correctAnswer = $answerResult->{correct_ans};
397 :     my $answerScore = $answerResult->{score};
398 : sh002i 431 my $answerMessage = $showAttemptAnswers ? $answerResult->{ans_message} : "";
399 : sh002i 425
400 :     $numCorrect += $answerScore > 0;
401 :     my $resultString = $answerScore ? "correct :^)" : "incorrect >:(";
402 :    
403 : sh002i 449 my $row = CGI::td($name);
404 :     $row .= $showAttemptAnswers ? CGI::td($studentAnswer) : "";
405 :     $row .= $showCorrectAnswers ? CGI::td($correctAnswer) : "";
406 :     $row .= $showAttemptResults ? CGI::td($resultString) : "";
407 :     $row .= $answerMessage ? CGI::td($answerMessage) : "";
408 : sh002i 425 push @tableRows, $row;
409 :     }
410 :    
411 : sh002i 431 my $numCorrectNoun = $numCorrect == 1 ? "question" : "questions";
412 : sh002i 425 my $scorePercent = int ($problemResult->{score} * 100) . "\%";
413 : sh002i 431 my $summary = "On this attempt, you answered $numCorrect $numCorrectNoun out of "
414 : sh002i 425 . scalar @answerNames . " correct, for a score of $scorePercent.";
415 : sh002i 476 return CGI::table({-border=>1}, CGI::Tr(\@tableRows)) . CGI::p($summary);
416 : sh002i 425 }
417 :    
418 : sh002i 449 sub viewOptions($) {
419 :     my $self = shift;
420 :     my $displayMode = $self->{displayMode};
421 :     my %must = %{ $self->{must} };
422 :     my %can = %{ $self->{can} };
423 :     my %will = %{ $self->{will} };
424 : sh002i 431
425 :     my $optionLine;
426 :     $can{showOldAnswers} and $optionLine .= join "",
427 : sh002i 429 "Show: &nbsp;",
428 : sh002i 449 CGI::checkbox(
429 : sh002i 429 -name => "showOldAnswers",
430 : sh002i 431 -checked => $will{showOldAnswers},
431 :     -label => "Saved answers",
432 :     ), "&nbsp;&nbsp;";
433 :     $can{showCorrectAnswers} and $optionLine .= join "",
434 : sh002i 449 CGI::checkbox(
435 : sh002i 429 -name => "showCorrectAnswers",
436 : sh002i 431 -checked => $will{showCorrectAnswers},
437 : sh002i 429 -label => "Correct answers",
438 : sh002i 431 ), "&nbsp;&nbsp;";
439 :     $can{showHints} and $optionLine .= join "",
440 : sh002i 449 CGI::checkbox(
441 : sh002i 429 -name => "showHints",
442 : sh002i 431 -checked => $will{showHints},
443 : sh002i 429 -label => "Hints",
444 : sh002i 431 ), "&nbsp;&nbsp;";
445 :     $can{showSolutions} and $optionLine .= join "",
446 : sh002i 449 CGI::checkbox(
447 : sh002i 429 -name => "showSolutions",
448 : sh002i 431 -checked => $will{showSolutions},
449 : sh002i 429 -label => "Solutions",
450 : sh002i 431 ), "&nbsp;&nbsp;";
451 : sh002i 449 $optionLine and $optionLine .= join "", CGI::br();
452 : sh002i 431
453 : sh002i 449 return CGI::div({-style=>"border: thin groove; padding: 1ex; margin: 2ex"},
454 : sh002i 431 "View equations as: &nbsp;",
455 : sh002i 449 CGI::radio_group(
456 : sh002i 431 -name => "displayMode",
457 :     -values => ['plainText', 'formattedText', 'images'],
458 :     -default => $displayMode,
459 :     -labels => {
460 :     plainText => "plain text",
461 :     formattedText => "formatted text",
462 :     images => "images",
463 :     }
464 : sh002i 449 ), CGI::br(),
465 : sh002i 431 $optionLine,
466 : sh002i 449 CGI::submit(-name=>"redisplay", -label=>"Redisplay Problem"),
467 : sh002i 429 );
468 :     }
469 :    
470 : sh002i 431 ##### permission queries #####
471 : sh002i 429
472 :     # this stuff should be abstracted out into the permissions system
473 :     # however, the permission system only knows about things in the
474 :     # course environment and the username. hmmm...
475 :    
476 : sh002i 431 # also, i should fix these so that they have a consistent calling
477 :     # format -- perhaps:
478 :     # canPERM($courseEnv, $user, $set, $problem, $permissionLevel)
479 :    
480 : sh002i 429 sub canShowCorrectAnswers($$) {
481 :     my ($permissionLevel, $answerDate) = @_;
482 :     return $permissionLevel > 0 || time > $answerDate;
483 :     }
484 :    
485 :     sub canShowSolutions($$) {
486 :     my ($permissionLevel, $answerDate) = @_;
487 :     return canShowCorrectAnswers($permissionLevel, $answerDate);
488 :     }
489 :    
490 : sh002i 431 sub canRecordAnswers($$$$$) {
491 :     my ($permissionLevel, $openDate, $dueDate, $maxAttempts, $attempts) = @_;
492 :     my $permHigh = $permissionLevel > 0;
493 :     my $timeOK = time >= $openDate && time <= $dueDate;
494 :     my $attemptsOK = $attempts <= $maxAttempts;
495 :     return $permHigh || ($timeOK && $attemptsOK);
496 : sh002i 429 }
497 :    
498 :     sub mustRecordAnswers($) {
499 :     my ($permissionLevel) = @_;
500 :     return $permissionLevel == 0;
501 :     }
502 :    
503 : sh002i 415 1;
aubreyja at gmail dot com
 ViewVC Help
Powered by ViewVC 1.0.9