[system] / trunk / pg / macros / PGanswermacros.pl Repository:
ViewVC logotype

Annotation of /trunk/pg/macros/PGanswermacros.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 6387 - (view) (download) (as text)

1 : sh002i 5584 ################################################################################
2 :     # WeBWorK Online Homework Delivery System
3 :     # Copyright 2000-2007 The WeBWorK Project, http://openwebwork.sf.net/
4 : gage 6248 # $CVSHeader: pg/macros/PGanswermacros.pl,v 1.72 2010/02/01 01:33:05 apizer Exp $
5 : sh002i 5584 #
6 :     # This program is free software; you can redistribute it and/or modify it under
7 :     # the terms of either: (a) the GNU General Public License as published by the
8 :     # Free Software Foundation; either version 2, or (at your option) any later
9 :     # version, or (b) the "Artistic License" which comes with this package.
10 :     #
11 :     # This program is distributed in the hope that it will be useful, but WITHOUT
12 :     # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
13 :     # FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the
14 :     # Artistic License for more details.
15 :     ################################################################################
16 : gage 4997
17 : sh002i 5584 # FIXME TODO:
18 :     # Document and maybe split out: filters, graders, utilities
19 : sh002i 1050
20 :     =head1 NAME
21 :    
22 : sh002i 5584 PGanswermacros.pl - Macros for building answer evaluators.
23 : sh002i 1050
24 :     =head1 SYNPOSIS
25 :    
26 : sh002i 5584 Number Answer Evaluators:
27 : apizer 1080
28 : sh002i 5584 num_cmp() -- uses an input hash to determine parameters
29 : jj 3572
30 : sh002i 5584 std_num_cmp(), std_num_cmp_list(), std_num_cmp_abs, std_num_cmp_abs_list()
31 :     frac_num_cmp(), frac_num_cmp_list(), frac_num_cmp_abs, frac_num_cmp_abs_list()
32 :     arith_num_cmp(), arith_num_cmp_list(), arith_num_cmp_abs, arith_num_cmp_abs_list()
33 :     strict_num_cmp(), strict_num_cmp_list(), strict_num_cmp_abs, strict_num_cmp_abs_list()
34 : gage 1812
35 : sh002i 5584 numerical_compare_with_units() -- requires units as part of the answer
36 :     std_num_str_cmp() -- also accepts a set of strings as possible answers
37 : toenail 1797
38 : sh002i 5584 Function Answer Evaluators:
39 : apizer 1080
40 : sh002i 5584 fun_cmp() -- uses an input hash to determine parameters
41 : sh002i 2277
42 : sh002i 5584 function_cmp(), function_cmp_abs()
43 :     function_cmp_up_to_constant(), function_cmp_up_to_constant_abs()
44 :     multivar_function_cmp()
45 : jj 3572
46 : sh002i 5584 String Answer Evaluators:
47 : jj 3572
48 : sh002i 5584 str_cmp() -- uses an input hash to determine parameters
49 : jj 3572
50 : sh002i 5584 std_str_cmp(), std_str_cmp_list(), std_cs_str_cmp(), std_cs_str_cmp_list()
51 :     strict_str_cmp(), strict_str_cmp_list()
52 :     ordered_str_cmp(), ordered_str_cmp_list(), ordered_cs_str_cmp(), ordered_cs_str_cmp_list()
53 :     unordered_str_cmp(), unordered_str_cmp_list(), unordered_cs_str_cmp(), unordered_cs_str_cmp_list()
54 : jj 3572
55 : sh002i 5584 Miscellaneous Answer Evaluators:
56 : jj 3572
57 : sh002i 5584 checkbox_cmp()
58 :     radio_cmp()
59 : jj 3572
60 : sh002i 5584 =head1 DESCRIPTION
61 : jj 3572
62 : sh002i 5584 The macros in this file are factories which construct and return answer
63 :     evaluators for checking student answers. The macros take various arguments,
64 :     including the correct answer, and return an "answer evaluator", which is a
65 :     subroutine reference suitable for passing to the ANS* family of macro.
66 : jj 3572
67 : sh002i 5584 When called with the student's answer, the answer evaluator will compare this
68 :     answer to the correct answer that it keeps internally and returns an AnswerHash
69 :     representing the results of the comparison. Part of the answer hash is a score,
70 :     which is a number between 0 and 1 representing the correctness of the student's
71 :     answer. The fields of an AnswerHash are as follows:
72 : jj 3572
73 : sh002i 5584 score => $correctQ,
74 :     correct_ans => $originalCorrEqn,
75 :     student_ans => $modified_student_ans,
76 :     original_student_ans => $original_student_answer,
77 :     ans_message => $PGanswerMessage,
78 :     type => 'typeString',
79 :     preview_text_string => $preview_text_string,
80 :     preview_latex_string => $preview_latex_string, # optional
81 : jj 3572
82 : sh002i 5584 =over
83 : jj 3572
84 : sh002i 5584 =item C<$ans_hash{score}>
85 : jj 3572
86 : sh002i 5584 a number between 0 and 1 indicating whether the answer is correct. Fractions
87 :     allow the implementation of partial credit for incorrect answers.
88 : gage 2061
89 : sh002i 5584 =item C<$ans_hash{correct_ans}>
90 : sh002i 1050
91 : sh002i 5584 The correct answer, as supplied by the instructor and then formatted. This can
92 :     be viewed by the student after the answer date.
93 : sh002i 1050
94 : sh002i 5584 =item C<$ans_hash{student_ans}>
95 : sh002i 1050
96 : sh002i 5584 This is the student answer, after reformatting; for example the answer might be
97 :     forced to capital letters for comparison with the instructors answer. For a
98 :     numerical answer, it gives the evaluated answer. This is displayed in the
99 :     section reporting the results of checking the student answers.
100 : sh002i 1050
101 : sh002i 5584 =item C<$ans_hash{original_student_ans}>
102 : sh002i 1050
103 : sh002i 5584 This is the original student answer. This is displayed on the preview page and
104 :     may be used for sticky answers.
105 : sh002i 1050
106 : sh002i 5584 =item C<$ans_hash{ans_message}>
107 : sh002i 1050
108 : sh002i 5584 Any error message, or hint provided by the answer evaluator. This is also
109 :     displayed in the section reporting the results of checking the student answers.
110 : sh002i 1050
111 : sh002i 5584 =item C<$ans_hash{type}>
112 : sh002i 1050
113 : sh002i 5584 A string indicating the type of answer evaluator. This helps in preprocessing
114 :     the student answer for errors. Some examples: C<'number_with_units'>,
115 :     C<'function'>, C<'frac_number'>, C<'arith_number'>.
116 : sh002i 1050
117 : sh002i 5584 =item C<$ans_hash{preview_text_string}>
118 : sh002i 1050
119 : sh002i 5584 This typically shows how the student answer was parsed. It is displayed on the
120 :     preview page. For a student answer of 2sin(3x) this would be 2*sin(3*x). For
121 :     string answers it is typically the same as $ans_hash{student_ans}.
122 : sh002i 1050
123 : sh002i 5584 =item C<$ans_hash{preview_latex_string}>
124 : sh002i 1050
125 : sh002i 5584 (Optional.) This is latex version of the student answer which is used to
126 :     show a typeset view on the answer on the preview page. For a student answer of
127 :     2/3, this would be \frac{2}{3}.
128 : sh002i 1050
129 : sh002i 5584 =back
130 : sh002i 1050
131 :     =cut
132 :    
133 : sh002i 5658 # ^uses be_strict
134 : sh002i 5584 BEGIN { be_strict() }
135 : sh002i 1050
136 : sh002i 5584 # Until we get the PG cacheing business sorted out, we need to use
137 :     # PG_restricted_eval to get the correct values for some(?) PG environment
138 :     # variables. We do this once here and place the values in lexicals for later
139 :     # access.
140 : sh002i 5658
141 : sh002i 5663 # ^variable my $BR
142 : sh002i 5584 my $BR;
143 : sh002i 5663 # ^variable my $functLLimitDefault
144 : sh002i 5584 my $functLLimitDefault;
145 : sh002i 5663 # ^variable my $functULimitDefault
146 : sh002i 5584 my $functULimitDefault;
147 : sh002i 5663 # ^variable my $functVarDefault
148 : sh002i 5584 my $functVarDefault;
149 : sh002i 5663 # ^variable my $useBaseTenLog
150 : sh002i 5584 my $useBaseTenLog;
151 : apizer 6149 # ^variable my $reducedScoringPeriod
152 :     my $reducedScoringPeriod;
153 :     # ^variable my $reducedScoringValue
154 :     my $reducedScoringValue;
155 : apizer 6158 # ^variable my $enable_reduced_scoring
156 :     my $enable_reduced_scoring;
157 : apizer 6149 # ^variable my $dueDate
158 :     my $dueDate;
159 : sh002i 5658
160 :     # ^function _PGanswermacros_init
161 :     # ^uses loadMacros
162 :     # ^uses PG_restricted_eval
163 :     # ^uses $BR
164 :     # ^uses $envir{functLLimitDefault}
165 :     # ^uses $envir{functULimitDefault}
166 :     # ^uses $envir{functVarDefault}
167 :     # ^uses $envir{useBaseTenLog}
168 : apizer 6149 # ^uses $envir{reducedScoringPeriod}
169 :     # ^uses $envir{reducedScoringValue}
170 : apizer 6158 # ^uses $envir{enable_reduced_scoring}
171 : apizer 6149 # ^uses $envir{dueDate}
172 :    
173 : sh002i 5584 sub _PGanswermacros_init {
174 : gage 5643 loadMacros('PGnumericevaluators.pl'); # even if these files are already loaded they need to be initialized.
175 :     loadMacros('PGfunctionevaluators.pl');
176 :     loadMacros('PGstringevaluators.pl');
177 :     loadMacros('PGmiscevaluators.pl');
178 :    
179 : sh002i 5584 $BR = PG_restricted_eval(q/$BR/);
180 : gage 5585 $functLLimitDefault = PG_restricted_eval(q/$envir{functLLimitDefault}/);
181 :     $functULimitDefault = PG_restricted_eval(q/$envir{functULimitDefault}/);
182 :     $functVarDefault = PG_restricted_eval(q/$envir{functVarDefault}/);
183 :     $useBaseTenLog = PG_restricted_eval(q/$envir{useBaseTenLog}/);
184 : apizer 6149 $reducedScoringPeriod= PG_restricted_eval(q/$envir{reducedScoringPeriod}/);
185 :     $reducedScoringValue= PG_restricted_eval(q/$envir{reducedScoringValue}/);
186 : apizer 6158 $enable_reduced_scoring= PG_restricted_eval(q/$envir{enable_reduced_scoring}/);
187 : apizer 6149 $dueDate = PG_restricted_eval(q/$envir{dueDate}/);
188 : sh002i 1050 }
189 :    
190 : sh002i 5584 =head1 MACROS
191 : sh002i 1050
192 : sh002i 5584 =head2 Answer evaluator macros
193 : sh002i 1050
194 : sh002i 5584 The answer macros have been split up into several separate files, one for each type:
195 : sh002i 1050
196 : sh002i 5584 L<PGnumericevaluators.pl> - contains answer evaluators for evaluating numeric
197 :     values, including num_cmp() and related.
198 : sh002i 1050
199 : sh002i 5584 L<PGfunctionevaluators.pl> - contains answer evaluators for evaluating
200 :     functions, including fun_cmp() and related.
201 : sh002i 1050
202 : sh002i 5584 L<PGstringevaluators.pl> - contains answer evaluators for evaluating strings,
203 :     including str_cmp() and related.
204 : sh002i 1050
205 : sh002i 5584 L<PGtextevaluators.pl> - contains answer evaluators that handle free response
206 :     questions and questionnaires.
207 : sh002i 1050
208 : sh002i 5584 L<PGmiscevaluators.pl> - contains answer evaluators that don't seem to fit into
209 :     other categories.
210 : sh002i 1050
211 :     =cut
212 :    
213 :     ###########################################################################
214 :     ### THE FOLLOWING ARE LOCAL SUBROUTINES THAT ARE MEANT TO BE CALLED ONLY FROM THIS SCRIPT.
215 :    
216 :     ## Internal routine that converts variables into the standard array format
217 :     ##
218 :     ## IN: one of the following:
219 :     ## an undefined value (i.e., no variable was specified)
220 :     ## a reference to an array of variable names -- [var1, var2]
221 :     ## a number (the number of variables desired) -- 3
222 :     ## one or more variable names -- (var1, var2)
223 :     ## OUT: an array of variable names
224 :    
225 : sh002i 5658 # ^function get_var_array
226 :     # ^uses $functVarDefault
227 : sh002i 1050 sub get_var_array {
228 :     my $in = shift @_;
229 :     my @out;
230 :    
231 :     if( not defined($in) ) { #if nothing defined, build default array and return
232 :     @out = ( $functVarDefault );
233 :     return @out;
234 :     }
235 :     elsif( ref( $in ) eq 'ARRAY' ) { #if given an array ref, dereference and return
236 :     return @{$in};
237 :     }
238 :     elsif( $in =~ /^\d+/ ) { #if given a number, set up the array and return
239 :     if( $in == 1 ) {
240 :     $out[0] = 'x';
241 :     }
242 :     elsif( $in == 2 ) {
243 :     $out[0] = 'x';
244 :     $out[1] = 'y';
245 :     }
246 :     elsif( $in == 3 ) {
247 :     $out[0] = 'x';
248 :     $out[1] = 'y';
249 :     $out[2] = 'z';
250 :     }
251 :     else { #default to the x_1, x_2, ... convention
252 :     my ($i, $tag);
253 : jj 3572 for($i = 0; $i < $in; $i++) {$out[$i] = "${functVarDefault}_".($i+1)}
254 : sh002i 1050 }
255 :     return @out;
256 :     }
257 :     else { #if given one or more names, return as an array
258 :     unshift( @_, $in );
259 :     return @_;
260 :     }
261 :     }
262 :    
263 :     ## Internal routine that converts limits into the standard array of arrays format
264 :     ## Some of the cases are probably unneccessary, but better safe than sorry
265 :     ##
266 :     ## IN: one of the following:
267 :     ## an undefined value (i.e., no limits were specified)
268 :     ## a reference to an array of arrays of limits -- [[llim,ulim], [llim,ulim]]
269 :     ## a reference to an array of limits -- [llim, ulim]
270 :     ## an array of array references -- ([llim,ulim], [llim,ulim])
271 :     ## an array of limits -- (llim,ulim)
272 :     ## OUT: an array of array references -- ([llim,ulim], [llim,ulim]) or ([llim,ulim])
273 :    
274 : sh002i 5658 # ^function get_limits_array
275 :     # ^uses $functLLimitDefault
276 :     # ^uses $functULimitDefault
277 : sh002i 1050 sub get_limits_array {
278 :     my $in = shift @_;
279 :     my @out;
280 :    
281 :     if( not defined($in) ) { #if nothing defined, build default array and return
282 :     @out = ( [$functLLimitDefault, $functULimitDefault] );
283 :     return @out;
284 :     }
285 :     elsif( ref($in) eq 'ARRAY' ) { #$in is either ref to array, or ref to array of refs
286 :     my @deref = @{$in};
287 :    
288 :     if( ref( $in->[0] ) eq 'ARRAY' ) { #$in is a ref to an array of array refs
289 :     return @deref;
290 :     }
291 :     else { #$in was just a ref to an array of numbers
292 :     @out = ( $in );
293 :     return @out;
294 :     }
295 :     }
296 :     else { #$in was an array of references or numbers
297 :     unshift( @_, $in );
298 :    
299 :     if( ref($_[0]) eq 'ARRAY' ) { #$in was an array of references, so just return it
300 :     return @_;
301 :     }
302 :     else { #$in was an array of numbers
303 :     @out = ( \@_ );
304 :     return @out;
305 :     }
306 :     }
307 :     }
308 :    
309 :     #sub check_option_list {
310 :     # my $size = scalar(@_);
311 :     # if( ( $size % 2 ) != 0 ) {
312 :     # warn "ERROR in answer evaluator generator:\n" .
313 :     # "Usage: <CODE>str_cmp([\$ans1, \$ans2],%options)</CODE>
314 :     # or <CODE> num_cmp([\$num1, \$num2], %options)</CODE><BR>
315 :     # A list of inputs must be inclosed in square brackets <CODE>[\$ans1, \$ans2]</CODE>";
316 :     # }
317 :     #}
318 :    
319 :     # simple subroutine to display an error message when
320 :     # function compares are called with invalid parameters
321 : sh002i 5658 # ^function function_invalid_params
322 : sh002i 1050 sub function_invalid_params {
323 :     my $correctEqn = shift @_;
324 :     my $error_response = sub {
325 :     my $PGanswerMessage = "Tell your professor that there is an error with the parameters " .
326 :     "to the function answer evaluator";
327 :     return ( 0, $correctEqn, "", $PGanswerMessage );
328 :     };
329 :     return $error_response;
330 :     }
331 :    
332 : sh002i 5658 # ^function clean_up_error_msg
333 : sh002i 1050 sub clean_up_error_msg {
334 :     my $msg = $_[0];
335 :     $msg =~ s/^\[[^\]]*\][^:]*://;
336 :     $msg =~ s/Unquoted string//g;
337 :     $msg =~ s/may\s+clash.*/does not make sense here/;
338 :     $msg =~ s/\sat.*line [\d]*//g;
339 : gage 2061 $msg = 'Error: '. $msg;
340 : sh002i 1050
341 :     return $msg;
342 :     }
343 :    
344 :     #formats the student and correct answer as specified
345 :     #format must be of a form suitable for sprintf (e.g. '%0.5g'),
346 :     #with the exception that a '#' at the end of the string
347 :     #will cause trailing zeros in the decimal part to be removed
348 : sh002i 5658 # ^function prfmt
349 :     # ^uses is_a_number
350 : sh002i 1050 sub prfmt {
351 :     my($number,$format) = @_; # attention, the order of format and number are reversed
352 :     my $out;
353 :     if ($format) {
354 :     warn "Incorrect format used: $format. <BR> Format should look something like %4.5g<BR>"
355 :     unless $format =~ /^\s*%\d*\.?\d*\w#?\s*$/;
356 :    
357 :     if( $format =~ s/#\s*$// ) { # remove trailing zeros in the decimal
358 :     $out = sprintf( $format, $number );
359 :     $out =~ s/(\.\d*?)0+$/$1/;
360 :     $out =~ s/\.$//; # in case all decimal digits were zero, remove the decimal
361 :     $out =~ s/e/E/g; # only use capital E's for exponents. Little e is for 2.71828...
362 :     } elsif (is_a_number($number) ){
363 :     $out = sprintf( $format, $number );
364 :     $out =~ s/e/E/g; # only use capital E's for exponents. Little e is for 2.71828...
365 :     } else { # number is probably a string representing an arithmetic expression
366 :     $out = $number;
367 :     }
368 : apizer 1080
369 : sh002i 1050 } else {
370 :     if (is_a_number($number)) {# only use capital E's for exponents. Little e is for 2.71828...
371 :     $out = $number;
372 :     $out =~ s/e/E/g;
373 : apizer 1080 } else { # number is probably a string representing an arithmetic expression
374 : sh002i 1050 $out = $number;
375 : apizer 1080 }
376 : sh002i 1050 }
377 :     return $out;
378 :     }
379 :     #########################################################################
380 :     # Filters for answer evaluators
381 :     #########################################################################
382 :    
383 :     =head2 Filters
384 :    
385 :     =pod
386 :    
387 :     A filter is a short subroutine with the following structure. It accepts an
388 :     AnswerHash, followed by a hash of options. It returns an AnswerHash
389 :    
390 :     $ans_hash = filter($ans_hash, %options);
391 :    
392 :     See the AnswerHash.pm file for a list of entries which can be expected to be found
393 :     in an AnswerHash, such as 'student_ans', 'score' and so forth. Other entries
394 :     may be present for specialized answer evaluators.
395 :    
396 :     The hope is that a well designed set of filters can easily be combined to form
397 : apizer 1080 a new answer_evaluator and that this method will produce answer evaluators which are
398 : sh002i 1050 are more robust than the method of copying existing answer evaluators and modifying them.
399 :    
400 :     Here is an outline of how a filter is constructed:
401 :    
402 :     sub filter{
403 :     my $rh_ans = shift;
404 :     my %options = @_;
405 :     assign_option_aliases(\%options,
406 :     'alias1' => 'option5'
407 :     'alias2' => 'option7'
408 :     );
409 :     set_default_options(\%options,
410 :     '_filter_name' => 'filter',
411 :     'option5' => .0001,
412 :     'option7' => 'ascii',
413 :     'allow_unknown_options => 0,
414 :     }
415 :     .... body code of filter .......
416 :     if ($error) {
417 : apizer 1080 $rh_ans->throw_error("FILTER_ERROR", "Something went wrong");
418 : sh002i 1050 # see AnswerHash.pm for details on using the throw_error method.
419 : apizer 1080
420 : sh002i 1050 $rh_ans; #reference to an AnswerHash object is returned.
421 :     }
422 :    
423 :     =cut
424 :    
425 :     =head4 compare_numbers
426 :    
427 :    
428 :     =cut
429 :    
430 : sh002i 5658 # ^function compare_numbers
431 :     # ^uses PG_answer_eval
432 :     # ^uses clean_up_error_msg
433 :     # ^uses prfmt
434 :     # ^uses is_a_number
435 : sh002i 1050 sub compare_numbers {
436 :     my ($rh_ans, %options) = @_;
437 :     my ($inVal,$PG_eval_errors,$PG_full_error_report) = PG_answer_eval($rh_ans->{student_ans});
438 :     if ($PG_eval_errors) {
439 :     $rh_ans->throw_error('EVAL','There is a syntax error in your answer');
440 :     $rh_ans->{ans_message} = clean_up_error_msg($PG_eval_errors);
441 :     # return $rh_ans;
442 :     } else {
443 :     $rh_ans->{student_ans} = prfmt($inVal,$options{format});
444 :     }
445 : apizer 1080
446 : sh002i 1050 my $permitted_error;
447 : apizer 1080
448 : sh002i 1050 if ($rh_ans->{tolType} eq 'absolute') {
449 :     $permitted_error = $rh_ans->{tolerance};
450 :     }
451 :     elsif ( abs($rh_ans->{correct_ans}) <= $options{zeroLevel}) {
452 :     $permitted_error = $options{zeroLevelTol}; ## want $tol to be non zero
453 :     }
454 :     else {
455 :     $permitted_error = abs($rh_ans->{tolerance}*$rh_ans->{correct_ans});
456 :     }
457 : apizer 1080
458 : sh002i 1050 my $is_a_number = is_a_number($inVal);
459 :     $rh_ans->{score} = 1 if ( ($is_a_number) and
460 :     (abs( $inVal - $rh_ans->{correct_ans} ) <= $permitted_error) );
461 :     if (not $is_a_number) {
462 :     $rh_ans->{error_message} = "$rh_ans->{error_message}". 'Your answer does not evaluate to a number ';
463 :     }
464 : apizer 1080
465 : sh002i 1050 $rh_ans;
466 :     }
467 :    
468 :     =head4 std_num_filter
469 :    
470 :     std_num_filter($rh_ans, %options)
471 :     returns $rh_ans
472 :    
473 :     Replaces some constants using math_constants, then evaluates a perl expression.
474 :    
475 :    
476 :     =cut
477 :    
478 : sh002i 5658 # ^function std_num_filter
479 :     # ^uses math_constants
480 :     # ^uses PG_answer_eval
481 :     # ^uses clean_up_error_msg
482 : sh002i 1050 sub std_num_filter {
483 :     my $rh_ans = shift;
484 :     my %options = @_;
485 :     my $in = $rh_ans->input();
486 :     $in = math_constants($in);
487 :     $rh_ans->{type} = 'std_number';
488 :     my ($inVal,$PG_eval_errors,$PG_full_error_report);
489 :     if ($in =~ /\S/) {
490 :     ($inVal,$PG_eval_errors,$PG_full_error_report) = PG_answer_eval($in);
491 : apizer 1080 } else {
492 : sh002i 1050 $PG_eval_errors = '';
493 :     }
494 :    
495 : apizer 1080 if ($PG_eval_errors) { ##error message from eval or above
496 : sh002i 1050 $rh_ans->{ans_message} = 'There is a syntax error in your answer';
497 : gage 2061 $rh_ans->{student_ans} =
498 :     clean_up_error_msg($PG_eval_errors);
499 : sh002i 1050 } else {
500 :     $rh_ans->{student_ans} = $inVal;
501 :     }
502 :     $rh_ans;
503 :     }
504 :    
505 : gage 4831 =head4 std_num_array_filter
506 : sh002i 1050
507 :     std_num_array_filter($rh_ans, %options)
508 :     returns $rh_ans
509 : apizer 1080
510 : sh002i 1050 Assumes the {student_ans} field is a numerical array, and applies BOTH check_syntax and std_num_filter
511 :     to each element of the array. Does it's best to generate sensible error messages for syntax errors.
512 :     A typical error message displayed in {studnet_ans} might be ( 56, error message, -4).
513 :    
514 :     =cut
515 :    
516 : sh002i 5658 # ^function std_num_array_filter
517 :     # ^uses set_default_options
518 :     # ^uses AnswerHash::new
519 :     # ^uses check_syntax
520 :     # ^uses std_num_filter
521 : apizer 1080 sub std_num_array_filter {
522 : sh002i 1050 my $rh_ans= shift;
523 :     my %options = @_;
524 :     set_default_options( \%options,
525 : apizer 1080 '_filter_name' => 'std_num_array_filter',
526 : sh002i 1050 );
527 :     my @in = @{$rh_ans->{student_ans}};
528 :     my $temp_hash = new AnswerHash;
529 :     my @out=();
530 :     my $PGanswerMessage = '';
531 :     foreach my $item (@in) { # evaluate each number in the vector
532 :     $temp_hash->input($item);
533 :     $temp_hash = check_syntax($temp_hash);
534 :     if (defined($temp_hash->{error_flag}) and $temp_hash->{error_flag} eq 'SYNTAX') {
535 :     $PGanswerMessage .= $temp_hash->{ans_message};
536 :     $temp_hash->{ans_message} = undef;
537 :     } else {
538 :     #continue processing
539 :     $temp_hash = std_num_filter($temp_hash);
540 :     if (defined($temp_hash->{ans_message}) and $temp_hash->{ans_message} ) {
541 :     $PGanswerMessage .= $temp_hash->{ans_message};
542 :     $temp_hash->{ans_message} = undef;
543 : apizer 1080 }
544 : sh002i 1050 }
545 :     push(@out, $temp_hash->input());
546 : apizer 1080
547 : sh002i 1050 }
548 :     if ($PGanswerMessage) {
549 :     $rh_ans->input( "( " . join(", ", @out ) . " )" );
550 :     $rh_ans->throw_error('SYNTAX', 'There is a syntax error in your answer.');
551 :     } else {
552 :     $rh_ans->input( [@out] );
553 :     }
554 :     $rh_ans;
555 :     }
556 :    
557 :     =head4 function_from_string2
558 :    
559 :    
560 :    
561 :     =cut
562 :    
563 : sh002i 5658 # ^function function_from_string2
564 :     # ^uses assign_option_aliases
565 :     # ^uses set_default_options
566 :     # ^uses math_constants
567 :     # ^uses PG_restricted_eval
568 :     # ^uses PG_answer_eval
569 :     # ^uses clean_up_error_msg
570 : sh002i 1050 sub function_from_string2 {
571 :     my $rh_ans = shift;
572 :     my %options = @_;
573 :     assign_option_aliases(\%options,
574 :     'vars' => 'ra_vars',
575 :     'var' => 'ra_vars',
576 : gage 2056 'store_in' => 'stdout',
577 : sh002i 1050 );
578 :     set_default_options( \%options,
579 : gage 2056 'stdin' => 'student_ans',
580 :     'stdout' => 'rf_student_ans',
581 : sh002i 1050 'ra_vars' => [qw( x y )],
582 :     'debug' => 0,
583 : apizer 1080 '_filter_name' => 'function_from_string2',
584 : sh002i 1050 );
585 : gage 2056 # initialize
586 : sh002i 1050 $rh_ans->{_filter_name} = $options{_filter_name};
587 : gage 2056
588 : gage 2061 my $eqn = $rh_ans->{ $options{stdin} };
589 :     my @VARS = @{ $options{ 'ra_vars'} };
590 : sh002i 1050 #warn "VARS = ", join("<>", @VARS) if defined($options{debug}) and $options{debug} ==1;
591 :     my $originalEqn = $eqn;
592 : gage 2061 $eqn = &math_constants($eqn);
593 : sh002i 1050 for( my $i = 0; $i < @VARS; $i++ ) {
594 :     # This next line is a hack required for 5.6.0 -- it doesn't appear to be needed in 5.6.1
595 :     my ($temp,$er1,$er2) = PG_restricted_eval('"'. $VARS[$i] . '"');
596 : gage 2056 #$eqn =~ s/\b$VARS[$i]\b/\$VARS[$i]/g;
597 : sh002i 1050 $eqn =~ s/\b$temp\b/\$VARS[$i]/g;
598 :    
599 :     }
600 :     #warn "equation evaluated = $eqn",$rh_ans->pretty_print(), "<br>\noptions<br>\n",
601 : apizer 1080 # pretty_print(\%options)
602 : sh002i 1050 # if defined($options{debug}) and $options{debug} ==1;
603 :     my ($function_sub,$PG_eval_errors, $PG_full_errors) = PG_answer_eval( q!
604 :     sub {
605 :     my @VARS = @_;
606 : apizer 1080 my $input_str = '';
607 : sh002i 1050 for( my $i=0; $i<@VARS; $i++ ) {
608 :     $input_str .= "\$VARS[$i] = $VARS[$i]; ";
609 :     }
610 :     my $PGanswerMessage;
611 : apizer 1080 $input_str .= '! . $eqn . q!'; # need the single quotes to keep the contents of $eqn from being
612 : sh002i 1050 # evaluated when it is assigned to $input_str;
613 :     my ($out, $PG_eval_errors, $PG_full_errors) = PG_answer_eval($input_str); #Finally evaluated
614 : apizer 1080
615 : sh002i 1050 if ( defined($PG_eval_errors) and $PG_eval_errors =~ /\S/ ) {
616 : apizer 1080 $PGanswerMessage = clean_up_error_msg($PG_eval_errors);
617 : sh002i 1050 # This message seemed too verbose, but it does give extra information, we'll see if it is needed.
618 :     # "<br> There was an error in evaluating your function <br>
619 : apizer 1080 # !. $originalEqn . q! <br>
620 : sh002i 1050 # at ( " . join(', ', @VARS) . " ) <br>
621 :     # $PG_eval_errors
622 :     # "; # this message appears in the answer section which is not process by Latex2HTML so it must
623 :     # # be in HTML. That is why $BR is NOT used.
624 : apizer 1080
625 :     }
626 : sh002i 1050 (wantarray) ? ($out, $PGanswerMessage): $out; # PGanswerMessage may be undefined.
627 :     };
628 :     !);
629 :    
630 :     if (defined($PG_eval_errors) and $PG_eval_errors =~/\S/ ) {
631 :     $PG_eval_errors = clean_up_error_msg($PG_eval_errors);
632 : apizer 1080
633 :     my $PGanswerMessage = "There was an error in converting the expression
634 : gage 1250 $BR $originalEqn $BR into a function.
635 :     $BR $PG_eval_errors.";
636 : sh002i 1050 $rh_ans->{rf_student_ans} = $function_sub;
637 :     $rh_ans->{ans_message} = $PGanswerMessage;
638 :     $rh_ans->{error_message} = $PGanswerMessage;
639 :     $rh_ans->{error_flag} = 1;
640 :     # we couldn't compile the equation, we'll return an error message.
641 :     } else {
642 : gage 2056 # if (defined($options{stdout} )) {
643 :     # $rh_ans ->{$options{stdout}} = $function_sub;
644 : sh002i 1050 # } else {
645 :     # $rh_ans->{rf_student_ans} = $function_sub;
646 :     # }
647 : gage 2056 $rh_ans ->{$options{stdout}} = $function_sub;
648 : sh002i 1050 }
649 : apizer 1080
650 :     $rh_ans;
651 : sh002i 1050 }
652 :    
653 :     =head4 is_zero_array
654 :    
655 :    
656 :     =cut
657 :    
658 : sh002i 5658 # ^function is_zero_array
659 :     # ^uses is_a_number
660 : sh002i 1050 sub is_zero_array {
661 :     my $rh_ans = shift;
662 :     my %options = @_;
663 :     set_default_options( \%options,
664 : apizer 1080 '_filter_name' => 'is_zero_array',
665 : gage 2056 'tolerance' => 0.000001,
666 : gage 2061 'stdin' => 'ra_differences',
667 :     'stdout' => 'score',
668 : sh002i 1050 );
669 : gage 2056 #intialize
670 :     $rh_ans->{_filter_name} = $options{_filter_name};
671 :    
672 : gage 2061 my $array = $rh_ans -> {$options{stdin}}; # default ra_differences
673 : sh002i 1050 my $num = @$array;
674 :     my $i;
675 :     my $max = 0; my $mm;
676 :     for ($i=0; $i< $num; $i++) {
677 :     $mm = $array->[$i] ;
678 :     if (not is_a_number($mm) ) {
679 :     $max = $mm; # break out if one of the elements is not a number
680 :     last;
681 :     }
682 :     $max = abs($mm) if abs($mm) > $max;
683 :     }
684 :     if (not is_a_number($max)) {
685 :     $rh_ans->{score} = 0;
686 : apizer 1080 my $error = "WeBWorK was unable evaluate your function. Please check that your
687 : sh002i 1050 expression doesn't take roots of negative numbers, or divide by zero.";
688 :     $rh_ans->throw_error('EVAL',$error);
689 :     } else {
690 : gage 2061 $rh_ans->{$options{stdout}} = ($max < $options{tolerance} ) ? 1: 0; # set 'score' to 1 if the array is close to 0;
691 : sh002i 1050 }
692 :     $rh_ans;
693 :     }
694 :    
695 :     =head4 best_approx_parameters
696 :    
697 :     best_approx_parameters($rh_ans,%options); #requires the following fields in $rh_ans
698 :     {rf_student_ans} # reference to the test answer
699 : apizer 1080 {rf_correct_ans} # reference to the comparison answer
700 : sh002i 1050 {evaluation_points}, # an array of row vectors indicating the points
701 :     # to evaluate when comparing the functions
702 : apizer 1080
703 : sh002i 1050 %options # debug => 1 gives more error answers
704 :     # param_vars => [''] additional parameters used to adapt to function
705 :     )
706 :    
707 :    
708 :     The parameters for the comparison function which best approximates the test_function are stored
709 : apizer 1080 in the field {ra_parameters}.
710 : sh002i 1050
711 :    
712 :     The last $dim_of_parms_space variables are assumed to be parameters, and it is also
713 :     assumed that the function \&comparison_fun
714 : apizer 1080 depends linearly on these variables. This function finds the values for these parameters which minimizes the
715 : sh002i 1050 Euclidean distance (L2 distance) between the test function and the comparison function and the test points specified
716 :     by the array reference \@rows_of_test_points. This is assumed to be an array of arrays, with the inner arrays
717 : apizer 1080 determining a test point.
718 : sh002i 1050
719 :     The comparison function should have $dim_of_params_space more input variables than the test function.
720 :    
721 :    
722 :    
723 :    
724 : apizer 1080
725 : sh002i 1050 =cut
726 :    
727 :     # Used internally:
728 : apizer 1080 #
729 : sh002i 1050 # &$determine_param_coeff( $rf_comparison_function # a reference to the correct answer function
730 :     # $ra_variables # an array of the active input variables to the functions
731 : apizer 1080 # $dim_of_params_space # indicates the number of parameters upon which the
732 : sh002i 1050 # # the comparison function depends linearly. These are assumed to
733 :     # # be the last group of inputs to the comparison function.
734 : apizer 1080 #
735 : sh002i 1050 # %options # $options{debug} gives more error messages
736 : apizer 1080 #
737 :     # # A typical function might look like
738 : sh002i 1050 # # f(x,y,z,a,b) = x^2+a*cos(xz) + b*sin(x) with a parameter
739 :     # # space of dimension 2 and a variable space of dimension 3.
740 :     # )
741 :     # # returns a list of coefficients
742 : apizer 1080
743 : sh002i 5658 # ^function best_approx_parameters
744 :     # ^uses set_default_options
745 :     # ^uses pretty_print
746 :     # ^uses Matrix::new
747 :     # ^uses is_a_number
748 : sh002i 1050 sub best_approx_parameters {
749 :     my $rh_ans = shift;
750 :     my %options = @_;
751 :     set_default_options(\%options,
752 :     '_filter_name' => 'best_approx_paramters',
753 :     'allow_unknown_options' => 1,
754 :     );
755 :     my $errors = undef;
756 :     # This subroutine for the determining the coefficents of the parameters at a given point
757 :     # is pretty specialized, so it is included here as a sub-subroutine.
758 :     my $determine_param_coeffs = sub {
759 :     my ($rf_fun, $ra_variables, $dim_of_params_space, %options) =@_;
760 :     my @zero_params=();
761 :     for(my $i=1;$i<=$dim_of_params_space;$i++){push(@zero_params,0); }
762 :     my @vars = @$ra_variables;
763 :     my @coeff = ();
764 :     my @inputs = (@vars,@zero_params);
765 :     my ($f0, $f1, $err);
766 :     ($f0, $err) = &{$rf_fun}(@inputs);
767 :     if (defined($err) ) {
768 :     $errors .= "$err ";
769 :     } else {
770 :     for (my $i=@vars;$i<@inputs;$i++) {
771 :     $inputs[$i]=1; # set one parameter to 1;
772 :     my($f1,$err) = &$rf_fun(@inputs);
773 :     if (defined($err) ) {
774 :     $errors .= " $err ";
775 :     } else {
776 :     push(@coeff, $f1-$f0);
777 :     }
778 :     $inputs[$i]=0; # set it back
779 :     }
780 :     }
781 :     (\@coeff, $errors);
782 :     };
783 :     my $rf_fun = $rh_ans->{rf_student_ans};
784 :     my $rf_correct_fun = $rh_ans->{rf_correct_ans};
785 :     my $ra_vars_matrix = $rh_ans->{evaluation_points};
786 :     my $dim_of_param_space = @{$options{param_vars}};
787 :     # Short cut. Bail if there are no param_vars
788 :     unless ($dim_of_param_space >0) {
789 :     $rh_ans ->{ra_parameters} = [];
790 :     return $rh_ans;
791 :     }
792 :     # inputs are row arrays in this case.
793 :     my @zero_params=();
794 : apizer 1080
795 : sh002i 1050 for(my $i=1;$i<=$dim_of_param_space;$i++){push(@zero_params,0); }
796 :     my @rows_of_vars = @$ra_vars_matrix;
797 :     warn "input rows ", pretty_print(\@rows_of_vars) if defined($options{debug}) and $options{debug};
798 :     my $rows = @rows_of_vars;
799 : gage 6354 my $matrix = Matrix->new($rows,$dim_of_param_space);
800 :     my $rhs_vec = Matrix->new($rows, 1);
801 : sh002i 1050 my $row_num = 1;
802 :     my ($ra_coeff,$val2, $val1, $err1,$err2,@inputs,@vars);
803 :     my $number_of_data_points = $dim_of_param_space +2;
804 :     while (@rows_of_vars and $row_num <= $number_of_data_points) {
805 :     # get one set of data points from the test function;
806 : apizer 1080 @vars = @{ shift(@rows_of_vars) };
807 : sh002i 1050 ($val2, $err1) = &{$rf_fun}(@vars);
808 :     $errors .= " $err1 " if defined($err1);
809 :     @inputs = (@vars,@zero_params);
810 :     ($val1, $err2) = &{$rf_correct_fun}(@inputs);
811 :     $errors .= " $err2 " if defined($err2);
812 : apizer 1080
813 : sh002i 1050 unless (defined($err1) or defined($err2) ) {
814 :     $rhs_vec->assign($row_num,1, $val2-$val1 );
815 : apizer 1080
816 : sh002i 1050 # warn "rhs data val1=$val1, val2=$val2, val2 - val1 = ", $val2 - $val1 if $options{debug};
817 :     # warn "vars ", join(" | ", @vars) if $options{debug};
818 : apizer 1080
819 : sh002i 1050 ($ra_coeff, $err1) = &{$determine_param_coeffs}($rf_correct_fun,\@vars,$dim_of_param_space,%options);
820 :     if (defined($err1) ) {
821 :     $errors .= " $err1 ";
822 :     } else {
823 :     my @coeff = @$ra_coeff;
824 :     my $col_num=1;
825 :     while(@coeff) {
826 :     $matrix->assign($row_num,$col_num, shift(@coeff) );
827 :     $col_num++;
828 :     }
829 :     }
830 :     }
831 :     $row_num++;
832 : apizer 1080 last if $errors; # break if there are any errors.
833 : sh002i 1050 # This cuts down on the size of error messages.
834 :     # However it impossible to check for equivalence at 95% of points
835 :     # which might be useful for functions that are not defined at some points.
836 : apizer 1080 }
837 : sh002i 1050 warn "<br> best_approx_parameters: matrix1 <br> ", " $matrix " if $options{debug};
838 :     warn "<br> best_approx_parameters: vector <br> ", " $rhs_vec " if $options{debug};
839 : apizer 1080
840 : sh002i 1050 # we have Matrix * parameter = data_vec + perpendicular vector
841 :     # where the matrix has column vectors defining the span of the parameter space
842 :     # multiply both sides by Matrix_transpose and solve for the parameters
843 :     # This is exactly what the method proj_coeff method does.
844 :     my @array;
845 :     if (defined($errors) ) {
846 :     @array = (); # new Matrix($dim_of_param_space,1);
847 :     } else {
848 :     @array = $matrix->proj_coeff($rhs_vec)->list();
849 :     }
850 :     # check size (hack)
851 :     my $max = 0;
852 :     foreach my $val (@array ) {
853 :     $max = abs($val) if $max < abs($val);
854 :     if (not is_a_number($val) ) {
855 :     $max = "NaN: $val";
856 :     last;
857 :     }
858 :     }
859 :     if ($max =~/NaN/) {
860 : apizer 1080 $errors .= "WeBWorK was unable evaluate your function. Please check that your
861 : sh002i 1050 expression doesn't take roots of negative numbers, or divide by zero.";
862 :     } elsif ($max > $options{maxConstantOfIntegration} ) {
863 : apizer 1080 $errors .= "At least one of the adapting parameters
864 :     (perhaps the constant of integration) is too large: $max,
865 :     ( the maximum allowed is $options{maxConstantOfIntegration} )";
866 : sh002i 1050 }
867 : apizer 1080
868 : sh002i 1050 $rh_ans->{ra_parameters} = \@array;
869 :     $rh_ans->throw_error('EVAL', $errors) if defined($errors);
870 :     $rh_ans;
871 :     }
872 :    
873 :     =head4 calculate_difference_vector
874 :    
875 :     calculate_difference_vector( $ans_hash, %options);
876 : apizer 1080
877 : sh002i 1050 {rf_student_ans}, # a reference to the test function
878 :     {rf_correct_ans}, # a reference to the correct answer function
879 :     {evaluation_points}, # an array of row vectors indicating the points
880 :     # to evaluate when comparing the functions
881 : apizer 1080 {ra_parameters} # these are the (optional) additional inputs to
882 :     # the comparison function which adapt it properly
883 : sh002i 1050 # to the problem at hand.
884 : apizer 1080
885 :     %options # mode => 'rel' specifies that each element in the
886 : sh002i 1050 # difference matrix is divided by the correct answer.
887 :     # unless the correct answer is nearly 0.
888 : apizer 1080 )
889 : sh002i 1050
890 :     =cut
891 :    
892 : sh002i 5658 # ^function calculate_difference_vector
893 :     # ^uses assign_option_aliases
894 :     # ^uses set_default_options
895 : sh002i 1050 sub calculate_difference_vector {
896 :     my $rh_ans = shift;
897 :     my %options = @_;
898 : gage 2061 assign_option_aliases( \%options,
899 :     );
900 :     set_default_options( \%options,
901 :     allow_unknown_options => 1,
902 :     stdin1 => 'rf_student_ans',
903 :     stdin2 => 'rf_correct_ans',
904 :     stdout => 'ra_differences',
905 :     debug => 0,
906 :     tolType => 'absolute',
907 :     error_msg_flag => 1,
908 :     );
909 : sh002i 1050 # initialize
910 : gage 2061 $rh_ans->{_filter_name} = 'calculate_difference_vector';
911 :     my $rf_fun = $rh_ans -> {$options{stdin1}}; # rf_student_ans by default
912 :     my $rf_correct_fun = $rh_ans -> {$options{stdin2}}; # rf_correct_ans by default
913 :     my $ra_parameters = $rh_ans -> {ra_parameters};
914 :     my @evaluation_points = @{$rh_ans->{evaluation_points} };
915 :     my @parameters = ();
916 :     @parameters = @$ra_parameters if defined($ra_parameters) and ref($ra_parameters) eq 'ARRAY';
917 :     my $errors = undef;
918 :     my @zero_params = ();
919 :     for (my $i=1;$i<=@{$ra_parameters};$i++) {
920 :     push(@zero_params,0);
921 :     }
922 :     my @differences = ();
923 : sh002i 1050 my @student_values;
924 :     my @adjusted_student_values;
925 :     my @instructorVals;
926 :     my ($diff,$instructorVal);
927 :     # calculate the vector of differences between the test function and the comparison function.
928 :     while (@evaluation_points) {
929 :     my ($err1, $err2,$err3);
930 :     my @vars = @{ shift(@evaluation_points) };
931 :     my @inputs = (@vars, @parameters);
932 :     my ($inVal, $correctVal);
933 :     ($inVal, $err1) = &{$rf_fun}(@vars);
934 :     $errors .= " $err1 " if defined($err1);
935 : jj 2243 $errors .= " Error detected evaluating student input at (".join(' , ',@vars) ." ) " if defined($options{debug}) and $options{debug}==1 and defined($err1);
936 : sh002i 1050 ($correctVal, $err2) =&{$rf_correct_fun}(@inputs);
937 :     $errors .= " There is an error in WeBWorK's answer to this problem, please alert your instructor.<br> $err2 " if defined($err2);
938 :     $errors .= " Error detected evaluating correct adapted answer at (".join(' , ',@inputs) ." ) " if defined($options{debug}) and $options{debug}=1 and defined($err2);
939 :     ($instructorVal,$err3)= &$rf_correct_fun(@vars, @zero_params);
940 :     $errors .= " There is an error in WeBWorK's answer to this problem, please alert your instructor.<br> $err3 " if defined($err3);
941 :     $errors .= " Error detected evaluating instructor answer at (".join(' , ',@vars, @zero_params) ." ) " if defined($options{debug}) and $options{debug}=1 and defined($err3);
942 :     unless (defined($err1) or defined($err2) or defined($err3) ) {
943 :     $diff = ( $inVal - ($correctVal -$instructorVal ) ) - $instructorVal; #prevents entering too high a number?
944 :     #warn "taking the difference of ", $inVal, " and ", $correctVal, " is ", $diff;
945 : gage 2061 if ( $options{tolType} eq 'relative' ) { #relative tolerance
946 : sh002i 1050 #warn "diff = $diff";
947 :     #$diff = ( $inVal - ($correctVal-$instructorVal ) )/abs($instructorVal) -1 if abs($instructorVal) > $options{zeroLevel};
948 :     $diff = ( $inVal - ($correctVal-$instructorVal ) )/$instructorVal -1 if abs($instructorVal) > $options{zeroLevel};
949 : dpvc 4928 # DPVC -- adjust so that a check for tolerance will
950 :     # do a zeroLevelTol check
951 :     ## $diff *= $options{tolerance}/$options{zeroLevelTol} unless abs($instructorVal) > $options{zeroLevel};
952 :     # /DPVC
953 : sh002i 1050 #$diff = ( $inVal - ($correctVal-$instructorVal- $instructorVal ) )/abs($instructorVal) if abs($instructorVal) > $options{zeroLevel};
954 :     #warn "diff = $diff, ", abs( &$rf_correct_fun(@inputs) ) , "-- $correctVal";
955 :     }
956 :     }
957 : apizer 1080 last if $errors; # break if there are any errors.
958 : sh002i 1050 # This cuts down on the size of error messages.
959 :     # However it impossible to check for equivalence at 95% of points
960 :     # which might be useful for functions that are not defined at some points.
961 :     push(@student_values,$inVal);
962 : apizer 1080 push(@adjusted_student_values,( $inVal - ($correctVal -$instructorVal) ) );
963 :     push(@differences, $diff);
964 :     push(@instructorVals,$instructorVal);
965 : sh002i 1050 }
966 : gage 3039 if (( not defined($errors) ) or $errors eq '' or $options{error_msg_flag} ) {
967 : gage 2061 $rh_ans ->{$options{stdout}} = \@differences;
968 :     $rh_ans ->{ra_student_values} = \@student_values;
969 :     $rh_ans ->{ra_adjusted_student_values} = \@adjusted_student_values;
970 :     $rh_ans->{ra_instructor_values}=\@instructorVals;
971 :     $rh_ans->throw_error('EVAL', $errors) if defined($errors);
972 :     } else {
973 :    
974 :     } # no output if error_msg_flag is set to 0.
975 :    
976 : sh002i 1050 $rh_ans;
977 :     }
978 :    
979 :     =head4 fix_answer_for_display
980 :    
981 :     =cut
982 :    
983 : sh002i 5658 # ^function fix_answers_for_display
984 :     # ^uses evaluatesToNumber
985 :     # ^uses AnswerHash::new
986 :     # ^uses check_syntax
987 : sh002i 1050 sub fix_answers_for_display {
988 :     my ($rh_ans, %options) = @_;
989 :     if ( $rh_ans->{answerIsString} ==1) {
990 :     $rh_ans = evaluatesToNumber ($rh_ans, %options);
991 :     }
992 :     if (defined ($rh_ans->{student_units})) {
993 :     $rh_ans->{student_ans} = $rh_ans->{student_ans}. ' '. $rh_ans->{student_units};
994 : gage 1812
995 : sh002i 1050 }
996 : gage 1812 if ( $rh_ans->catch_error('UNITS') ) { # create preview latex string for expressions even if the units are incorrect
997 :     my $rh_temp = new AnswerHash;
998 :     $rh_temp->{student_ans} = $rh_ans->{student_ans};
999 :     $rh_temp = check_syntax($rh_temp);
1000 :     $rh_ans->{preview_latex_string} = $rh_temp->{preview_latex_string};
1001 :     }
1002 : sh002i 1050 $rh_ans->{correct_ans} = $rh_ans->{original_correct_ans};
1003 : apizer 1080
1004 : sh002i 1050 $rh_ans;
1005 :     }
1006 :    
1007 :     =head4 evaluatesToNumber
1008 :    
1009 :     =cut
1010 :    
1011 : sh002i 5658 # ^function evaluatesToNumber
1012 :     # ^uses is_a_numeric_expression
1013 :     # ^uses PG_answer_eval
1014 :     # ^uses prfmt
1015 : sh002i 1050 sub evaluatesToNumber {
1016 :     my ($rh_ans, %options) = @_;
1017 :     if (is_a_numeric_expression($rh_ans->{student_ans})) {
1018 :     my ($inVal,$PG_eval_errors,$PG_full_error_report) = PG_answer_eval($rh_ans->{student_ans});
1019 :     if ($PG_eval_errors) { # this if statement should never be run
1020 :     # change nothing
1021 :     } else {
1022 :     # change this
1023 :     $rh_ans->{student_ans} = prfmt($inVal,$options{format});
1024 :     }
1025 :     }
1026 :     $rh_ans;
1027 :     }
1028 :    
1029 :     =head4 is_numeric_expression
1030 :    
1031 :     =cut
1032 :    
1033 : sh002i 5658 # ^function is_a_numeric_expression
1034 :     # ^uses PG_answer_eval
1035 : sh002i 1050 sub is_a_numeric_expression {
1036 :     my $testString = shift;
1037 :     my $is_a_numeric_expression = 0;
1038 :     my ($inVal,$PG_eval_errors,$PG_full_error_report) = PG_answer_eval($testString);
1039 :     if ($PG_eval_errors) {
1040 :     $is_a_numeric_expression = 0;
1041 :     } else {
1042 :     $is_a_numeric_expression = 1;
1043 :     }
1044 :     $is_a_numeric_expression;
1045 :     }
1046 :    
1047 :     =head4 is_a_number
1048 :    
1049 :     =cut
1050 :    
1051 : sh002i 5658 # ^function is_a_number
1052 : sh002i 1050 sub is_a_number {
1053 :     my ($num,%options) = @_;
1054 :     my $process_ans_hash = ( ref( $num ) eq 'AnswerHash' ) ? 1 : 0 ;
1055 :     my ($rh_ans);
1056 :     if ($process_ans_hash) {
1057 :     $rh_ans = $num;
1058 :     $num = $rh_ans->{student_ans};
1059 :     }
1060 : apizer 1080
1061 : sh002i 1050 my $is_a_number = 0;
1062 :     return $is_a_number unless defined($num);
1063 :     $num =~ s/^\s*//; ## remove initial spaces
1064 :     $num =~ s/\s*$//; ## remove trailing spaces
1065 :    
1066 :     ## the following is copied from the online perl manual
1067 :     if ($num =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/){
1068 :     $is_a_number = 1;
1069 :     }
1070 : apizer 1080
1071 : sh002i 1050 if ($process_ans_hash) {
1072 :     if ($is_a_number == 1 ) {
1073 :     $rh_ans->{student_ans}=$num;
1074 :     return $rh_ans;
1075 :     } else {
1076 :     $rh_ans->{student_ans} = "Incorrect number format: You must enter a number, e.g. -6, 5.3, or 6.12E-3";
1077 :     $rh_ans->throw_error('NUMBER', 'You must enter a number, e.g. -6, 5.3, or 6.12E-3');
1078 :     return $rh_ans;
1079 :     }
1080 :     } else {
1081 :     return $is_a_number;
1082 :     }
1083 :     }
1084 :    
1085 :     =head4 is_a_fraction
1086 :    
1087 :     =cut
1088 :    
1089 : sh002i 5658 # ^function is_a_fraction
1090 : sh002i 1050 sub is_a_fraction {
1091 :     my ($num,%options) = @_;
1092 :     my $process_ans_hash = ( ref( $num ) eq 'AnswerHash' ) ? 1 : 0 ;
1093 :     my ($rh_ans);
1094 :     if ($process_ans_hash) {
1095 :     $rh_ans = $num;
1096 :     $num = $rh_ans->{student_ans};
1097 :     }
1098 : apizer 1080
1099 : sh002i 1050 my $is_a_fraction = 0;
1100 :     return $is_a_fraction unless defined($num);
1101 :     $num =~ s/^\s*//; ## remove initial spaces
1102 :     $num =~ s/\s*$//; ## remove trailing spaces
1103 : apizer 1080
1104 : sh002i 1050 if ($num =~ /^\s*\-?\s*[\/\d\.Ee\s]*$/) {
1105 :     $is_a_fraction = 1;
1106 :     }
1107 : apizer 1080
1108 : sh002i 1050 if ($process_ans_hash) {
1109 :     if ($is_a_fraction == 1 ) {
1110 :     $rh_ans->{student_ans}=$num;
1111 :     return $rh_ans;
1112 :     } else {
1113 :     $rh_ans->{student_ans} = "Not a number of fraction: You must enter a number or fraction, e.g. -6 or 7/13";
1114 :     $rh_ans->throw_error('NUMBER', 'You must enter a number, e.g. -6, 5.3, or 6.12E-3');
1115 :     return $rh_ans;
1116 :     }
1117 : apizer 1080
1118 : sh002i 1050 } else {
1119 :     return $is_a_fraction;
1120 :     }
1121 :     }
1122 :    
1123 :     =head4 phase_pi
1124 :     I often discovered that the answers I was getting, when using the arctan function would be off by phases of
1125 :     pi, which for the tangent function, were equivalent values. This method allows for this.
1126 :     =cut
1127 :    
1128 : sh002i 5658 # ^function phase_pi
1129 : sh002i 1050 sub phase_pi {
1130 :     my ($num,%options) = @_;
1131 :     my $process_ans_hash = ( ref( $num ) eq 'AnswerHash' ) ? 1 : 0 ;
1132 :     my ($rh_ans);
1133 :     if ($process_ans_hash) {
1134 :     $rh_ans = $num;
1135 :     $num = $rh_ans->{correct_ans};
1136 :     }
1137 :     while( ($rh_ans->{correct_ans}) > 3.14159265358979/2 ){
1138 :     $rh_ans->{correct_ans} -= 3.14159265358979;
1139 :     }
1140 :     while( ($rh_ans->{correct_ans}) <= -3.14159265358979/2 ){
1141 :     $rh_ans->{correct_ans} += 3.14159265358979;
1142 :     }
1143 :     $rh_ans;
1144 :     }
1145 :    
1146 :     =head4 is_an_arithemetic_expression
1147 :    
1148 :     =cut
1149 :    
1150 : sh002i 5658 # ^function is_an_arithmetic_expression
1151 : sh002i 1050 sub is_an_arithmetic_expression {
1152 :     my ($num,%options) = @_;
1153 :     my $process_ans_hash = ( ref( $num ) eq 'AnswerHash' ) ? 1 : 0 ;
1154 :     my ($rh_ans);
1155 :     if ($process_ans_hash) {
1156 :     $rh_ans = $num;
1157 :     $num = $rh_ans->{student_ans};
1158 :     }
1159 : apizer 1080
1160 : sh002i 1050 my $is_an_arithmetic_expression = 0;
1161 :     return $is_an_arithmetic_expression unless defined($num);
1162 :     $num =~ s/^\s*//; ## remove initial spaces
1163 :     $num =~ s/\s*$//; ## remove trailing spaces
1164 : apizer 1080
1165 : sh002i 1050 if ($num =~ /^[+\-*\/\^\(\)\[\]\{\}\s\d\.Ee]*$/) {
1166 :     $is_an_arithmetic_expression = 1;
1167 :     }
1168 : apizer 1080
1169 : sh002i 1050 if ($process_ans_hash) {
1170 :     if ($is_an_arithmetic_expression == 1 ) {
1171 :     $rh_ans->{student_ans}=$num;
1172 :     return $rh_ans;
1173 :     } else {
1174 : apizer 1080
1175 : sh002i 1050 $rh_ans->{student_ans} = "Not an arithmetic expression: You must enter an arithmetic expression, e.g. -6 or (2.3*4+5/3)^2";
1176 :     $rh_ans->throw_error('NUMBER', 'You must enter an arithmetic expression, e.g. -6 or (2.3*4+5/3)^2');
1177 :     return $rh_ans;
1178 :     }
1179 : apizer 1080
1180 : sh002i 1050 } else {
1181 :     return $is_an_arithmetic_expression;
1182 :     }
1183 :     }
1184 :    
1185 :     #
1186 :    
1187 :     =head4 math_constants
1188 :    
1189 :     replaces pi, e, and ^ with their Perl equivalents
1190 :     if useBaseTenLog is non-zero, convert log to logten
1191 :    
1192 :     =cut
1193 :    
1194 : sh002i 5658 # ^function math_constants
1195 : sh002i 1050 sub math_constants {
1196 :     my($in,%options) = @_;
1197 :     my $rh_ans;
1198 :     my $process_ans_hash = ( ref( $in ) eq 'AnswerHash' ) ? 1 : 0 ;
1199 :     if ($process_ans_hash) {
1200 :     $rh_ans = $in;
1201 :     $in = $rh_ans->{student_ans};
1202 : apizer 1080 }
1203 : sh002i 1050 # The code fragment above allows this filter to be used when the input is simply a string
1204 :     # as well as when the input is an AnswerHash, and options.
1205 :     $in =~s/\bpi\b/(4*atan2(1,1))/ge;
1206 :     $in =~s/\be\b/(exp(1))/ge;
1207 :     $in =~s/\^/**/g;
1208 : jj 1932 if($useBaseTenLog) {
1209 : sh002i 1050 $in =~ s/\blog\b/logten/g;
1210 :     }
1211 : apizer 1080
1212 : sh002i 1050 if ($process_ans_hash) {
1213 :     $rh_ans->{student_ans}=$in;
1214 :     return $rh_ans;
1215 :     } else {
1216 :     return $in;
1217 :     }
1218 :     }
1219 :    
1220 :    
1221 :    
1222 :     =head4 is_array
1223 :    
1224 :     is_array($rh_ans)
1225 :     returns: $rh_ans. Throws error "NOTARRAY" if this is not an array
1226 :    
1227 :     =cut
1228 :    
1229 : sh002i 5658 # ^function is_array
1230 : sh002i 1050 sub is_array {
1231 :     my $rh_ans = shift;
1232 :     # return if the result is an array
1233 :     return($rh_ans) if ref($rh_ans->{student_ans}) eq 'ARRAY' ;
1234 :     $rh_ans->throw_error("NOTARRAY","The answer is not an array");
1235 :     $rh_ans;
1236 :     }
1237 :    
1238 :     =head4 check_syntax
1239 :    
1240 :     check_syntax( $rh_ans, %options)
1241 : apizer 1080 returns an answer hash.
1242 : sh002i 1050
1243 :     latex2html preview code are installed in the answer hash.
1244 :     The input has been transformed, changing 7pi to 7*pi or 7x to 7*x.
1245 :     Syntax error messages may be generated and stored in student_ans
1246 :     Additional syntax error messages are stored in {ans_message} and duplicated in {error_message}
1247 :    
1248 :    
1249 :     =cut
1250 :    
1251 : sh002i 5658 # ^function check_syntax
1252 :     # ^uses assign_option_aliases
1253 :     # ^uses set_default_options
1254 :     # ^uses AlgParserWithImplicitExpand::new
1255 : sh002i 1050 sub check_syntax {
1256 :     my $rh_ans = shift;
1257 :     my %options = @_;
1258 : gage 2056 assign_option_aliases(\%options,
1259 :     );
1260 :     set_default_options( \%options,
1261 :     'stdin' => 'student_ans',
1262 :     'stdout' => 'student_ans',
1263 :     'ra_vars' => [qw( x y )],
1264 :     'debug' => 0,
1265 :     '_filter_name' => 'check_syntax',
1266 : gage 2061 error_msg_flag => 1,
1267 : gage 2056 );
1268 :     #initialize
1269 :     $rh_ans->{_filter_name} = $options{_filter_name};
1270 :     unless ( defined( $rh_ans->{$options{stdin}} ) ) {
1271 :     warn "Check_syntax requires an equation in the field '$options{stdin}' or input";
1272 :     $rh_ans->throw_error("1","'$options{stdin}' field not defined");
1273 : sh002i 1050 return $rh_ans;
1274 :     }
1275 : gage 2056 my $in = $rh_ans->{$options{stdin}};
1276 : sh002i 1050 my $parser = new AlgParserWithImplicitExpand;
1277 : gage 2056 my $ret = $parser -> parse($in); #for use with loops
1278 : apizer 1080
1279 : sh002i 1050 if ( ref($ret) ) { ## parsed successfully
1280 : gage 2061 # $parser -> tostring(); # FIXME? was this needed for some reason?????
1281 : sh002i 1050 $parser -> normalize();
1282 : gage 2061 $rh_ans -> {$options{stdout}} = $parser -> tostring();
1283 :     $rh_ans -> {preview_text_string} = $in;
1284 : gage 2056 $rh_ans -> {preview_latex_string} = $parser -> tolatex();
1285 : sh002i 1050
1286 : gage 2061 } elsif ($options{error_msg_flag} ) { ## error in parsing
1287 : apizer 1080
1288 : gage 2056 $rh_ans->{$options{stdout}} = 'syntax error:'. $parser->{htmlerror},
1289 : sh002i 1050 $rh_ans->{'ans_message'} = $parser -> {error_msg},
1290 :     $rh_ans->{'preview_text_string'} = '',
1291 :     $rh_ans->{'preview_latex_string'} = '',
1292 : apizer 1080 $rh_ans->throw_error('SYNTAX', 'syntax error in answer:'. $parser->{htmlerror} . "$BR" .$parser -> {error_msg});
1293 : gage 2061 } # no output is produced if there is an error and the error_msg_flag is set to zero
1294 : gage 2056 $rh_ans;
1295 : sh002i 1050
1296 :     }
1297 :    
1298 :     =head4 check_strings
1299 :    
1300 :     check_strings ($rh_ans, %options)
1301 :     returns $rh_ans
1302 :    
1303 :     =cut
1304 :    
1305 : sh002i 5658 # ^function check_strings
1306 :     # ^uses str_filters
1307 :     # ^uses str_cmp
1308 : sh002i 1050 sub check_strings {
1309 :     my ($rh_ans, %options) = @_;
1310 : apizer 1080
1311 : sh002i 1050 # if the student's answer is a number, simply return the answer hash (unchanged).
1312 : apizer 1080
1313 : sh002i 1050 # we allow constructions like -INF to be treated as a string. Thus we ignore an initial
1314 :     # - in deciding whether the student's answer is a number or string
1315 :    
1316 :     my $temp_ans = $rh_ans->{student_ans};
1317 :     $temp_ans =~ s/^\s*\-//; # remove an initial -
1318 :    
1319 :     if ( $temp_ans =~ m/[\d+\-*\/^(){}\[\]]|^\s*e\s*$|^\s*pi\s*$/) {
1320 :     # if ( $rh_ans->{answerIsString} == 1) {
1321 :     # #$rh_ans->throw_error('STRING','Incorrect Answer'); # student's answer is a number
1322 :     # }
1323 : apizer 1080 return $rh_ans;
1324 : sh002i 1050 }
1325 :     # the student's answer is recognized as a string
1326 :     my $ans = $rh_ans->{student_ans};
1327 :    
1328 :     # OVERVIEW of reminder of function:
1329 :     # if answer is correct, return correct. (adjust score to 1)
1330 :     # if answer is incorect:
1331 : apizer 1080 # 1) determine if the answer is sensible. if it is, return incorrect.
1332 : sh002i 1050 # 2) if the answer is not sensible (and incorrect), then return an error message indicating so.
1333 :     # no matter what: throw a 'STRING' error to skip numerical evaluations. (error flag skips remainder of pre_filters and evaluators)
1334 :     # last: 'STRING' post_filter will clear the error (avoiding pink screen.)
1335 :    
1336 :     my $sensibleAnswer = 0;
1337 :     $ans = str_filters( $ans, 'compress_whitespace' ); # remove trailing, leading, and double spaces.
1338 :     my ($ans_eval) = str_cmp($rh_ans->{correct_ans});
1339 : dpvc 3615 my $temp_ans_hash = $ans_eval->evaluate($ans);
1340 : sh002i 1050 $rh_ans->{test} = $temp_ans_hash;
1341 : gage 1506
1342 : sh002i 1050 if ($temp_ans_hash->{score} ==1 ) { # students answer matches the correct answer.
1343 : apizer 1080 $rh_ans->{score} = 1;
1344 : sh002i 1050 $sensibleAnswer = 1;
1345 :     } else { # students answer does not match the correct answer.
1346 :     my $legalString = ''; # find out if string makes sense
1347 :     my @legalStrings = @{$options{strings}};
1348 :     foreach $legalString (@legalStrings) {
1349 :     if ( uc($ans) eq uc($legalString) ) {
1350 :     $sensibleAnswer = 1;
1351 :     last;
1352 :     }
1353 :     }
1354 :     $sensibleAnswer = 1 unless $ans =~ /\S/; ## empty answers are sensible
1355 :     $rh_ans->throw_error('EVAL', "Your answer is not a recognized answer") unless ($sensibleAnswer);
1356 :     # $temp_ans_hash -> setKeys( 'ans_message' => 'Your answer is not a recognized answer' ) unless ($sensibleAnswer);
1357 :     # $temp_ans_hash -> setKeys( 'student_ans' => uc($ans) );
1358 :     }
1359 : gage 1506
1360 : sh002i 1050 $rh_ans->{student_ans} = $ans;
1361 : gage 1506
1362 : sh002i 1050 if ($sensibleAnswer) {
1363 :     $rh_ans->throw_error('STRING', "The student's answer $rh_ans->{student_ans} is interpreted as a string.");
1364 :     }
1365 : gage 1506
1366 :     $rh_ans->{'preview_text_string'} = $ans,
1367 :     $rh_ans->{'preview_latex_string'} = $ans,
1368 :    
1369 : sh002i 1050 # warn ("\$rh_ans->{answerIsString} = $rh_ans->{answerIsString}");
1370 :     $rh_ans;
1371 :     }
1372 :    
1373 :     =head4 check_units
1374 :    
1375 :     check_strings ($rh_ans, %options)
1376 :     returns $rh_ans
1377 :    
1378 :    
1379 :     =cut
1380 :    
1381 : sh002i 5658 # ^function check_units
1382 :     # ^uses str_filters
1383 :     # ^uses Units::evaluate_units
1384 :     # ^uses clean_up_error_msg
1385 :     # ^uses prfmt
1386 : sh002i 1050 sub check_units {
1387 :     my ($rh_ans, %options) = @_;
1388 :     my %correct_units = %{$rh_ans-> {rh_correct_units}};
1389 :     my $ans = $rh_ans->{student_ans};
1390 :     # $ans = '' unless defined ($ans);
1391 :     $ans = str_filters ($ans, 'trim_whitespace');
1392 :     my $original_student_ans = $ans;
1393 :     $rh_ans->{original_student_ans} = $original_student_ans;
1394 : apizer 1080
1395 : sh002i 1050 # it surprises me that the match below works since the first .* is greedy.
1396 :     my ($num_answer, $units) = $ans =~ /^(.*)\s+([^\s]*)$/;
1397 : apizer 1080
1398 : sh002i 1050 unless ( defined($num_answer) && $units ) {
1399 :     # there is an error reading the input
1400 :     if ( $ans =~ /\S/ ) { # the answer is not blank
1401 :     $rh_ans -> setKeys( 'ans_message' => "The answer \"$ans\" could not be interpreted " .
1402 :     "as a number or an arithmetic expression followed by a unit specification. " .
1403 :     "Your answer must contain units." );
1404 :     $rh_ans->throw_error('UNITS', "The answer \"$ans\" could not be interpreted " .
1405 :     "as a number or an arithmetic expression followed by a unit specification. " .
1406 :     "Your answer must contain units." );
1407 :     }
1408 :     return $rh_ans;
1409 :     }
1410 :    
1411 :     # we have been able to parse the answer into a numerical part and a unit part
1412 :    
1413 :     # $num_answer = $1; #$1 and $2 from the regular expression above
1414 :     # $units = $2;
1415 :    
1416 :     my %units = Units::evaluate_units($units);
1417 :     if ( defined( $units{'ERROR'} ) ) {
1418 :     # handle error condition
1419 :     $units{'ERROR'} = clean_up_error_msg($units{'ERROR'});
1420 :     $rh_ans -> setKeys( 'ans_message' => "$units{'ERROR'}" );
1421 :     $rh_ans -> throw_error('UNITS', "$units{'ERROR'}");
1422 :     return $rh_ans;
1423 :     }
1424 :    
1425 :     my $units_match = 1;
1426 :     my $fund_unit;
1427 :     foreach $fund_unit (keys %correct_units) {
1428 :     next if $fund_unit eq 'factor';
1429 :     $units_match = 0 unless $correct_units{$fund_unit} == $units{$fund_unit};
1430 :     }
1431 : apizer 1080
1432 : sh002i 1050 if ( $units_match ) {
1433 :     # units are ok. Evaluate the numerical part of the answer
1434 :     $rh_ans->{'tolerance'} = $rh_ans->{'tolerance'}* $correct_units{'factor'}/$units{'factor'} if
1435 :     $rh_ans->{'tolType'} eq 'absolute'; # the tolerance is in the units specified by the instructor.
1436 :     $rh_ans->{correct_ans} = prfmt($rh_ans->{correct_ans}*$correct_units{'factor'}/$units{'factor'});
1437 :     $rh_ans->{student_units} = $units;
1438 :     $rh_ans->{student_ans} = $num_answer;
1439 :    
1440 :     } else {
1441 :     $rh_ans -> setKeys( ans_message => 'There is an error in the units for this answer.' );
1442 :     $rh_ans -> throw_error ( 'UNITS', 'There is an error in the units for this answer.' );
1443 :     }
1444 : apizer 1080
1445 : sh002i 1050 return $rh_ans;
1446 :     }
1447 :    
1448 :    
1449 :    
1450 :    
1451 :     =head4 std_problem_grader
1452 :    
1453 :     This is an all-or-nothing grader. A student must get all parts of the problem write
1454 :     before receiving credit. You should make sure to use this grader on multiple choice
1455 :     and true-false questions, otherwise students will be able to deduce how many
1456 :     answers are correct by the grade reported by webwork.
1457 : apizer 1080
1458 :    
1459 : sh002i 1050 install_problem_grader(~~&std_problem_grader);
1460 :    
1461 :     =cut
1462 :    
1463 : sh002i 5658 # ^function std_problem_grader
1464 : sh002i 1050 sub std_problem_grader {
1465 :     my $rh_evaluated_answers = shift;
1466 :     my $rh_problem_state = shift;
1467 :     my %form_options = @_;
1468 :     my %evaluated_answers = %{$rh_evaluated_answers};
1469 :     # The hash $rh_evaluated_answers typically contains:
1470 :     # 'answer1' => 34, 'answer2'=> 'Mozart', etc.
1471 :    
1472 :     # By default the old problem state is simply passed back out again.
1473 :     my %problem_state = %$rh_problem_state;
1474 :    
1475 :     # %form_options might include
1476 :     # The user login name
1477 :     # The permission level of the user
1478 :     # The studentLogin name for this psvn.
1479 :     # Whether the form is asking for a refresh or is submitting a new answer.
1480 :    
1481 :     # initial setup of the answer
1482 :     my %problem_result = ( score => 0,
1483 :     errors => '',
1484 :     type => 'std_problem_grader',
1485 :     msg => '',
1486 :     );
1487 :     # Checks
1488 :    
1489 :     my $ansCount = keys %evaluated_answers; # get the number of answers
1490 : apizer 1080
1491 : sh002i 1050 unless ($ansCount > 0 ) {
1492 : apizer 1080
1493 : sh002i 1050 $problem_result{msg} = "This problem did not ask any questions.";
1494 :     return(\%problem_result,\%problem_state);
1495 :     }
1496 :    
1497 :     if ($ansCount > 1 ) {
1498 :     $problem_result{msg} = 'In order to get credit for this problem all answers must be correct.' ;
1499 :     }
1500 :    
1501 :     unless ($form_options{answers_submitted} == 1) {
1502 :     return(\%problem_result,\%problem_state);
1503 :     }
1504 :    
1505 :     my $allAnswersCorrectQ=1;
1506 :     foreach my $ans_name (keys %evaluated_answers) {
1507 :     # I'm not sure if this check is really useful.
1508 :     if ( ( ref($evaluated_answers{$ans_name} ) eq 'HASH' ) or ( ref($evaluated_answers{$ans_name}) eq 'AnswerHash' ) ) {
1509 :     $allAnswersCorrectQ = 0 unless( 1 == $evaluated_answers{$ans_name}->{score} );
1510 :     }
1511 :     else {
1512 :     die "Error at file ",__FILE__,"line ", __LINE__,": Answer |$ans_name| is not a hash reference\n".
1513 :     $evaluated_answers{$ans_name} .
1514 :     "This probably means that the answer evaluator for this answer\n" .
1515 :     "is not working correctly.";
1516 :     $problem_result{error} = "Error: Answer $ans_name is not a hash: $evaluated_answers{$ans_name}";
1517 :     }
1518 :     }
1519 :     # report the results
1520 :     $problem_result{score} = $allAnswersCorrectQ;
1521 : apizer 6149
1522 :     $problem_state{num_of_correct_ans}++ if $allAnswersCorrectQ == 1;
1523 :     $problem_state{num_of_incorrect_ans}++ if $allAnswersCorrectQ == 0;
1524 : sh002i 1050
1525 : apizer 6149 # Determine if we are in the reduced scoring period and act accordingly
1526 :    
1527 :     my $reducedScoringPeriodSec = $reducedScoringPeriod*60; # $reducedScoringPeriod is in minutes
1528 : apizer 6158 if (!$enable_reduced_scoring or time() < ($dueDate - $reducedScoringPeriodSec)) { # the reduced scoring period is disabled or it is before the reduced scoring period
1529 : apizer 6149 # increase recorded score if the current score is greater.
1530 :     $problem_state{recorded_score} = $problem_result{score} if $problem_result{score} > $problem_state{recorded_score};
1531 :     # the sub_recored_score holds the recored_score before entering the reduced scoring period
1532 :     $problem_state{sub_recorded_score} = $problem_state{recorded_score};
1533 : sh002i 1050 }
1534 : apizer 6195 elsif (time() < $dueDate) { # we are in the reduced scoring period.
1535 : apizer 6149 # student gets credit for all work done before the reduced scoring period plus a portion of work done during period
1536 :     my $newScore = 0;
1537 :     $newScore = $problem_state{sub_recorded_score} + $reducedScoringValue*($problem_result{score} - $problem_state{sub_recorded_score}) if ($problem_result{score} > $problem_state{sub_recorded_score});
1538 :     $problem_state{recorded_score} = $newScore if $newScore > $problem_state{recorded_score};
1539 :     my $reducedScoringPerCent = int(100*$reducedScoringValue+.5);
1540 : apizer 6195 $problem_result{msg} = $problem_result{msg}."<br />You are in the Reduced Credit Period: All additional work done counts $reducedScoringPerCent\% of the original.";
1541 : sh002i 1050 }
1542 :    
1543 : gage 3393 $problem_state{state_summary_msg} = ''; # an HTML formatted message printed at the bottom of the problem page
1544 :    
1545 : sh002i 1050 (\%problem_result, \%problem_state);
1546 :     }
1547 :    
1548 :     =head4 std_problem_grader2
1549 :    
1550 :     This is an all-or-nothing grader. A student must get all parts of the problem write
1551 :     before receiving credit. You should make sure to use this grader on multiple choice
1552 :     and true-false questions, otherwise students will be able to deduce how many
1553 :     answers are correct by the grade reported by webwork.
1554 : apizer 1080
1555 :    
1556 : sh002i 1050 install_problem_grader(~~&std_problem_grader2);
1557 : apizer 1080
1558 : sh002i 1050 The only difference between the two versions
1559 :     is at the end of the subroutine, where std_problem_grader2
1560 :     records the attempt only if there have been no syntax errors,
1561 :     whereas std_problem_grader records it regardless.
1562 :    
1563 :     =cut
1564 :    
1565 :    
1566 :    
1567 : sh002i 5658 # ^function std_problem_grader2
1568 : sh002i 1050 sub std_problem_grader2 {
1569 :     my $rh_evaluated_answers = shift;
1570 :     my $rh_problem_state = shift;
1571 :     my %form_options = @_;
1572 :     my %evaluated_answers = %{$rh_evaluated_answers};
1573 :     # The hash $rh_evaluated_answers typically contains:
1574 :     # 'answer1' => 34, 'answer2'=> 'Mozart', etc.
1575 :    
1576 :     # By default the old problem state is simply passed back out again.
1577 :     my %problem_state = %$rh_problem_state;
1578 :    
1579 :     # %form_options might include
1580 :     # The user login name
1581 :     # The permission level of the user
1582 :     # The studentLogin name for this psvn.
1583 :     # Whether the form is asking for a refresh or is submitting a new answer.
1584 :    
1585 :     # initial setup of the answer
1586 :     my %problem_result = ( score => 0,
1587 :     errors => '',
1588 :     type => 'std_problem_grader',
1589 :     msg => '',
1590 :     );
1591 :    
1592 :     # syntax errors are not counted.
1593 :     my $record_problem_attempt = 1;
1594 :     # Checks
1595 : apizer 6149 # FIXME: syntax errors are never checked for so this grader does not perform as advertised
1596 : sh002i 1050
1597 :     my $ansCount = keys %evaluated_answers; # get the number of answers
1598 :     unless ($ansCount > 0 ) {
1599 :     $problem_result{msg} = "This problem did not ask any questions.";
1600 :     return(\%problem_result,\%problem_state);
1601 :     }
1602 :    
1603 :     if ($ansCount > 1 ) {
1604 :     $problem_result{msg} = 'In order to get credit for this problem all answers must be correct.' ;
1605 :     }
1606 :    
1607 :     unless ($form_options{answers_submitted} == 1) {
1608 :     return(\%problem_result,\%problem_state);
1609 :     }
1610 :    
1611 :     my $allAnswersCorrectQ=1;
1612 :     foreach my $ans_name (keys %evaluated_answers) {
1613 :     # I'm not sure if this check is really useful.
1614 :     if ( ( ref($evaluated_answers{$ans_name} ) eq 'HASH' ) or ( ref($evaluated_answers{$ans_name}) eq 'AnswerHash' ) ) {
1615 :     $allAnswersCorrectQ = 0 unless( 1 == $evaluated_answers{$ans_name}->{score} );
1616 :     }
1617 :     else {
1618 :     die "Error at file ",__FILE__,"line ", __LINE__,": Answer |$ans_name| is not a hash reference\n".
1619 :     $evaluated_answers{$ans_name} .
1620 :     "This probably means that the answer evaluator for this answer\n" .
1621 :     "is not working correctly.";
1622 :     $problem_result{error} = "Error: Answer $ans_name is not a hash: $evaluated_answers{$ans_name}";
1623 :     }
1624 :     }
1625 :     # report the results
1626 :     $problem_result{score} = $allAnswersCorrectQ;
1627 :    
1628 : apizer 6149 # Determine if we are in the reduced scoring period and act accordingly
1629 :    
1630 :     my $reducedScoringPeriodSec = $reducedScoringPeriod*60; # $reducedScoringPeriod is in minutes
1631 : apizer 6158 if (!$enable_reduced_scoring or time() < ($dueDate - $reducedScoringPeriodSec)) { # the reduced scoring period is disabled or it is before the reduced scoring period
1632 : apizer 6149 # increase recorded score if the current score is greater.
1633 :     $problem_state{recorded_score} = $problem_result{score} if $problem_result{score} > $problem_state{recorded_score};
1634 :     # the sub_recored_score holds the recored_score before entering the reduced scoring period
1635 :     $problem_state{sub_recorded_score} = $problem_state{recorded_score};
1636 : sh002i 1050 }
1637 : apizer 6195 elsif (time() < $dueDate) { # we are in the reduced scoring period.
1638 : apizer 6149 # student gets credit for all work done before the reduced scoring period plus a portion of work done during period
1639 :     my $newScore = 0;
1640 :     $newScore = $problem_state{sub_recorded_score} + $reducedScoringValue*($problem_result{score} - $problem_state{sub_recorded_score}) if ($problem_result{score} > $problem_state{sub_recorded_score});
1641 :     $problem_state{recorded_score} = $newScore if $newScore > $problem_state{recorded_score};
1642 :     my $reducedScoringPerCent = int(100*$reducedScoringValue+.5);
1643 : apizer 6195 $problem_result{msg} = $problem_result{msg}."<br />You are in the Reduced Credit Period: All additional work done counts $reducedScoringPerCent\% of the original.";
1644 : sh002i 1050 }
1645 :     # record attempt only if there have been no syntax errors.
1646 :    
1647 :     if ($record_problem_attempt == 1) {
1648 :     $problem_state{num_of_correct_ans}++ if $allAnswersCorrectQ == 1;
1649 :     $problem_state{num_of_incorrect_ans}++ if $allAnswersCorrectQ == 0;
1650 : gage 3393 $problem_state{state_summary_msg} = ''; # an HTML formatted message printed at the bottom of the problem page
1651 :    
1652 : sh002i 1050 }
1653 :     else {
1654 :     $problem_result{show_partial_correct_answers} = 0 ; # prevent partial correct answers from being shown for syntax errors.
1655 :     }
1656 :     (\%problem_result, \%problem_state);
1657 :     }
1658 :    
1659 :     =head4 avg_problem_grader
1660 :    
1661 : apizer 1080 This grader gives a grade depending on how many questions from the problem are correct. (The highest
1662 : sh002i 1050 grade is the one that is kept. One can never lower the recorded grade on a problem by repeating it.)
1663 :     Many professors (and almost all students :-) ) prefer this grader.
1664 : apizer 1080
1665 :    
1666 : sh002i 1050 install_problem_grader(~~&avg_problem_grader);
1667 :    
1668 :     =cut
1669 :    
1670 : sh002i 5658 # ^function avg_problem_grader
1671 : apizer 1080 sub avg_problem_grader {
1672 : sh002i 1050 my $rh_evaluated_answers = shift;
1673 :     my $rh_problem_state = shift;
1674 :     my %form_options = @_;
1675 :     my %evaluated_answers = %{$rh_evaluated_answers};
1676 :     # The hash $rh_evaluated_answers typically contains:
1677 :     # 'answer1' => 34, 'answer2'=> 'Mozart', etc.
1678 :    
1679 :     # By default the old problem state is simply passed back out again.
1680 :     my %problem_state = %$rh_problem_state;
1681 :    
1682 :     # %form_options might include
1683 :     # The user login name
1684 :     # The permission level of the user
1685 :     # The studentLogin name for this psvn.
1686 :     # Whether the form is asking for a refresh or is submitting a new answer.
1687 :    
1688 :     # initial setup of the answer
1689 :     my $total=0;
1690 :     my %problem_result = ( score => 0,
1691 :     errors => '',
1692 :     type => 'avg_problem_grader',
1693 :     msg => '',
1694 :     );
1695 :     my $count = keys %evaluated_answers;
1696 :     $problem_result{msg} = 'You can earn partial credit on this problem.' if $count >1;
1697 :     # Return unless answers have been submitted
1698 :     unless ($form_options{answers_submitted} == 1) {
1699 :     return(\%problem_result,\%problem_state);
1700 :     }
1701 :    
1702 :     # Answers have been submitted -- process them.
1703 :     foreach my $ans_name (keys %evaluated_answers) {
1704 :     # I'm not sure if this check is really useful.
1705 :     if ( ( ref($evaluated_answers{$ans_name} ) eq 'HASH' ) or ( ref($evaluated_answers{$ans_name}) eq 'AnswerHash' ) ) {
1706 :     $total += $evaluated_answers{$ans_name}->{score};
1707 :     }
1708 :     else {
1709 :     die "Error: Answer |$ans_name| is not a hash reference\n".
1710 :     $evaluated_answers{$ans_name} .
1711 :     "This probably means that the answer evaluator for this answer\n" .
1712 :     "is not working correctly.";
1713 :     $problem_result{error} = "Error: Answer $ans_name is not a hash: $evaluated_answers{$ans_name}";
1714 :     }
1715 :     }
1716 :     # Calculate score rounded to three places to avoid roundoff problems
1717 :     $problem_result{score} = $total/$count if $count;
1718 :    
1719 : apizer 6149 $problem_state{num_of_correct_ans}++ if $total == $count;
1720 :     $problem_state{num_of_incorrect_ans}++ if $total < $count;
1721 : sh002i 1050
1722 : apizer 6158 # Determine if we are in the reduced scoring period and if the reduced scoring period is enabled and act accordingly
1723 :     #warn("enable_reduced_scoring is $enable_reduced_scoring");
1724 :     # warn("dueDate is $dueDate");
1725 : apizer 6149 my $reducedScoringPeriodSec = $reducedScoringPeriod*60; # $reducedScoringPeriod is in minutes
1726 : apizer 6158 if (!$enable_reduced_scoring or time() < ($dueDate - $reducedScoringPeriodSec)) { # the reduced scoring period is disabled or it is before the reduced scoring period
1727 : apizer 6149 # increase recorded score if the current score is greater.
1728 :     $problem_state{recorded_score} = $problem_result{score} if $problem_result{score} > $problem_state{recorded_score};
1729 :     # the sub_recored_score holds the recored_score before entering the reduced scoring period
1730 :     $problem_state{sub_recorded_score} = $problem_state{recorded_score};
1731 :     }
1732 : apizer 6195 elsif (time() < $dueDate) { # we are in the reduced scoring period.
1733 : apizer 6149 # student gets credit for all work done before the reduced scoring period plus a portion of work done during period
1734 :     my $newScore = 0;
1735 :     $newScore = $problem_state{sub_recorded_score} + $reducedScoringValue*($problem_result{score} - $problem_state{sub_recorded_score}) if ($problem_result{score} > $problem_state{sub_recorded_score});
1736 :     $problem_state{recorded_score} = $newScore if $newScore > $problem_state{recorded_score};
1737 :     my $reducedScoringPerCent = int(100*$reducedScoringValue+.5);
1738 : apizer 6195 $problem_result{msg} = $problem_result{msg}."<br />You are in the Reduced Credit Period: All additional work done counts $reducedScoringPerCent\% of the original.";
1739 : apizer 6149 }
1740 : gage 3393
1741 :     $problem_state{state_summary_msg} = ''; # an HTML formatted message printed at the bottom of the problem page
1742 : apizer 6149
1743 : sh002i 1050 warn "Error in grading this problem the total $total is larger than $count" if $total > $count;
1744 :     (\%problem_result, \%problem_state);
1745 :     }
1746 :    
1747 :     =head2 Utility subroutines
1748 :    
1749 : gage 4832 =head4 pretty_print
1750 : sh002i 1050
1751 : gage 4832 Usage: warn pretty_print( $rh_hash_input)
1752 :     TEXT(pretty_print($ans_hash));
1753 :     TEXT(~~%envir);
1754 : apizer 1080
1755 : sh002i 1050 This can be very useful for printing out messages about objects while debugging
1756 :    
1757 :     =cut
1758 :    
1759 : sh002i 5658 # ^function pretty_print
1760 :     # ^uses lex_sort
1761 :     # ^uses pretty_print
1762 : mgage 6292 # sub pretty_print {
1763 :     # my $r_input = shift;
1764 :     # my $out = '';
1765 :     # if ( not ref($r_input) ) {
1766 :     # $out = $r_input if defined $r_input; # not a reference
1767 :     # $out =~ s/</&lt;/g ; # protect for HTML output
1768 :     # } elsif ("$r_input" =~/hash/i) { # this will pick up objects whose '$self' is hash and so works better than ref($r_iput).
1769 :     # local($^W) = 0;
1770 :     #
1771 :     # $out .= "$r_input " ."<TABLE border = \"2\" cellpadding = \"3\" BGCOLOR = \"#FFFFFF\">";
1772 :     #
1773 :     #
1774 :     # foreach my $key (lex_sort( keys %$r_input )) {
1775 :     # $out .= "<tr><TD> $key</TD><TD>=&gt;</td><td>&nbsp;".pretty_print($r_input->{$key}) . "</td></tr>";
1776 :     # }
1777 :     #
1778 :     #
1779 :     #
1780 :     # $out .="</table>";
1781 :     # } elsif (ref($r_input) eq 'ARRAY' ) {
1782 :     # my @array = @$r_input;
1783 :     # $out .= "( " ;
1784 :     # while (@array) {
1785 :     # $out .= pretty_print(shift @array) . " , ";
1786 :     # }
1787 :     # $out .= " )";
1788 :     # } elsif (ref($r_input) eq 'CODE') {
1789 :     # $out = "$r_input";
1790 :     # } else {
1791 :     # $out = $r_input;
1792 :     # $out =~ s/</&lt;/g ; # protect for HTML output
1793 :     # }
1794 :     # $out;
1795 :     # }
1796 : sh002i 1050
1797 :     1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9