Parent Directory
| 
Revision Log
Roll back my changes. Use Davide's method of detecting the preview Button
1 # This file is PGanswermacros.pl 2 # This includes the subroutines for the ANS macros, that 3 # is, macros allowing a more flexible answer checking 4 #################################################################### 5 # Copyright @ 1995-2000 University of Rochester 6 # All Rights Reserved 7 #################################################################### 8 #$Id$ 9 10 =head1 NAME 11 12 PGanswermacros.pl -- located in the courseScripts directory 13 14 =head1 SYNPOSIS 15 16 Number Answer Evaluators: 17 num_cmp() -- uses an input hash to determine parameters 18 19 std_num_cmp(), std_num_cmp_list(), std_num_cmp_abs, std_num_cmp_abs_list() 20 frac_num_cmp(), frac_num_cmp_list(), frac_num_cmp_abs, frac_num_cmp_abs_list() 21 arith_num_cmp(), arith_num_cmp_list(), arith_num_cmp_abs, arith_num_cmp_abs_list() 22 strict_num_cmp(), strict_num_cmp_list(), strict_num_cmp_abs, strict_num_cmp_abs_list() 23 numerical_compare_with_units() -- requires units as part of the answer 24 std_num_str_cmp() -- also accepts a set of strings as possible answers 25 26 Function Answer Evaluators: 27 fun_cmp() -- uses an input hash to determine parameters 28 29 function_cmp(), function_cmp_abs() 30 function_cmp_up_to_constant(), function_cmp_up_to_constant_abs() 31 multivar_function_cmp() 32 33 String Answer Evaluators: 34 str_cmp() -- uses an input hash to determine parameters 35 36 std_str_cmp(), std_str_cmp_list(), std_cs_str_cmp(), std_cs_str_cmp_list() 37 strict_str_cmp(), strict_str_cmp_list() 38 ordered_str_cmp(), ordered_str_cmp_list(), ordered_cs_str_cmp(), ordered_cs_str_cmp_list() 39 unordered_str_cmp(), unordered_str_cmp_list(), unordered_cs_str_cmp(), unordered_cs_str_cmp_list() 40 41 Miscellaneous Answer Evaluators: 42 checkbox_cmp() 43 radio_cmp() 44 45 =cut 46 47 =head1 DESCRIPTION 48 49 This file adds subroutines which create "answer evaluators" for checking 50 answers. Each answer evaluator accepts a single input from a student answer, 51 checks it and creates an output hash %ans_hash with seven or eight entries 52 (the preview_latex_string is optional). The output hash is now being created 53 with the AnswerHash package "class", which is located at the end of this file. 54 This class is currently just a wrapper for the hash, but this might change in 55 the future as new capabilities are added. 56 57 score => $correctQ, 58 correct_ans => $originalCorrEqn, 59 student_ans => $modified_student_ans 60 original_student_ans => $original_student_answer, 61 ans_message => $PGanswerMessage, 62 type => 'typeString', 63 preview_text_string => $preview_text_string, 64 preview_latex_string => $preview_latex_string 65 66 67 $ans_hash{score} -- a number between 0 and 1 indicating 68 whether the answer is correct. Fractions 69 allow the implementation of partial 70 credit for incorrect answers. 71 $ans_hash{correct_ans} -- The correct answer, as supplied by the 72 instructor and then formatted. This can 73 be viewed by the student after the answer date. 74 $ans_hash{student_ans} -- This is the student answer, after reformatting; 75 for example the answer might be forced 76 to capital letters for comparison with 77 the instructors answer. For a numerical 78 answer, it gives the evaluated answer. 79 This is displayed in the section reporting 80 the results of checking the student answers. 81 $ans_hash{original_student_ans} -- This is the original student answer. This is displayed 82 on the preview page and may be used for sticky answers. 83 $ans_hash{ans_message} -- Any error message, or hint provided by the answer evaluator. 84 This is also displayed in the section reporting 85 the results of checking the student answers. 86 $ans_hash{type} -- A string indicating the type of answer evaluator. This 87 helps in preprocessing the student answer for errors. 88 Some examples: 89 'number_with_units' 90 'function' 91 'frac_number' 92 'arith_number' 93 $ans_hash{preview_text_string} -- This typically shows how the student answer was parsed. It is 94 displayed on the preview page. For a student answer of 2sin(3x) 95 this would be 2*sin(3*x). For string answers it is typically the 96 same as $ans_hash{student_ans}. 97 $ans_hash{preview_latex_string} -- THIS IS OPTIONAL. This is latex version of the student answer 98 which is used to show a typeset view on the answer on the preview 99 page. For a student answer of 2/3, this would be \frac{2}{3}. 100 101 Technical note: the routines in this file are not actually answer evaluators. Instead, they create 102 answer evaluators. An answer evaluator is an anonymous subroutine, referenced by a named scalar. The 103 routines in this file build the subroutine and return a reference to it. Later, when the student 104 actually enters an answer, the problem processor feeds that answer to the referenced subroutine, which 105 evaluates it and returns a score (usually 0 or 1). For most users, this distinction is unimportant, but 106 if you plan on writing your own answer evaluators, you should understand this point. 107 108 =cut 109 110 BEGIN { 111 be_strict(); # an alias for use strict. This means that all global variable must contain main:: as a prefix. 112 } 113 114 115 my ($BR , # convenient localizations. 116 $PAR , 117 $numRelPercentTolDefault , 118 $numZeroLevelDefault , 119 $numZeroLevelTolDefault , 120 $numAbsTolDefault , 121 $numFormatDefault , 122 $functRelPercentTolDefault , 123 $functZeroLevelDefault , 124 $functZeroLevelTolDefault , 125 $functAbsTolDefault , 126 $functNumOfPoints , 127 $functVarDefault , 128 $functLLimitDefault , 129 $functULimitDefault , 130 $functMaxConstantOfIntegration , 131 $CA , 132 $rh_envir , 133 $useBaseTenLog , 134 $inputs_ref , 135 $QUESTIONNAIRE_ANSWERS , 136 $user_context, 137 $Context, 138 ); 139 140 141 142 143 sub _PGanswermacros_init { 144 145 $BR = main::PG_restricted_eval(q!$main::BR!); 146 $PAR = main::PG_restricted_eval(q!$main::PAR!); 147 148 # import defaults 149 # these are now imported from the %envir variable 150 $numRelPercentTolDefault = main::PG_restricted_eval(q!$main::numRelPercentTolDefault!); 151 $numZeroLevelDefault = main::PG_restricted_eval(q!$main::numZeroLevelDefault!); 152 $numZeroLevelTolDefault = main::PG_restricted_eval(q!$main::numZeroLevelTolDefault!); 153 $numAbsTolDefault = main::PG_restricted_eval(q!$main::numAbsTolDefault!); 154 $numFormatDefault = main::PG_restricted_eval(q!$main::numFormatDefault!); 155 $functRelPercentTolDefault = main::PG_restricted_eval(q!$main::functRelPercentTolDefault!); 156 $functZeroLevelDefault = main::PG_restricted_eval(q!$main::functZeroLevelDefault!); 157 $functZeroLevelTolDefault = main::PG_restricted_eval(q!$main::functZeroLevelTolDefault!); 158 $functAbsTolDefault = main::PG_restricted_eval(q!$main::functAbsTolDefault!); 159 $functNumOfPoints = main::PG_restricted_eval(q!$main::functNumOfPoints!); 160 $functVarDefault = main::PG_restricted_eval(q!$main::functVarDefault!); 161 $functLLimitDefault = main::PG_restricted_eval(q!$main::functLLimitDefault!); 162 $functULimitDefault = main::PG_restricted_eval(q!$main::functULimitDefault!); 163 $functMaxConstantOfIntegration = main::PG_restricted_eval(q!$main::functMaxConstantOfIntegration!); 164 $rh_envir = main::PG_restricted_eval(q!\%main::envir!); 165 $useBaseTenLog = main::PG_restricted_eval(q!$main::useBaseTenLog!); 166 $inputs_ref = main::PG_restricted_eval(q!$main::inputs_ref!); 167 $QUESTIONNAIRE_ANSWERS = ''; 168 169 if (!main::PG_restricted_eval(q!$main::useOldAnswerMacros!)) { 170 $user_context = main::PG_restricted_eval(q!\%context!); 171 $Context = sub {Parser::Context->current($user_context,@_)}; 172 } 173 } 174 175 176 177 ########################################################################## 178 179 #Note use $rh_envir to read environment variables 180 181 ########################################################################## 182 ## Number answer evaluators 183 184 =head2 Number Answer Evaluators 185 186 Number answer evaluators take in a numerical answer, compare it to the correct answer, 187 and return a score. In addition, they can choose to accept or reject an answer based on 188 its format, closeness to the correct answer, and other criteria. There are two types 189 of numerical answer evaluators: num_cmp(), which takes a hash of named options as parameters, 190 and the "mode"_num_cmp() variety, which use different functions to access different sets of 191 options. In addition, there is the special case of std_num_str_cmp(), which can evaluate 192 both numbers and strings. 193 194 Numerical Comparison Options 195 196 correctAnswer -- This is the correct answer that the student answer will 197 be compared to. However, this does not mean that the 198 student answer must match this exactly. How close the 199 student answer must be is determined by the other 200 options, especially tolerance and format. 201 202 tolerance -- These options determine how close the student answer 203 must be to the correct answer to qualify. There are two 204 types of tolerance: relative and absolute. Relative 205 tolerances are given in percentages. A relative 206 tolerance of 1 indicates that the student answer must 207 be within 1% of the correct answer to qualify as correct. 208 In other words, a student answer is correct when 209 abs(studentAnswer - correctAnswer) <= abs(.01*relpercentTol*correctAnswer) 210 Using absolute tolerance, the student answer must be a 211 fixed distance from the correct answer to qualify. 212 For example, an absolute tolerance of 5 means that any 213 number which is +-5 of the correct answer qualifies as correct. 214 Final (rarely used) tolerance options are zeroLevel 215 and zeroLevelTol, used in conjunction with relative 216 tolerance. if correctAnswer has absolute value less than 217 or equal to zeroLevel, then the student answer must be, 218 in absolute terms, within zeroLevelTol of correctAnswer, i.e., 219 abs(studentAnswer - correctAnswer) <= zeroLevelTol. 220 In other words, if the correct answer is very near zero, 221 an absolute tolerance will be used. One must do this to 222 handle floating point answers very near zero, because of 223 the inaccuracy of floating point arithmetic. However, the 224 default values are almost always adequate. 225 226 mode -- This determines the allowable methods for entering an 227 answer. Answers which do not meet this requirement will 228 be graded as incorrect, regardless of their numerical 229 value. The recognized modes are: 230 'std' (default) -- allows any expression which evaluates 231 to a number, including those using 232 elementary functions like sin() and 233 exp(), as well as the operations of 234 arithmetic (+, -, *, /, ^) 235 'strict' -- only decimal numbers are allowed 236 'frac' -- whole numbers and fractions are allowed 237 'arith' -- arithmetic expressions are allowed, but 238 no functions 239 Note that all modes allow the use of "pi" and "e" as 240 constants, and also the use of "E" to represent scientific 241 notation. 242 243 format -- The format to use when displaying the correct and 244 submitted answers. This has no effect on how answers are 245 evaluated; it is only for cosmetic purposes. The 246 formatting syntax is the same as Perl uses for the sprintf() 247 function. Format strings are of the form '%m.nx' or '%m.nx#', 248 where m and n are described below, and x is a formatter. 249 Esentially, m is the minimum length of the field 250 (make this negative to left-justify). Note that the decimal 251 point counts as a character when determining the field width. 252 If m begins with a zero, the number will be padded with zeros 253 instead of spaces to fit the field. 254 The precision specifier (n) works differently, depending 255 on which formatter you are using. For d, i, o, u, x and X 256 formatters (non-floating point formatters), n is the minimum 257 number of digits to display. For e and f, it is the number of 258 digits that appear after the decimal point (extra digits will 259 be rounded; insufficient digits will be padded with spaces--see 260 '#' below). For g, it is the number of significant digits to 261 display. 262 The full list of formatters can be found in the manpage 263 for printf(3), or by typing "perldoc -f sprintf" at a 264 terminal prompt. The following is a brief summary of the 265 most frequent formatters: 266 d -- decimal number 267 ld -- long decimal number 268 u -- unsigned decimal number 269 lu -- long unsigned decimal number 270 x -- hexadecimal number 271 o -- octal number 272 e -- floating point number in scientific notation 273 f -- floating point number 274 g -- either e or f, whichever takes less space 275 Technically, g will use e if the exponent is less than -4 or 276 greater than or equal to the precision. Trailing zeros are 277 removed in this mode. 278 If the format string ends in '#', trailing zeros will be 279 removed in the decimal part. Note that this is not a standard 280 syntax; it is handled internally by WeBWorK and not by Perl 281 (although this should not be a concern to end users). 282 The default format is '%0.5f#', which displays as a floating 283 point number with 5 digits of precision and no trailing zeros. 284 Other useful format strings might be '%0.2f' for displaying 285 dollar amounts, or '%010d' to display an integer with leading 286 zeros. Setting format to an empty string ( '' ) means no 287 formatting will be used; this will show 'arbitrary' precision 288 floating points. 289 290 Default Values (As of 7/24/2000) (Option -- Variable Name -- Value) 291 292 Format -- $numFormatDefault -- "%0.5f#" 293 Relative Tolerance -- $numRelPercentTolDefault -- .1 294 Absolute Tolerance -- $numAbsTolDefault -- .001 295 Zero Level -- $numZeroLevelDefault -- 1E-14 296 Zero Level Tolerance -- $numZeroLevelTolDefault -- 1E-12 297 298 =cut 299 300 301 =head3 num_cmp() 302 303 Compares a number or a list of numbers, using a named hash of options to set 304 parameters. This can make for more readable code than using the "mode"_num_cmp() 305 style, but some people find one or the other easier to remember. 306 307 ANS( num_cmp( answer or answer_array_ref, options_hash ) ); 308 309 1. the correct answer, or a reference to an array of correct answers 310 2. a hash with the following keys (all optional): 311 mode -- 'std' (default) (allows any expression evaluating to 312 a number) 313 'strict' (only numbers are allowed) 314 'frac' (fractions are allowed) 315 'arith' (arithmetic expressions allowed) 316 format -- '%0.5f#' (default); defines formatting for the 317 correct answer 318 tol -- an absolute tolerance, or 319 relTol -- a relative tolerance 320 units -- the units to use for the answer(s) 321 strings -- a reference to an array of strings which are valid 322 answers (works like std_num_str_cmp() ) 323 zeroLevel -- if the correct answer is this close to zero, 324 then zeroLevelTol applies 325 zeroLevelTol -- absolute tolerance to allow when answer is close 326 to zero 327 328 debug -- if set to 1, provides verbose listing of 329 hash entries throughout fliters. 330 331 Returns an answer evaluator, or (if given a reference to an array of 332 answers), a list of answer evaluators. Note that a reference to an array of 333 answers results is just a shortcut for writing a separate <code>num_cmp()</code> for each 334 answer. 335 336 EXAMPLES: 337 338 num_cmp( 5 ) -- correct answer is 5, using defaults 339 for all options 340 num_cmp( [5,6,7] ) -- correct answers are 5, 6, and 7, 341 using defaults for all options 342 num_cmp( 5, mode => 'strict' ) -- correct answer is 5, mode is strict 343 num_cmp( [5,6], relTol => 5 ) -- correct answers are 5 and 6, 344 both with 5% relative tolerance 345 num_cmp( 6, strings => ["Inf", "Minf", "NaN"] ) 346 -- correct answer is 6, "Inf", "Minf", 347 and "NaN" recognized as valid, but 348 incorrect answers. 349 num_cmp( "-INF", strings => ["INF", "-INF"] ) 350 -- correct answer is "-INF", "INF" and 351 numerical expressions recognized as valid, 352 but incorrect answers. 353 354 355 =cut 356 357 sub num_cmp { 358 my $correctAnswer = shift @_; 359 $CA = $correctAnswer; 360 my @opt = @_; 361 my %out_options; 362 363 ######################################################################### 364 # Retain this first check for backword compatibility. Allows input of the form 365 # num_cmp($ans, 1, '%0.5f') but warns against it 366 ######################################################################### 367 my %known_options = ( 368 'mode' => 'std', 369 'format' => $numFormatDefault, 370 'tol' => $numAbsTolDefault, 371 'relTol' => $numRelPercentTolDefault, 372 'units' => undef, 373 'strings' => undef, 374 'zeroLevel' => $numZeroLevelDefault, 375 'zeroLevelTol' => $numZeroLevelTolDefault, 376 'tolType' => 'relative', 377 'tolerance' => 1, 378 'reltol' => undef, #alternate spelling 379 'unit' => undef, #alternate spelling 380 'debug' => 0 381 ); 382 383 my @output_list; 384 my( $relPercentTol, $format, $zeroLevel, $zeroLevelTol) = @opt; 385 386 unless( ref($correctAnswer) eq 'ARRAY' || scalar( @opt ) == 0 || 387 ( defined($opt[0]) and exists $known_options{$opt[0]} ) ) { 388 # unless the first parameter is a list of arrays 389 # or the second parameter is a known option or 390 # no options were used, 391 # use the old num_cmp which does not use options, but has inputs 392 # $relPercentTol,$format,$zeroLevel,$zeroLevelTol 393 warn "This method of using num_cmp() is deprecated. Please rewrite this" . 394 " problem using the options style of parameter passing (or" . 395 " check that your first option is spelled correctly)."; 396 397 %out_options = ( 'relTol' => $relPercentTol, 398 'format' => $format, 399 'zeroLevel' => $zeroLevel, 400 'zeroLevelTol' => $zeroLevelTol, 401 'mode' => 'std' 402 ); 403 } 404 405 ######################################################################### 406 # Now handle the options assuming they are entered in the form 407 # num_cmp($ans, relTol=>1, format=>'%0.5f') 408 ######################################################################### 409 %out_options = @opt; 410 assign_option_aliases( \%out_options, 411 'reltol' => 'relTol', 412 'unit' => 'units', 413 'abstol' => 'tol', 414 ); 415 416 set_default_options( \%out_options, 417 'tolType' => (defined($out_options{'tol'}) ) ? 'absolute' : 'relative', # the existence of "tol" means that we use absolute tolerance mode 418 'tolerance' => (defined($out_options{'tolType'}) && $out_options{'tolType'} eq 'absolute' ) ? $numAbsTolDefault : $numRelPercentTolDefault, # relative tolerance is the default 419 'mode' => 'std', 420 'format' => $numFormatDefault, 421 'tol' => undef, 422 'relTol' => undef, 423 'units' => undef, 424 'strings' => undef, 425 'zeroLevel' => $numZeroLevelDefault, 426 'zeroLevelTol' => $numZeroLevelTolDefault, 427 'debug' => 0, 428 ); 429 430 # can't use both units and strings 431 if( defined( $out_options{'units'} ) && defined( $out_options{'strings'} ) ) { 432 warn "Can't use both 'units' and 'strings' in the same problem " . 433 "(check your parameters to num_cmp() )"; 434 } 435 436 # absolute tolType and relTol are incompatible. So are relative tolType and tol 437 if( defined( $out_options{'relTol'} ) && $out_options{'tolType'} eq 'absolute' ) { 438 warn "The 'tolType' 'absolute' is not compatible with 'relTol' " . 439 "(check your parameters to num_cmp() )"; 440 } 441 if( defined( $out_options{'tol'} ) && $out_options{'tolType'} eq 'relative' ) { 442 warn "The 'tolType' 'relative' is not compatible with 'tol' " . 443 "(check your parameters to num_cmp() )"; 444 } 445 446 447 # Handle legacy options 448 if ($out_options{tolType} eq 'absolute') { 449 $out_options{'tolerance'}=$out_options{'tol'} if defined($out_options{'tol'}); 450 delete($out_options{'relTol'}) if exists( $out_options{'relTol'} ); 451 } else { 452 $out_options{'tolerance'}=$out_options{'relTol'} if defined($out_options{'relTol'}); 453 # delete($out_options{'tol'}) if exists( $out_options{'tol'} ); 454 } 455 # end legacy options 456 457 # thread over lists 458 my @ans_list = (); 459 460 if ( ref($correctAnswer) eq 'ARRAY' ) { 461 @ans_list = @{$correctAnswer}; 462 } 463 else { push( @ans_list, $correctAnswer ); 464 } 465 466 # produce answer evaluators 467 foreach my $ans (@ans_list) { 468 if( defined( $out_options{'units'} ) ) { 469 $ans = "$ans $out_options{'units'}"; 470 471 push( @output_list, NUM_CMP( 'correctAnswer' => $ans, 472 'tolerance' => $out_options{'tolerance'}, 473 'tolType' => $out_options{'tolType'}, 474 'format' => $out_options{'format'}, 475 'mode' => $out_options{'mode'}, 476 'zeroLevel' => $out_options{'zeroLevel'}, 477 'zeroLevelTol' => $out_options{'zeroLevelTol'}, 478 'debug' => $out_options{'debug'}, 479 'units' => $out_options{'units'}, 480 ) 481 ); 482 } elsif( defined( $out_options{'strings'} ) ) { 483 484 485 push( @output_list, NUM_CMP( 'correctAnswer' => $ans, 486 'tolerance' => $out_options{tolerance}, 487 'tolType' => $out_options{tolType}, 488 'format' => $out_options{'format'}, 489 'mode' => $out_options{'mode'}, 490 'zeroLevel' => $out_options{'zeroLevel'}, 491 'zeroLevelTol' => $out_options{'zeroLevelTol'}, 492 'debug' => $out_options{'debug'}, 493 'strings' => $out_options{'strings'}, 494 ) 495 ); 496 } else { 497 push(@output_list, 498 NUM_CMP( 'correctAnswer' => $ans, 499 'tolerance' => $out_options{tolerance}, 500 'tolType' => $out_options{tolType}, 501 'format' => $out_options{'format'}, 502 'mode' => $out_options{'mode'}, 503 'zeroLevel' => $out_options{'zeroLevel'}, 504 'zeroLevelTol' => $out_options{'zeroLevelTol'}, 505 'debug' => $out_options{'debug'}, 506 ), 507 ); 508 } 509 } 510 511 return (wantarray) ? @output_list : $output_list[0]; 512 } 513 514 #legacy code for compatability purposes 515 sub num_rel_cmp { # compare numbers 516 std_num_cmp( @_ ); 517 } 518 519 520 =head3 "mode"_num_cmp() functions 521 522 There are 16 functions total, 4 for each mode (std, frac, strict, arith). Each mode has 523 one "normal" function, one which accepts a list of answers, one which uses absolute 524 rather than relative tolerance, and one which uses absolute tolerance and accepts a list. 525 The "std" family is documented below; all others work precisely the same. 526 527 std_num_cmp($correctAnswer) OR 528 std_num_cmp($correctAnswer, $relPercentTol) OR 529 std_num_cmp($correctAnswer, $relPercentTol, $format) OR 530 std_num_cmp($correctAnswer, $relPercentTol, $format, $zeroLevel) OR 531 std_num_cmp($correctAnswer, $relPercentTol, $format, $zeroLevel, $zeroLevelTol) 532 533 $correctAnswer -- the correct answer 534 $relPercentTol -- the tolerance, as a percentage (optional) 535 $format -- the format of the displayed answer (optional) 536 $zeroLevel -- if the correct answer is this close to zero, then zeroLevelTol applies (optional) 537 $zeroLevelTol -- absolute tolerance to allow when correct answer is close to zero (optional) 538 539 std_num_cmp() uses standard mode (arithmetic operations and elementary 540 functions allowed) and relative tolerance. Options are specified by 541 one or more parameters. Note that if you wish to set an option which 542 is later in the parameter list, you must set all previous options. 543 544 std_num_cmp_abs($correctAnswer) OR 545 std_num_cmp_abs($correctAnswer, $absTol) OR 546 std_num_cmp_abs($correctAnswer, $absTol, $format) 547 548 $correctAnswer -- the correct answer 549 $absTol -- an absolute tolerance (optional) 550 $format -- the format of the displayed answer (optional) 551 552 std_num_cmp_abs() uses standard mode and absolute tolerance. Options 553 are set as with std_num_cmp(). Note that $zeroLevel and $zeroLevelTol 554 do not apply with absolute tolerance. 555 556 std_num_cmp_list($relPercentTol, $format, @answerList) 557 558 $relPercentTol -- the tolerance, as a percentage 559 $format -- the format of the displayed answer(s) 560 @answerList -- a list of one or more correct answers 561 562 std_num_cmp_list() uses standard mode and relative tolerance. There 563 is no way to set $zeroLevel or $zeroLevelTol. Note that no 564 parameters are optional. All answers in the list will be 565 evaluated with the same set of parameters. 566 567 std_num_cmp_abs_list($absTol, $format, @answerList) 568 569 $absTol -- an absolute tolerance 570 $format -- the format of the displayed answer(s) 571 @answerList -- a list of one or more correct answers 572 573 std_num_cmp_abs_list() uses standard mode and absolute tolerance. 574 Note that no parameters are optional. All answers in the list will be 575 evaluated with the same set of parameters. 576 577 arith_num_cmp(), arith_num_cmp_list(), arith_num_cmp_abs(), arith_num_cmp_abs_list() 578 strict_num_cmp(), strict_num_cmp_list(), strict_num_cmp_abs(), strict_num_cmp_abs_list() 579 frac_num_cmp(), frac_num_cmp_list(), frac_num_cmp_abs(), frac_num_cmp_abs_list() 580 581 Examples: 582 583 ANS( strict_num_cmp( 3.14159 ) ) -- The student answer must be a number 584 in decimal or scientific notation which is within .1 percent of 3.14159. 585 This assumes $numRelPercentTolDefault has been set to .1. 586 ANS( strict_num_cmp( $answer, .01 ) ) -- The student answer must be a 587 number within .01 percent of $answer (e.g. 3.14159 if $answer is 3.14159 588 or $answer is "pi" or $answer is 4*atan(1)). 589 ANS( frac_num_cmp( $answer) ) or ANS( frac_num_cmp( $answer,.01 )) -- 590 The student answer can be a number or fraction, e.g. 2/3. 591 ANS( arith_num_cmp( $answer) ) or ANS( arith_num_cmp( $answer,.01 )) -- 592 The student answer can be an arithmetic expression, e.g. (2+3)/7-2^.5 . 593 ANS( std_num_cmp( $answer) ) or ANS( std_num_cmp( $answer,.01 )) -- 594 The student answer can contain elementary functions, e.g. sin(.3+pi/2) 595 596 =cut 597 598 sub std_num_cmp { # compare numbers allowing use of elementary functions 599 my ( $correctAnswer, $relPercentTol, $format, $zeroLevel, $zeroLevelTol ) = @_; 600 601 my %options = ( 'relTol' => $relPercentTol, 602 'format' => $format, 603 'zeroLevel' => $zeroLevel, 604 'zeroLevelTol' => $zeroLevelTol 605 ); 606 607 set_default_options( \%options, 608 'tolType' => 'relative', 609 'tolerance' => $numRelPercentTolDefault, 610 'mode' => 'std', 611 'format' => $numFormatDefault, 612 'relTol' => $numRelPercentTolDefault, 613 'zeroLevel' => $numZeroLevelDefault, 614 'zeroLevelTol' => $numZeroLevelTolDefault, 615 'debug' => 0, 616 ); 617 618 num_cmp([$correctAnswer], %options); 619 } 620 621 ## Similar to std_num_cmp but accepts a list of numbers in the form 622 ## std_num_cmp_list(relpercentTol,format,ans1,ans2,ans3,...) 623 ## format is of the form "%10.3g" or "", i.e., a format suitable for sprintf(). Use "" for default 624 ## You must enter a format and tolerance 625 626 sub std_num_cmp_list { 627 my ( $relPercentTol, $format, @answerList) = @_; 628 629 my %options = ( 'relTol' => $relPercentTol, 630 'format' => $format, 631 ); 632 633 set_default_options( \%options, 634 'tolType' => 'relative', 635 'tolerance' => $numRelPercentTolDefault, 636 'mode' => 'std', 637 'format' => $numFormatDefault, 638 'relTol' => $numRelPercentTolDefault, 639 'zeroLevel' => $numZeroLevelDefault, 640 'zeroLevelTol' => $numZeroLevelTolDefault, 641 'debug' => 0, 642 ); 643 644 num_cmp(\@answerList, %options); 645 646 } 647 648 sub std_num_cmp_abs { # compare numbers allowing use of elementary functions with absolute tolerance 649 my ( $correctAnswer, $absTol, $format) = @_; 650 my %options = ( 'tolerance' => $absTol, 651 'format' => $format 652 ); 653 654 set_default_options (\%options, 655 'tolType' => 'absolute', 656 'tolerance' => $absTol, 657 'mode' => 'std', 658 'format' => $numFormatDefault, 659 'zeroLevel' => 0, 660 'zeroLevelTol' => 0, 661 'debug' => 0, 662 ); 663 664 num_cmp([$correctAnswer], %options); 665 } 666 667 ## See std_num_cmp_list for usage 668 669 sub std_num_cmp_abs_list { 670 my ( $absTol, $format, @answerList ) = @_; 671 672 my %options = ( 'tolerance' => $absTol, 673 'format' => $format, 674 ); 675 676 set_default_options( \%options, 677 'tolType' => 'absolute', 678 'tolerance' => $absTol, 679 'mode' => 'std', 680 'format' => $numFormatDefault, 681 'zeroLevel' => 0, 682 'zeroLevelTol' => 0, 683 'debug' => 0, 684 ); 685 686 num_cmp(\@answerList, %options); 687 } 688 689 sub frac_num_cmp { # only allow fractions and numbers as submitted answer 690 691 my ( $correctAnswer, $relPercentTol, $format, $zeroLevel, $zeroLevelTol ) = @_; 692 693 my %options = ( 'relTol' => $relPercentTol, 694 'format' => $format, 695 'zeroLevel' => $zeroLevel, 696 'zeroLevelTol' => $zeroLevelTol 697 ); 698 699 set_default_options( \%options, 700 'tolType' => 'relative', 701 'tolerance' => $relPercentTol, 702 'mode' => 'frac', 703 'format' => $numFormatDefault, 704 'zeroLevel' => $numZeroLevelDefault, 705 'zeroLevelTol' => $numZeroLevelTolDefault, 706 'relTol' => $numRelPercentTolDefault, 707 'debug' => 0, 708 ); 709 710 num_cmp([$correctAnswer], %options); 711 } 712 713 ## See std_num_cmp_list for usage 714 sub frac_num_cmp_list { 715 my ( $relPercentTol, $format, @answerList ) = @_; 716 717 my %options = ( 'relTol' => $relPercentTol, 718 'format' => $format 719 ); 720 721 set_default_options( \%options, 722 'tolType' => 'relative', 723 'tolerance' => $relPercentTol, 724 'mode' => 'frac', 725 'format' => $numFormatDefault, 726 'zeroLevel' => $numZeroLevelDefault, 727 'zeroLevelTol' => $numZeroLevelTolDefault, 728 'relTol' => $numRelPercentTolDefault, 729 'debug' => 0, 730 ); 731 732 num_cmp(\@answerList, %options); 733 } 734 735 sub frac_num_cmp_abs { # only allow fraction expressions as submitted answer with absolute tolerance 736 my ( $correctAnswer, $absTol, $format ) = @_; 737 738 my %options = ( 'tolerance' => $absTol, 739 'format' => $format 740 ); 741 742 set_default_options (\%options, 743 'tolType' => 'absolute', 744 'tolerance' => $absTol, 745 'mode' => 'frac', 746 'format' => $numFormatDefault, 747 'zeroLevel' => 0, 748 'zeroLevelTol' => 0, 749 'debug' => 0, 750 ); 751 752 num_cmp([$correctAnswer], %options); 753 } 754 755 ## See std_num_cmp_list for usage 756 757 sub frac_num_cmp_abs_list { 758 my ( $absTol, $format, @answerList ) = @_; 759 760 my %options = ( 'tolerance' => $absTol, 761 'format' => $format 762 ); 763 764 set_default_options (\%options, 765 'tolType' => 'absolute', 766 'tolerance' => $absTol, 767 'mode' => 'frac', 768 'format' => $numFormatDefault, 769 'zeroLevel' => 0, 770 'zeroLevelTol' => 0, 771 'debug' => 0, 772 ); 773 774 num_cmp(\@answerList, %options); 775 } 776 777 778 sub arith_num_cmp { # only allow arithmetic expressions as submitted answer 779 780 my ( $correctAnswer, $relPercentTol, $format, $zeroLevel, $zeroLevelTol ) = @_; 781 782 my %options = ( 'relTol' => $relPercentTol, 783 'format' => $format, 784 'zeroLevel' => $zeroLevel, 785 'zeroLevelTol' => $zeroLevelTol 786 ); 787 788 set_default_options( \%options, 789 'tolType' => 'relative', 790 'tolerance' => $relPercentTol, 791 'mode' => 'arith', 792 'format' => $numFormatDefault, 793 'zeroLevel' => $numZeroLevelDefault, 794 'zeroLevelTol' => $numZeroLevelTolDefault, 795 'relTol' => $numRelPercentTolDefault, 796 'debug' => 0, 797 ); 798 799 num_cmp([$correctAnswer], %options); 800 } 801 802 ## See std_num_cmp_list for usage 803 sub arith_num_cmp_list { 804 my ( $relPercentTol, $format, @answerList ) = @_; 805 806 my %options = ( 'relTol' => $relPercentTol, 807 'format' => $format, 808 ); 809 810 set_default_options( \%options, 811 'tolType' => 'relative', 812 'tolerance' => $relPercentTol, 813 'mode' => 'arith', 814 'format' => $numFormatDefault, 815 'zeroLevel' => $numZeroLevelDefault, 816 'zeroLevelTol' => $numZeroLevelTolDefault, 817 'relTol' => $numRelPercentTolDefault, 818 'debug' => 0, 819 ); 820 821 num_cmp(\@answerList, %options); 822 } 823 824 sub arith_num_cmp_abs { # only allow arithmetic expressions as submitted answer with absolute tolerance 825 my ( $correctAnswer, $absTol, $format ) = @_; 826 827 my %options = ( 'tolerance' => $absTol, 828 'format' => $format 829 ); 830 831 set_default_options (\%options, 832 'tolType' => 'absolute', 833 'tolerance' => $absTol, 834 'mode' => 'arith', 835 'format' => $numFormatDefault, 836 'zeroLevel' => 0, 837 'zeroLevelTol' => 0, 838 'debug' => 0, 839 ); 840 841 num_cmp([$correctAnswer], %options); 842 } 843 844 ## See std_num_cmp_list for usage 845 sub arith_num_cmp_abs_list { 846 my ( $absTol, $format, @answerList ) = @_; 847 848 my %options = ( 'tolerance' => $absTol, 849 'format' => $format 850 ); 851 852 set_default_options (\%options, 853 'tolType' => 'absolute', 854 'tolerance' => $absTol, 855 'mode' => 'arith', 856 'format' => $numFormatDefault, 857 'zeroLevel' => 0, 858 'zeroLevelTol' => 0, 859 'debug' => 0, 860 ); 861 862 num_cmp(\@answerList, %options); 863 } 864 865 sub strict_num_cmp { # only allow numbers as submitted answer 866 my ( $correctAnswer, $relPercentTol, $format, $zeroLevel, $zeroLevelTol ) = @_; 867 868 my %options = ( 'relTol' => $relPercentTol, 869 'format' => $format, 870 'zeroLevel' => $zeroLevel, 871 'zeroLevelTol' => $zeroLevelTol 872 ); 873 874 set_default_options( \%options, 875 'tolType' => 'relative', 876 'tolerance' => $relPercentTol, 877 'mode' => 'strict', 878 'format' => $numFormatDefault, 879 'zeroLevel' => $numZeroLevelDefault, 880 'zeroLevelTol' => $numZeroLevelTolDefault, 881 'relTol' => $numRelPercentTolDefault, 882 'debug' => 0, 883 ); 884 num_cmp([$correctAnswer], %options); 885 886 } 887 888 ## See std_num_cmp_list for usage 889 sub strict_num_cmp_list { # compare numbers 890 my ( $relPercentTol, $format, @answerList ) = @_; 891 892 my %options = ( 'relTol' => $relPercentTol, 893 'format' => $format, 894 ); 895 896 set_default_options( \%options, 897 'tolType' => 'relative', 898 'tolerance' => $relPercentTol, 899 'mode' => 'strict', 900 'format' => $numFormatDefault, 901 'zeroLevel' => $numZeroLevelDefault, 902 'zeroLevelTol' => $numZeroLevelTolDefault, 903 'relTol' => $numRelPercentTolDefault, 904 'debug' => 0, 905 ); 906 907 num_cmp(\@answerList, %options); 908 } 909 910 911 sub strict_num_cmp_abs { # only allow numbers as submitted answer with absolute tolerance 912 my ( $correctAnswer, $absTol, $format ) = @_; 913 914 my %options = ( 'tolerance' => $absTol, 915 'format' => $format 916 ); 917 918 set_default_options (\%options, 919 'tolType' => 'absolute', 920 'tolerance' => $absTol, 921 'mode' => 'strict', 922 'format' => $numFormatDefault, 923 'zeroLevel' => 0, 924 'zeroLevelTol' => 0, 925 'debug' => 0, 926 ); 927 num_cmp([$correctAnswer], %options); 928 929 } 930 931 ## See std_num_cmp_list for usage 932 sub strict_num_cmp_abs_list { # compare numbers 933 my ( $absTol, $format, @answerList ) = @_; 934 935 my %options = ( 'tolerance' => $absTol, 936 'format' => $format 937 ); 938 939 set_default_options (\%options, 940 'tolType' => 'absolute', 941 'tolerance' => $absTol, 942 'mode' => 'strict', 943 'format' => $numFormatDefault, 944 'zeroLevel' => 0, 945 'zeroLevelTol' => 0, 946 'debug' => 0, 947 ); 948 949 num_cmp(\@answerList, %options); 950 } 951 952 ## sub numerical_compare_with_units 953 ## Compares a number with units 954 ## Deprecated; use num_cmp() 955 ## 956 ## IN: a string which includes the numerical answer and the units 957 ## a hash with the following keys (all optional): 958 ## mode -- 'std', 'frac', 'arith', or 'strict' 959 ## format -- the format to use when displaying the answer 960 ## tol -- an absolute tolerance, or 961 ## relTol -- a relative tolerance 962 ## zeroLevel -- if the correct answer is this close to zero, then zeroLevelTol applies 963 ## zeroLevelTol -- absolute tolerance to allow when correct answer is close to zero 964 965 # This mode is depricated. send input through num_cmp -- it can handle units. 966 967 sub numerical_compare_with_units { 968 my $correct_answer = shift; # the answer is a string which includes both the numerical answer and the units. 969 my %options = @_; # all of the other inputs are (key value) pairs 970 971 # Prepare the correct answer 972 $correct_answer = str_filters( $correct_answer, 'trim_whitespace' ); 973 974 # it surprises me that the match below works since the first .* is greedy. 975 my ($correct_num_answer, $correct_units) = $correct_answer =~ /^(.*)\s+([^\s]*)$/; 976 $options{units} = $correct_units; 977 978 num_cmp($correct_num_answer, %options); 979 } 980 981 982 =head3 std_num_str_cmp() 983 984 NOTE: This function is maintained for compatibility. num_cmp() with the 985 'strings' parameter is slightly preferred. 986 987 std_num_str_cmp() is used when the correct answer could be either a number or a 988 string. For example, if you wanted the student to evaluate a function at number 989 of points, but write "Inf" or "Minf" if the function is unbounded. This routine 990 will provide error messages that do not give a hint as to whether the correct 991 answer is a string or a number. For numerical comparisons, std_num_cmp() is 992 used internally; for string comparisons, std_str_cmp() is used. String answers 993 must consist entirely of letters except that an initial minus sign is allowed. 994 E.g. "inf" and "-inf" are valid strings where as "too-big" is not. 995 996 std_num_str_cmp( $correctAnswer ) OR 997 std_num_str_cmp( $correctAnswer, $ra_legalStrings ) OR 998 std_num_str_cmp( $correctAnswer, $ra_legalStrings, $relPercentTol ) OR 999 std_num_str_cmp( $correctAnswer, $ra_legalStrings, $relPercentTol, $format ) OR 1000 std_num_str_cmp( $correctAnswer, $ra_legalStrings, $relPercentTol, $format, $zeroLevel ) OR 1001 std_num_str_cmp( $correctAnswer, $ra_legalStrings, $relPercentTol, $format, 1002 $zeroLevel, $zeroLevelTol ) 1003 1004 $correctAnswer -- the correct answer 1005 $ra_legalStrings -- a reference to an array of legal strings, e.g. ["str1", "str2"] 1006 $relPercentTol -- the error tolerance as a percentage 1007 $format -- the display format 1008 $zeroLevel -- if the correct answer is this close to zero, then zeroLevelTol applies 1009 $zeroLevelTol -- absolute tolerance to allow when correct answer is close to zero 1010 1011 Examples: 1012 ANS( std_num_str_cmp( $ans, ["Inf", "Minf", "NaN"] ) ); 1013 ANS( std_num_str_cmp( $ans, ["INF", "-INF"] ) ); 1014 1015 =cut 1016 1017 sub std_num_str_cmp { 1018 my ( $correctAnswer, $ra_legalStrings, $relpercentTol, $format, $zeroLevel, $zeroLevelTol ) = @_; 1019 # warn ('This method is depreciated. Use num_cmp instead.'); 1020 return num_cmp ($correctAnswer, strings=>$ra_legalStrings, relTol=>$relpercentTol, format=>$format, 1021 zeroLevel=>$zeroLevel, zeroLevelTol=>$zeroLevelTol); 1022 } 1023 1024 sub NUM_CMP { # low level numeric compare (now uses Parser) 1025 return ORIGINAL_NUM_CMP(@_) 1026 if main::PG_restricted_eval(q!$main::useOldAnswerMacros!); 1027 1028 my %num_params = @_; 1029 1030 # 1031 # check for required parameters 1032 # 1033 my @keys = qw(correctAnswer tolerance tolType format mode zeroLevel zeroLevelTol debug); 1034 foreach my $key (@keys) { 1035 warn "$key must be defined in options when calling NUM_CMP" 1036 unless defined($num_params{$key}); 1037 } 1038 1039 my $correctAnswer = $num_params{correctAnswer}; 1040 my $mode = $num_params{mode}; 1041 my %options = (debug => $num_params{debug}); 1042 1043 # 1044 # Hack to fix up exponential notation in correct answer 1045 # (e.g., perl will pass .0000001 as 1e-07). 1046 # 1047 $correctAnswer = uc($correctAnswer) 1048 if $correctAnswer =~ m/e/ && Value::isNumber($correctAnswer); 1049 1050 # 1051 # Get an apppropriate context based on the mode 1052 # 1053 my $context; 1054 for ($mode) { 1055 /^strict$/i and do { 1056 $context = $Parser::Context::Default::context{LimitedNumeric}->copy; 1057 last; 1058 }; 1059 /^arith$/i and do { 1060 $context = $Parser::Context::Default::context{LegacyNumeric}->copy; 1061 $context->functions->disable('All'); 1062 last; 1063 }; 1064 /^frac$/i and do { 1065 $context = $Parser::Context::Default::context{'LimitedNumeric-Fraction'}->copy; 1066 last; 1067 }; 1068 1069 # default 1070 $context = $Parser::Context::Default::context{LegacyNumeric}->copy; 1071 } 1072 $context->{format}{number} = $num_params{'format'}; 1073 $context->strings->clear; 1074 # FIXME: should clear variables as well? Copy them from the current context? 1075 1076 # 1077 # Add the strings to the context 1078 # 1079 if ($num_params{strings}) { 1080 foreach my $string (@{$num_params{strings}}) { 1081 my %tex = ($string =~ m/^(-?)inf(inity)?$/i)? (TeX => "$1\\infty"): (); 1082 %tex = (TeX => "-\\infty") if uc($string) eq "MINF"; 1083 $context->strings->add(uc($string) => {%tex}); 1084 } 1085 } 1086 1087 # 1088 # Set the tolerances 1089 # 1090 if ($num_params{tolType} eq 'absolute') { 1091 $context->flags->set( 1092 tolerance => $num_params{tolerance}, 1093 tolType => 'absolute', 1094 ); 1095 } else { 1096 $context->flags->set( 1097 tolerance => .01*$num_params{tolerance}, 1098 tolType => 'relative', 1099 ); 1100 } 1101 $context->flags->set( 1102 zeroLevel => $num_params{zeroLevel}, 1103 zeroLevelTol => $num_params{zeroLevelTol}, 1104 ); 1105 1106 # 1107 # Get the proper Parser object for the professor's answer 1108 # using the initialized context 1109 # 1110 my $oldContext = &$Context(); &$Context($context); my $r; 1111 if ($num_params{units}) { 1112 $r = new Parser::Legacy::NumberWithUnits($correctAnswer); 1113 $options{rh_correct_units} = $num_params{units}; 1114 } else { 1115 $r = Value::Formula->new($correctAnswer); 1116 die "The professor's answer can't be a formula" unless $r->isConstant; 1117 $r = $r->eval; $r = new Value::Real($r) unless Value::class($r) eq 'String'; 1118 $r->{correct_ans} = $correctAnswer; 1119 if ($mode eq 'phase_pi') { 1120 my $pi = 4*atan2(1,1); 1121 while ($r > $pi/2) {$r -= $pi} 1122 while ($r < -$pi/2) {$r += $pi} 1123 } 1124 } 1125 # 1126 # Get the answer checker from the parser object 1127 # 1128 my $cmp = $r->cmp(%options); 1129 $cmp->install_pre_filter(sub { 1130 my $rh_ans = shift; 1131 $rh_ans->{original_student_ans} = $rh_ans->{student_ans}; 1132 $rh_ans->{original_correct_ans} = $rh_ans->{correct_ans}; 1133 return $rh_ans; 1134 }); 1135 $cmp->install_post_filter(sub { 1136 my $rh_ans = shift; 1137 $rh_ans->{student_ans} = $rh_ans->{student_value}->string 1138 if ref($rh_ans->{student_value}); 1139 return $rh_ans; 1140 }); 1141 &$Context($oldContext); 1142 1143 return $cmp; 1144 } 1145 1146 # 1147 # The original version, for backward compatibility 1148 # (can be removed when the Parser-based version is more fully tested.) 1149 # 1150 sub ORIGINAL_NUM_CMP { # low level numeric compare 1151 my %num_params = @_; 1152 1153 my @keys = qw ( correctAnswer tolerance tolType format mode zeroLevel zeroLevelTol debug ); 1154 foreach my $key (@keys) { 1155 warn "$key must be defined in options when calling NUM_CMP" unless defined ($num_params{$key}); 1156 } 1157 1158 my $correctAnswer = $num_params{'correctAnswer'}; 1159 my $format = $num_params{'format'}; 1160 my $mode = $num_params{'mode'}; 1161 1162 if( $num_params{tolType} eq 'relative' ) { 1163 $num_params{'tolerance'} = .01*$num_params{'tolerance'}; 1164 } 1165 1166 my $formattedCorrectAnswer; 1167 my $correct_units; 1168 my $correct_num_answer; 1169 my %correct_units; 1170 my $corrAnswerIsString = 0; 1171 1172 1173 if (defined($num_params{units}) && $num_params{units}) { 1174 $correctAnswer = str_filters( $correctAnswer, 'trim_whitespace' ); 1175 # units are in form stuff space units where units contains no spaces. 1176 1177 ($correct_num_answer, $correct_units) = $correctAnswer =~ /^(.*)\s+([^\s]*)$/; 1178 %correct_units = Units::evaluate_units($correct_units); 1179 if ( defined( $correct_units{'ERROR'} ) ) { 1180 warn ("ERROR: The answer \"$correctAnswer\" in the problem definition cannot be parsed:\n" . 1181 "$correct_units{'ERROR'}\n"); 1182 } 1183 # $formattedCorrectAnswer = spf($correct_num_answer,$num_params{'format'}) . " $correct_units"; 1184 $formattedCorrectAnswer = prfmt($correct_num_answer,$num_params{'format'}) . " $correct_units"; 1185 1186 } elsif (defined($num_params{strings}) && $num_params{strings}) { 1187 my $legalString = ''; 1188 my @legalStrings = @{$num_params{strings}}; 1189 $correct_num_answer = $correctAnswer; 1190 $formattedCorrectAnswer = $correctAnswer; 1191 foreach $legalString (@legalStrings) { 1192 if ( uc($correctAnswer) eq uc($legalString) ) { 1193 $corrAnswerIsString = 1; 1194 1195 last; 1196 } 1197 } ## at this point $corrAnswerIsString = 0 iff correct answer is numeric 1198 } else { 1199 $correct_num_answer = $correctAnswer; 1200 $formattedCorrectAnswer = prfmt( $correctAnswer, $num_params{'format'} ); 1201 } 1202 1203 $correct_num_answer = math_constants($correct_num_answer); 1204 1205 my $PGanswerMessage = ''; 1206 1207 my ($inVal,$correctVal,$PG_eval_errors,$PG_full_error_report); 1208 1209 if (defined($correct_num_answer) && $correct_num_answer =~ /\S/ && $corrAnswerIsString == 0 ) { 1210 ($correctVal, $PG_eval_errors,$PG_full_error_report) = PG_answer_eval($correct_num_answer); 1211 } else { # case of a string answer 1212 $PG_eval_errors = ' '; 1213 $correctVal = $correctAnswer; 1214 } 1215 1216 if ( ($PG_eval_errors && $corrAnswerIsString == 0) or ((not is_a_number($correctVal)) && $corrAnswerIsString == 0)) { 1217 ##error message from eval or above 1218 warn "Error in 'correct' answer: $PG_eval_errors<br> 1219 The answer $correctAnswer evaluates to $correctVal, 1220 which cannot be interpreted as a number. "; 1221 1222 } 1223 ######################################################################### 1224 1225 #construct the answer evaluator 1226 my $answer_evaluator = new AnswerEvaluator; 1227 $answer_evaluator->{debug} = $num_params{debug}; 1228 $answer_evaluator->ans_hash( 1229 correct_ans => $correctVal, 1230 type => "${mode}_number", 1231 tolerance => $num_params{tolerance}, 1232 tolType => $num_params{tolType}, 1233 units => $correct_units, 1234 original_correct_ans => $formattedCorrectAnswer, 1235 rh_correct_units => \%correct_units, 1236 answerIsString => $corrAnswerIsString, 1237 ); 1238 my ($in, $formattedSubmittedAnswer); 1239 $answer_evaluator->install_pre_filter(sub {my $rh_ans = shift; 1240 $rh_ans->{original_student_ans} = $rh_ans->{student_ans}; $rh_ans;} 1241 ); 1242 1243 1244 1245 if (defined($num_params{units}) && $num_params{units}) { 1246 $answer_evaluator->install_pre_filter(\&check_units); 1247 } 1248 if (defined($num_params{strings}) && $num_params{strings}) { 1249 $answer_evaluator->install_pre_filter(\&check_strings, %num_params); 1250 } 1251 1252 ## FIXME? - this pre filter was moved before check_units to allow 1253 ## for latex preview of answers with no units. 1254 ## seems to work but may have unintended side effects elsewhere. 1255 1256 ## Actually it caused trouble with the check strings package so it has been moved back 1257 # We'll try some other method -- perhaps add code to fix_answer for display 1258 $answer_evaluator->install_pre_filter(\&check_syntax); 1259 1260 $answer_evaluator->install_pre_filter(\&math_constants); 1261 1262 if ($mode eq 'std') { 1263 # do nothing 1264 } elsif ($mode eq 'strict') { 1265 $answer_evaluator->install_pre_filter(\&is_a_number); 1266 } elsif ($mode eq 'arith') { 1267 $answer_evaluator->install_pre_filter(\&is_an_arithmetic_expression); 1268 } elsif ($mode eq 'frac') { 1269 $answer_evaluator->install_pre_filter(\&is_a_fraction); 1270 1271 } elsif ($mode eq 'phase_pi') { 1272 $answer_evaluator->install_pre_filter(\&phase_pi); 1273 1274 } else { 1275 $PGanswerMessage = 'Tell your professor that there is an error in his or her answer mechanism. No mode was specified.'; 1276 $formattedSubmittedAnswer = $in; 1277 } 1278 1279 if ($corrAnswerIsString == 0 ){ # avoiding running compare_numbers when correct answer is a string. 1280 $answer_evaluator->install_evaluator(\&compare_numbers, %num_params); 1281 } 1282 1283 1284 ############################################################################### 1285 # We'll leave these next lines out for now, so that the evaluated versions of the student's and professor's 1286 # can be displayed in the answer message. This may still cause a few anomolies when strings are used 1287 # 1288 ############################################################################### 1289 1290 $answer_evaluator->install_post_filter(\&fix_answers_for_display); 1291 1292 $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; 1293 return $rh_ans unless $rh_ans->catch_error('EVAL'); 1294 $rh_ans->{student_ans} = $rh_ans->{original_student_ans}. ' '. $rh_ans->{error_message}; 1295 $rh_ans->clear_error('EVAL'); } ); 1296 $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('SYNTAX'); } ); 1297 $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('UNITS'); } ); 1298 $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('NUMBER'); } ); 1299 $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('STRING'); } ); 1300 $answer_evaluator; 1301 } 1302 1303 1304 1305 ########################################################################## 1306 ########################################################################## 1307 ## Function answer evaluators 1308 1309 =head2 Function Answer Evaluators 1310 1311 Function answer evaluators take in a function, compare it numerically to a 1312 correct function, and return a score. They can require an exactly equivalent 1313 function, or one that is equal up to a constant. They can accept or reject an 1314 answer based on specified tolerances for numerical deviation. 1315 1316 Function Comparison Options 1317 1318 correctEqn -- The correct equation, specified as a string. It may include 1319 all basic arithmetic operations, as well as elementary 1320 functions. Variable usage is described below. 1321 1322 Variables -- The independent variable(s). When comparing the correct 1323 equation to the student equation, each variable will be 1324 replaced by a certain number of numerical values. If 1325 the student equation agrees numerically with the correct 1326 equation, they are considered equal. Note that all 1327 comparison is numeric; it is possible (although highly 1328 unlikely and never a practical concern) for two unequal 1329 functions to yield the same numerical results. 1330 1331 Limits -- The limits of evaluation for the independent variables. 1332 Each variable is evaluated only in the half-open interval 1333 [lower_limit, upper_limit). This is useful if the function 1334 has a singularity or is not defined in a certain range. 1335 For example, the function "sqrt(-1-x)" could be evaluated 1336 in [-2,-1). 1337 1338 Tolerance -- Tolerance in function comparisons works exactly as in 1339 numerical comparisons; see the numerical comparison 1340 documentation for a complete description. Note that the 1341 tolerance does applies to the function as a whole, not 1342 each point individually. 1343 1344 Number of -- Specifies how many points to evaluate each variable at. This 1345 Points is typically 3, but can be set higher if it is felt that 1346 there is a strong possibility of "false positives." 1347 1348 Maximum -- Sets the maximum size of the constant of integration. For 1349 Constant of technical reasons concerning floating point arithmetic, if 1350 Integration the additive constant, i.e., the constant of integration, is 1351 greater (in absolute value) than maxConstantOfIntegration 1352 AND is greater than maxConstantOfIntegration times the 1353 correct value, WeBWorK will give an error message saying 1354 that it can not handle such a large constant of integration. 1355 This is to prevent e.g. cos(x) + 1E20 or even 1E20 as being 1356 accepted as a correct antiderivatives of sin(x) since 1357 floating point arithmetic cannot tell the difference 1358 between cos(x) + 1E20, 1E20, and -cos(x) + 1E20. 1359 1360 Technical note: if you examine the code for the function routines, you will see 1361 that most subroutines are simply doing some basic error-checking and then 1362 passing the parameters on to the low-level FUNCTION_CMP(). Because this routine 1363 is set up to handle multivariable functions, with single-variable functions as 1364 a special case, it is possible to pass multivariable parameters to single- 1365 variable functions. This usage is strongly discouraged as unnecessarily 1366 confusing. Avoid it. 1367 1368 Default Values (As of 7/24/2000) (Option -- Variable Name -- Value) 1369 1370 Variable -- $functVarDefault -- 'x' 1371 Relative Tolerance -- $functRelPercentTolDefault -- .1 1372 Absolute Tolerance -- $functAbsTolDefault -- .001 1373 Lower Limit -- $functLLimitDefault -- .0000001 1374 Upper Limit -- $functULimitDefault -- 1 1375 Number of Points -- $functNumOfPoints -- 3 1376 Zero Level -- $functZeroLevelDefault -- 1E-14 1377 Zero Level Tolerance -- $functZeroLevelTolDefault -- 1E-12 1378 Maximum Constant -- $functMaxConstantOfIntegration -- 1E8 1379 of Integration 1380 1381 =cut 1382 1383 1384 1385 =head3 fun_cmp() 1386 1387 Compares a function or a list of functions, using a named hash of options to set 1388 parameters. This can make for more readable code than using the function_cmp() 1389 style, but some people find one or the other easier to remember. 1390 1391 ANS( fun_cmp( answer or answer_array_ref, options_hash ) ); 1392 1393 1. a string containing the correct function, or a reference to an 1394 array of correct functions 1395 2. a hash containing the following items (all optional): 1396 var -- either the number of variables or a reference to an 1397 array of variable names (see below) 1398 limits -- reference to an array of arrays of limits (see below), or: 1399 mode -- 'std' (default) (function must match exactly), or: 1400 'antider' (function must match up to a constant) 1401 relTol -- (default) a relative tolerance (as a percentage), or: 1402 tol -- an absolute tolerance for error 1403 numPoints -- the number of points to evaluate the function at 1404 maxConstantOfIntegration -- maximum size of the constant of integration 1405 zeroLevel -- if the correct answer is this close to zero, then 1406 zeroLevelTol applies 1407 zeroLevelTol -- absolute tolerance to allow when answer is close to zero 1408 test_points -- a list of points to use in checking the function, or a list of lists when there is more than one variable. 1409 params an array of "free" parameters which can be used to adapt 1410 the correct answer to the submitted answer. (e.g. ['c'] for 1411 a constant of integration in the answer x^3/3 + c. 1412 debug -- when set to 1 this provides extra information while checking the 1413 the answer. 1414 1415 Returns an answer evaluator, or (if given a reference to an array 1416 of answers), a list of answer evaluators 1417 1418 ANSWER: 1419 1420 The answer must be in the form of a string. The answer can contain 1421 functions, pi, e, and arithmetic operations. However, the correct answer 1422 string follows a slightly stricter syntax than student answers; specifically, 1423 there is no implicit multiplication. So the correct answer must be "3*x" rather 1424 than "3 x". Students can still enter "3 x". 1425 1426 VARIABLES: 1427 1428 The var parameter can contain either a number or a reference to an array of 1429 variable names. If it contains a number, the variables are named automatically 1430 as follows: 1 variable -- x 1431 2 variables -- x, y 1432 3 variables -- x, y, z 1433 4 or more -- x_1, x_2, x_3, etc. 1434 If the var parameter contains a reference to an array of variable names, then 1435 the number of variables is determined by the number of items in the array. A 1436 reference to an array is created with brackets, e.g. "var => ['r', 's', 't']". 1437 If only one variable is being used, you can write either "var => ['t']" for 1438 consistency or "var => 't'" as a shortcut. The default is one variable, x. 1439 1440 LIMITS: 1441 1442 Limits are specified with the limits parameter. You may NOT use llimit/ulimit. 1443 If you specify limits for one variable, you must specify them for all variables. 1444 The limit parameter must be a reference to an array of arrays of the form 1445 [lower_limit. upper_limit], each array corresponding to the lower and upper 1446 endpoints of the (half-open) domain of one variable. For example, 1447 "vars => 2, limits => [[0,2], [-3,8]]" would cause x to be evaluated in [0,2) and 1448 y to be evaluated in [-3,8). If only one variable is being used, you can write 1449 either "limits => [[0,3]]" for consistency or "limits => [0,3]" as a shortcut. 1450 1451 TEST POINTS: 1452 1453 In some cases, the problem writer may want to specify the points 1454 used to check a particular function. For example, if you want to 1455 use only integer values, they can be specified. With one variable, 1456 you can specify "test_points => [1,4,5,6]" or "test_points => [[1,4,5,6]]". 1457 With more variables, specify the list for the first variable, then the 1458 second, and so on: "vars=>['x','y'], test_points => [[1,4,5],[7,14,29]]". 1459 1460 If the problem writer wants random values which need to meet some special 1461 restrictions (such as being integers), they can be generated in the problem: 1462 "test_points=>[random(1,50), random(1,50), random(1,50), random(1,50)]". 1463 1464 Note that test_points should not be used for function checks which involve 1465 parameters (either explicitly given by "params", or as antiderivatives). 1466 1467 EXAMPLES: 1468 1469 fun_cmp( "3*x" ) -- standard compare, variable is x 1470 fun_cmp( ["3*x", "4*x+3", "3*x**2"] ) -- standard compare, defaults used for all three functions 1471 fun_cmp( "3*t", var => 't' ) -- standard compare, variable is t 1472 fun_cmp( "5*x*y*z", var => 3 ) -- x, y and z are the variables 1473 fun_cmp( "5*x", mode => 'antider' ) -- student answer must match up to constant (i.e., 5x+C) 1474 fun_cmp( ["3*x*y", "4*x*y"], limits => [[0,2], [5,7]] ) -- x evaluated in [0,2) 1475 y evaluated in [5,7) 1476 1477 =cut 1478 1479 sub fun_cmp { 1480 my $correctAnswer = shift @_; 1481 my %opt = @_; 1482 1483 assign_option_aliases( \%opt, 1484 'vars' => 'var', # set the standard option 'var' to the one specified as vars 1485 'domain' => 'limits', # set the standard option 'limits' to the one specified as domain 1486 'reltol' => 'relTol', 1487 'param' => 'params', 1488 ); 1489 1490 set_default_options( \%opt, 1491 'var' => $functVarDefault, 1492 'params' => [], 1493 'limits' => [[$functLLimitDefault, $functULimitDefault]], 1494 'test_points' => undef, 1495 'mode' => 'std', 1496 'tolType' => (defined($opt{tol}) ) ? 'absolute' : 'relative', 1497 'tol' => .01, # default mode should be relative, to obtain this tol must not be defined 1498 'relTol' => $functRelPercentTolDefault, 1499 'numPoints' => $functNumOfPoints, 1500 'maxConstantOfIntegration' => $functMaxConstantOfIntegration, 1501 'zeroLevel' => $functZeroLevelDefault, 1502 'zeroLevelTol' => $functZeroLevelTolDefault, 1503 'debug' => 0, 1504 'diagnostics' => undef, 1505 ); 1506 1507 # allow var => 'x' as an abbreviation for var => ['x'] 1508 my %out_options = %opt; 1509 unless ( ref($out_options{var}) eq 'ARRAY' || $out_options{var} =~ m/^\d+$/) { 1510 $out_options{var} = [$out_options{var}]; 1511 } 1512 # allow params => 'c' as an abbreviation for params => ['c'] 1513 unless ( ref($out_options{params}) eq 'ARRAY' ) { 1514 $out_options{params} = [$out_options{params}]; 1515 } 1516 my ($tolType, $tol); 1517 if ($out_options{tolType} eq 'absolute') { 1518 $tolType = 'absolute'; 1519 $tol = $out_options{'tol'}; 1520 delete($out_options{'relTol'}) if exists( $out_options{'relTol'} ); 1521 } else { 1522 $tolType = 'relative'; 1523 $tol = $out_options{'relTol'}; 1524 delete($out_options{'tol'}) if exists( $out_options{'tol'} ); 1525 } 1526 1527 my @output_list = (); 1528 # thread over lists 1529 my @ans_list = (); 1530 1531 if ( ref($correctAnswer) eq 'ARRAY' ) { 1532 @ans_list = @{$correctAnswer}; 1533 } 1534 else { 1535 push( @ans_list, $correctAnswer ); 1536 } 1537 1538 # produce answer evaluators 1539 foreach my $ans (@ans_list) { 1540 push(@output_list, 1541 FUNCTION_CMP( 1542 'correctEqn' => $ans, 1543 'var' => $out_options{'var'}, 1544 'limits' => $out_options{'limits'}, 1545 'tolerance' => $tol, 1546 'tolType' => $tolType, 1547 'numPoints' => $out_options{'numPoints'}, 1548 'test_points' => $out_options{'test_points'}, 1549 'mode' => $out_options{'mode'}, 1550 'maxConstantOfIntegration' => $out_options{'maxConstantOfIntegration'}, 1551 'zeroLevel' => $out_options{'zeroLevel'}, 1552 'zeroLevelTol' => $out_options{'zeroLevelTol'}, 1553 'params' => $out_options{'params'}, 1554 'debug' => $out_options{'debug'}, 1555 'diagnostics' => $out_options{'diagnostics'} , 1556 ), 1557 ); 1558 } 1559 1560 return (wantarray) ? @output_list : $output_list[0]; 1561 } 1562 1563 =head3 Single-variable Function Comparisons 1564 1565 There are four single-variable function answer evaluators: "normal," absolute 1566 tolerance, antiderivative, and antiderivative with absolute tolerance. All 1567 parameters (other than the correct equation) are optional. 1568 1569 function_cmp( $correctEqn ) OR 1570 function_cmp( $correctEqn, $var ) OR 1571 function_cmp( $correctEqn, $var, $llimit, $ulimit ) OR 1572 function_cmp( $correctEqn, $var, $llimit, $ulimit, $relPercentTol ) OR 1573 function_cmp( $correctEqn, $var, $llimit, $ulimit, 1574 $relPercentTol, $numPoints ) OR 1575 function_cmp( $correctEqn, $var, $llimit, $ulimit, 1576 $relPercentTol, $numPoints, $zeroLevel ) OR 1577 function_cmp( $correctEqn, $var, $llimit, $ulimit, $relPercentTol, $numPoints, 1578 $zeroLevel,$zeroLevelTol ) 1579 1580 $correctEqn -- the correct equation, as a string 1581 $var -- the string representing the variable (optional) 1582 $llimit -- the lower limit of the interval to evaluate the 1583 variable in (optional) 1584 $ulimit -- the upper limit of the interval to evaluate the 1585 variable in (optional) 1586 $relPercentTol -- the error tolerance as a percentage (optional) 1587 $numPoints -- the number of points at which to evaluate the 1588 variable (optional) 1589 $zeroLevel -- if the correct answer is this close to zero, then 1590 zeroLevelTol applies (optional) 1591 $zeroLevelTol -- absolute tolerance to allow when answer is close to zero 1592 1593 function_cmp() uses standard comparison and relative tolerance. It takes a 1594 string representing a single-variable function and compares the student 1595 answer to that function numerically. 1596 1597 function_cmp_up_to_constant( $correctEqn ) OR 1598 function_cmp_up_to_constant( $correctEqn, $var ) OR 1599 function_cmp_up_to_constant( $correctEqn, $var, $llimit, $ulimit ) OR 1600 function_cmp_up_to_constant( $correctEqn, $var, $llimit, $ulimit, 1601 $relpercentTol ) OR 1602 function_cmp_up_to_constant( $correctEqn, $var, $llimit, $ulimit, 1603 $relpercentTol, $numOfPoints ) OR 1604 function_cmp_up_to_constant( $correctEqn, $var, $llimit, $ulimit, 1605 $relpercentTol, $numOfPoints, 1606 $maxConstantOfIntegration ) OR 1607 function_cmp_up_to_constant( $correctEqn, $var, $llimit, $ulimit, 1608 $relpercentTol, $numOfPoints, 1609 $maxConstantOfIntegration, $zeroLevel) OR 1610 function_cmp_up_to_constant( $correctEqn, $var, $llimit, $ulimit, 1611 $relpercentTol, $numOfPoints, 1612 $maxConstantOfIntegration, 1613 $zeroLevel, $zeroLevelTol ) 1614 1615 $maxConstantOfIntegration -- the maximum size of the constant of 1616 integration 1617 1618 function_cmp_up_to_constant() uses antiderivative compare and relative 1619 tolerance. All options work exactly like function_cmp(), except of course 1620 $maxConstantOfIntegration. It will accept as correct any function which 1621 differs from $correctEqn by at most a constant; that is, if 1622 $studentEqn = $correctEqn + C 1623 the answer is correct. 1624 1625 function_cmp_abs( $correctFunction ) OR 1626 function_cmp_abs( $correctFunction, $var ) OR 1627 function_cmp_abs( $correctFunction, $var, $llimit, $ulimit ) OR 1628 function_cmp_abs( $correctFunction, $var, $llimit, $ulimit, $absTol ) OR 1629 function_cmp_abs( $correctFunction, $var, $llimit, $ulimit, $absTol, 1630 $numOfPoints ) 1631 1632 $absTol -- the tolerance as an absolute value 1633 1634 function_cmp_abs() uses standard compare and absolute tolerance. All 1635 other options work exactly as for function_cmp(). 1636 1637 function_cmp_up_to_constant_abs( $correctFunction ) OR 1638 function_cmp_up_to_constant_abs( $correctFunction, $var ) OR 1639 function_cmp_up_to_constant_abs( $correctFunction, $var, $llimit, $ulimit ) OR 1640 function_cmp_up_to_constant_abs( $correctFunction, $var, $llimit, $ulimit, 1641 $absTol ) OR 1642 function_cmp_up_to_constant_abs( $correctFunction, $var, $llimit, $ulimit, 1643 $absTol, $numOfPoints ) OR 1644 function_cmp_up_to_constant_abs( $correctFunction, $var, $llimit, $ulimit, 1645 $absTol, $numOfPoints, 1646 $maxConstantOfIntegration ) 1647 1648 function_cmp_up_to_constant_abs() uses antiderivative compare 1649 and absolute tolerance. All other options work exactly as with 1650 function_cmp_up_to_constant(). 1651 1652 Examples: 1653 1654 ANS( function_cmp( "cos(x)" ) ) -- Accepts cos(x), sin(x+pi/2), 1655 sin(x)^2 + cos(x) + cos(x)^2 -1, etc. This assumes 1656 $functVarDefault has been set to "x". 1657 ANS( function_cmp( $answer, "t" ) ) -- Assuming $answer is "cos(t)", 1658 accepts cos(t), etc. 1659 ANS( function_cmp_up_to_constant( "cos(x)" ) ) -- Accepts any 1660 antiderivative of sin(x), e.g. cos(x) + 5. 1661 ANS( function_cmp_up_to_constant( "cos(z)", "z" ) ) -- Accepts any 1662 antiderivative of sin(z), e.g. sin(z+pi/2) + 5. 1663 1664 =cut 1665 1666 sub adaptive_function_cmp { 1667 my $correctEqn = shift; 1668 my %options = @_; 1669 set_default_options( \%options, 1670 'vars' => [qw( x y )], 1671 'params' => [], 1672 'limits' => [ [0,1], [0,1]], 1673 'reltol' => $functRelPercentTolDefault, 1674 'numPoints' => $functNumOfPoints, 1675 'zeroLevel' => $functZeroLevelDefault, 1676 'zeroLevelTol' => $functZeroLevelTolDefault, 1677 'debug' => 0, 1678 'diagnostics' => undef, 1679 ); 1680 1681 my $var_ref = $options{'vars'}; 1682 my $ra_params = $options{ 'params'}; 1683 my $limit_ref = $options{'limits'}; 1684 my $relPercentTol= $options{'reltol'}; 1685 my $numPoints = $options{'numPoints'}; 1686 my $zeroLevel = $options{'zeroLevel'}; 1687 my $zeroLevelTol = $options{'zeroLevelTol'}; 1688 1689 FUNCTION_CMP( 'correctEqn' => $correctEqn, 1690 'var' => $var_ref, 1691 'limits' => $limit_ref, 1692 'tolerance' => $relPercentTol, 1693 'tolType' => 'relative', 1694 'numPoints' => $numPoints, 1695 'mode' => 'std', 1696 'maxConstantOfIntegration' => 10**100, 1697 'zeroLevel' => $zeroLevel, 1698 'zeroLevelTol' => $zeroLevelTol, 1699 'scale_norm' => 1, 1700 'params' => $ra_params, 1701 'debug' => $options{debug} , 1702 'diagnostics' => $options{diagnostics} , 1703 ); 1704 } 1705 1706 sub function_cmp { 1707 my ($correctEqn,$var,$llimit,$ulimit,$relPercentTol,$numPoints,$zeroLevel,$zeroLevelTol) = @_; 1708 1709 if ( (scalar(@_) == 3) or (scalar(@_) > 8) or (scalar(@_) == 0) ) { 1710 function_invalid_params( $correctEqn ); 1711 } 1712 else { 1713 FUNCTION_CMP( 'correctEqn' => $correctEqn, 1714 'var' => $var, 1715 'limits' => [$llimit, $ulimit], 1716 'tolerance' => $relPercentTol, 1717 'tolType' => 'relative', 1718 'numPoints' => $numPoints, 1719 'mode' => 'std', 1720 'maxConstantOfIntegration' => 0, 1721 'zeroLevel' => $zeroLevel, 1722 'zeroLevelTol' => $zeroLevelTol 1723 ); 1724 } 1725 } 1726 1727 sub function_cmp_up_to_constant { ## for antiderivative problems 1728 my ($correctEqn,$var,$llimit,$ulimit,$relPercentTol,$numPoints,$maxConstantOfIntegration,$zeroLevel,$zeroLevelTol) = @_; 1729 1730 if ( (scalar(@_) == 3) or (scalar(@_) > 9) or (scalar(@_) == 0) ) { 1731 function_invalid_params( $correctEqn ); 1732 } 1733 else { 1734 FUNCTION_CMP( 'correctEqn' => $correctEqn, 1735 'var' => $var, 1736 'limits' => [$llimit, $ulimit], 1737 'tolerance' => $relPercentTol, 1738 'tolType' => 'relative', 1739 'numPoints' => $numPoints, 1740 'mode' => 'antider', 1741 'maxConstantOfIntegration' => $maxConstantOfIntegration, 1742 'zeroLevel' => $zeroLevel, 1743 'zeroLevelTol' => $zeroLevelTol 1744 ); 1745 } 1746 } 1747 1748 sub function_cmp_abs { ## similar to function_cmp but uses absolute tolerance 1749 my ($correctEqn,$var,$llimit,$ulimit,$absTol,$numPoints) = @_; 1750 1751 if ( (scalar(@_) == 3) or (scalar(@_) > 6) or (scalar(@_) == 0) ) { 1752 function_invalid_params( $correctEqn ); 1753 } 1754 else { 1755 FUNCTION_CMP( 'correctEqn' => $correctEqn, 1756 'var' => $var, 1757 'limits' => [$llimit, $ulimit], 1758 'tolerance' => $absTol, 1759 'tolType' => 'absolute', 1760 'numPoints' => $numPoints, 1761 'mode' => 'std', 1762 'maxConstantOfIntegration' => 0, 1763 'zeroLevel' => 0, 1764 'zeroLevelTol' => 0 1765 ); 1766 } 1767 } 1768 1769 1770 sub function_cmp_up_to_constant_abs { ## for antiderivative problems 1771 ## similar to function_cmp_up_to_constant 1772 ## but uses absolute tolerance 1773 my ($correctEqn,$var,$llimit,$ulimit,$absTol,$numPoints,$maxConstantOfIntegration) = @_; 1774 1775 if ( (scalar(@_) == 3) or (scalar(@_) > 7) or (scalar(@_) == 0) ) { 1776 function_invalid_params( $correctEqn ); 1777 } 1778 1779 else { 1780 FUNCTION_CMP( 'correctEqn' => $correctEqn, 1781 'var' => $var, 1782 'limits' => [$llimit, $ulimit], 1783 'tolerance' => $absTol, 1784 'tolType' => 'absolute', 1785 'numPoints' => $numPoints, 1786 'mode' => 'antider', 1787 'maxConstantOfIntegration' => $maxConstantOfIntegration, 1788 'zeroLevel' => 0, 1789 'zeroLevelTol' => 0 1790 ); 1791 } 1792 } 1793 1794 ## The following answer evaluator for comparing multivarable functions was 1795 ## contributed by Professor William K. Ziemer 1796 ## (Note: most of the multivariable functionality provided by Professor Ziemer 1797 ## has now been integrated into fun_cmp and FUNCTION_CMP) 1798 ############################ 1799 # W.K. Ziemer, Sep. 1999 1800 # Math Dept. CSULB 1801 # email: wziemer@csulb.edu 1802 ############################ 1803 1804 =head3 multivar_function_cmp 1805 1806 NOTE: this function is maintained for compatibility. fun_cmp() is 1807 slightly preferred. 1808 1809 usage: 1810 1811 multivar_function_cmp( $answer, $var_reference, options) 1812 $answer -- string, represents function of several variables 1813 $var_reference -- number (of variables), or list reference (e.g. ["var1","var2"] ) 1814 options: 1815 $limit_reference -- reference to list of lists (e.g. [[1,2],[3,4]]) 1816 $relPercentTol -- relative percent tolerance in answer 1817 $numPoints -- number of points to sample in for each variable 1818 $zeroLevel -- if the correct answer is this close to zero, then zeroLevelTol applies 1819 $zeroLevelTol -- absolute tolerance to allow when answer is close to zero 1820 1821 =cut 1822 1823 sub multivar_function_cmp { 1824 my ($correctEqn,$var_ref,$limit_ref,$relPercentTol,$numPoints,$zeroLevel,$zeroLevelTol) = @_; 1825 1826 if ( (scalar(@_) > 7) or (scalar(@_) < 2) ) { 1827 function_invalid_params( $correctEqn ); 1828 } 1829 1830 FUNCTION_CMP( 'correctEqn' => $correctEqn, 1831 'var' => $var_ref, 1832 'limits' => $limit_ref, 1833 'tolerance' => $relPercentTol, 1834 'tolType' => 'relative', 1835 'numPoints' => $numPoints, 1836 'mode' => 'std', 1837 'maxConstantOfIntegration' => 0, 1838 'zeroLevel' => $zeroLevel, 1839 'zeroLevelTol' => $zeroLevelTol 1840 ); 1841 } 1842 1843 ## LOW-LEVEL ROUTINE -- NOT NORMALLY FOR END USERS -- USE WITH CAUTION 1844 ## NOTE: PG_answer_eval is used instead of PG_restricted_eval in order to insure that the answer 1845 ## evaluated within the context of the package the problem was originally defined in. 1846 ## Includes multivariable modifications contributed by Professor William K. Ziemer 1847 ## 1848 ## IN: a hash consisting of the following keys (error checking to be added later?) 1849 ## correctEqn -- the correct equation as a string 1850 ## var -- the variable name as a string, 1851 ## or a reference to an array of variables 1852 ## limits -- reference to an array of arrays of type [lower,upper] 1853 ## tolerance -- the allowable margin of error 1854 ## tolType -- 'relative' or 'absolute' 1855 ## numPoints -- the number of points to evaluate the function at 1856 ## mode -- 'std' or 'antider' 1857 ## maxConstantOfIntegration -- maximum size of the constant of integration 1858 ## zeroLevel -- if the correct answer is this close to zero, 1859 ## then zeroLevelTol applies 1860 ## zeroLevelTol -- absolute tolerance to allow when answer is close to zero 1861 ## test_points -- user supplied points to use for testing the 1862 ## function, either array of arrays, or optionally 1863 ## reference to single array (for one variable) 1864 1865 1866 sub FUNCTION_CMP { 1867 return ORIGINAL_FUNCTION_CMP(@_) 1868 if main::PG_restricted_eval(q!$main::useOldAnswerMacros!); 1869 1870 my %func_params = @_; 1871 1872 my $correctEqn = $func_params{'correctEqn'}; 1873 my $var = $func_params{'var'}; 1874 my $ra_limits = $func_params{'limits'}; 1875 my $tol = $func_params{'tolerance'}; 1876 my $tolType = $func_params{'tolType'}; 1877 my $numPoints = $func_params{'numPoints'}; 1878 my $mode = $func_params{'mode'}; 1879 my $maxConstantOfIntegration = $func_params{'maxConstantOfIntegration'}; 1880 my $zeroLevel = $func_params{'zeroLevel'}; 1881 my $zeroLevelTol = $func_params{'zeroLevelTol'}; 1882 my $testPoints = $func_params{'test_points'}; 1883 1884 # 1885 # Check that everything is defined: 1886 # 1887 $func_params{debug} = 0 unless defined $func_params{debug}; 1888 $mode = 'std' unless defined $mode; 1889 my @VARS = get_var_array($var); 1890 my @limits = get_limits_array($ra_limits); 1891 my @PARAMS = @{$func_params{'params'} || []}; 1892 1893 if($tolType eq 'relative') { 1894 $tol = $functRelPercentTolDefault unless defined $tol; 1895 $tol *= .01; 1896 } else { 1897 $tol = $functAbsTolDefault unless defined $tol; 1898 } 1899 1900 # 1901 # Ensure that the number of limits matches number of variables 1902 # 1903 foreach my $i (0..scalar(@VARS)-1) { 1904 $limits[$i][0] = $functLLimitDefault unless defined $limits[$i][0]; 1905 $limits[$i][1] = $functULimitDefault unless defined $limits[$i][1]; 1906 } 1907 1908 # 1909 # Check that the test points are array references with the right number of coordinates 1910 # 1911 if ($testPoints) { 1912 my $n = scalar(@VARS); my $s = ($n != 1)? "s": ""; 1913 foreach my $p (@{$testPoints}) { 1914 $p = [$p] unless ref($p) eq 'ARRAY'; 1915 warn "Test point (".join(',',@{$p}).") should have $n coordiante$s" 1916 unless scalar(@{$p}) == $n; 1917 } 1918 } 1919 1920 $numPoints = $functNumOfPoints unless defined $numPoints; 1921 $maxConstantOfIntegration = $functMaxConstantOfIntegration unless defined $maxConstantOfIntegration; 1922 $zeroLevel = $functZeroLevelDefault unless defined $zeroLevel; 1923 $zeroLevelTol = $functZeroLevelTolDefault unless defined $zeroLevelTol; 1924 1925 $func_params{'var'} = \@VARS; 1926 $func_params{'params'} = \@PARAMS; 1927 $func_params{'limits'} = \@limits; 1928 $func_params{'tolerance'} = $tol; 1929 $func_params{'tolType'} = $tolType; 1930 $func_params{'numPoints'} = $numPoints; 1931 $func_params{'mode'} = $mode; 1932 $func_params{'maxConstantOfIntegration'} = $maxConstantOfIntegration; 1933 $func_params{'zeroLevel'} = $zeroLevel; 1934 $func_params{'zeroLevelTol'} = $zeroLevelTol; 1935 1936 ######################################################## 1937 # End of cleanup of calling parameters 1938 ######################################################## 1939 1940 my %options = ( 1941 debug => $func_params{'debug'}, 1942 diagnostics => $func_params{'diagnostics'}, 1943 ); 1944 1945 # 1946 # Initialize the context for the formula 1947 # 1948 my $context = $Parser::Context::Default::context{"LegacyNumeric"}->copy; 1949 $context->flags->set( 1950 tolerance => $func_params{'tolerance'}, 1951 tolType => $func_params{'tolType'}, 1952 zeroLevel => $func_params{'zeroLevel'}, 1953 zeroLevelTol => $func_params{'zeroLevelTol'}, 1954 num_points => $func_params{'numPoints'}, 1955 ); 1956 if ($func_params{'mode'} eq 'antider') { 1957 $context->flags->set(max_adapt => $func_params{'maxConstantOfIntegration'}); 1958 $options{upToConstant} = 1; 1959 } 1960 1961 # 1962 # Add the variables and parameters to the context 1963 # 1964 my %variables; my $x; 1965 foreach $x (@{$func_params{'var'}}) { 1966 if (length($x) > 1) { 1967 $context->{_variables}->{pattern} = $context->{_variables}->{namePattern} = 1968 $x . '|' . $context->{_variables}->{pattern}; 1969 $context->update; 1970 } 1971 $variables{$x} = 'Real'; 1972 } 1973 foreach $x (@{$func_params{'params'}}) {$variables{$x} = 'Parameter'} 1974 $context->variables->are(%variables); 1975 1976 # 1977 # Create the Formula object and get its answer checker 1978 # 1979 my $oldContext = &$Context(); &$Context($context); 1980 my $f = new Value::Formula($correctEqn); 1981 $f->{limits} = $func_params{'limits'}; 1982 $f->{test_points} = $func_params{'test_points'}; 1983 my $cmp = $f->cmp(%options); 1984 &$Context($oldContext); 1985 1986 # 1987 # Get previous answer from hidden field of form 1988 # 1989 $cmp->install_pre_filter( 1990 sub { 1991 my $rh_ans = shift; 1992 $rh_ans->{_filter_name} = "fetch_previous_answer"; 1993 my $prev_ans_label = "previous_".$rh_ans->{ans_label}; 1994 $rh_ans->{prev_ans} = 1995 (defined $inputs_ref->{$prev_ans_label} and 1996 $inputs_ref->{$prev_ans_label} =~/\S/) ? $inputs_ref->{$prev_ans_label} : undef; 1997 $rh_ans; 1998 } 1999 ); 2000 2001 # 2002 # Parse the previous answer, if any 2003 # 2004 $cmp->install_evaluator( 2005 sub { 2006 my $rh_ans = shift; 2007 $rh_ans->{_filter_name} = "parse_previous_answer"; 2008 return $rh_ans unless defined $rh_ans->{prev_ans}; 2009 my $oldContext = &$Context(); 2010 &$Context($rh_ans->{correct_value}{context}); 2011 $rh_ans->{prev_formula} = Parser::Formula($rh_ans->{prev_ans}); 2012 &$Context($oldContext); 2013 $rh_ans; 2014 } 2015 ); 2016 2017 # 2018 # Check if previous answer equals this current one 2019 # 2020 $cmp->install_evaluator( 2021 sub { 2022 my $rh_ans = shift; 2023 $rh_ans->{_filter_name} = "compare_to_previous_answer"; 2024 return $rh_ans unless defined($rh_ans->{prev_formula}) && defined($rh_ans->{student_formula}); 2025 $rh_ans->{prev_equals_current} = 2026 Value::cmp_compare($rh_ans->{student_formula},$rh_ans->{prev_formula},{}); 2027 $rh_ans; 2028 } 2029 ); 2030 2031 # 2032 # Produce a message if the previous answer equals this one 2033 # (and is not correct, and is not specified the same way) 2034 # 2035 $cmp->install_post_filter( 2036 sub { 2037 my $rh_ans = shift; 2038 $rh_ans->{_filter_name} = "produce_equivalence_message"; 2039 return $rh_ans unless $rh_ans->{prev_equals_current} && 2040 ($rh_ans->{score} != 1 || $rh_ans->{isPreview}); 2041 # 2042 # If the match is exact don't give an error since there may be multiple 2043 # entry blanks and the student is trying to get one of the other ones 2044 # right. We should only give this message when the student is actually 2045 # working on this answer. 2046 # 2047 return $rh_ans if $rh_ans->{prev_ans} eq $rh_ans->{original_student_ans}; 2048 $rh_ans->{ans_message} = "This answer is equivalent to the one you just submitted or previewed."; 2049 $rh_ans; 2050 } 2051 ); 2052 2053 return $cmp; 2054 } 2055 2056 # 2057 # The original version, for backward compatibility 2058 # (can be removed when the Parser-based version is more fully tested.) 2059 # 2060 sub ORIGINAL_FUNCTION_CMP { 2061 my %func_params = @_; 2062 2063 my $correctEqn = $func_params{'correctEqn'}; 2064 my $var = $func_params{'var'}; 2065 my $ra_limits = $func_params{'limits'}; 2066 my $tol = $func_params{'tolerance'}; 2067 my $tolType = $func_params{'tolType'}; 2068 my $numPoints = $func_params{'numPoints'}; 2069 my $mode = $func_params{'mode'}; 2070 my $maxConstantOfIntegration = $func_params{'maxConstantOfIntegration'}; 2071 my $zeroLevel = $func_params{'zeroLevel'}; 2072 my $zeroLevelTol = $func_params{'zeroLevelTol'}; 2073 my $ra_test_points = $func_params{'test_points'}; 2074 2075 # Check that everything is defined: 2076 $func_params{debug} = 0 unless defined $func_params{debug}; 2077 $mode = 'std' unless defined $mode; 2078 my @VARS = get_var_array($var); 2079 my @limits = get_limits_array($ra_limits); 2080 my @PARAMS = (); 2081 @PARAMS = @{$func_params{'params'}} if defined $func_params{'params'}; 2082 2083 my @evaluation_points; 2084 if(defined $ra_test_points) { 2085 # see if this is the standard format 2086 if(ref $ra_test_points->[0] eq 'ARRAY') { 2087 $numPoints = scalar @{$ra_test_points->[0]}; 2088 # now a little sanity check 2089 my $j; 2090 for $j (@{$ra_test_points}) { 2091 warn "Test points do not give the same number of values for each variable" 2092 unless(scalar(@{$j}) == $numPoints); 2093 } 2094 warn "Test points do not match the number of variables" 2095 unless scalar @{$ra_test_points} == scalar @VARS; 2096 } else { # we are got the one-variable format 2097 $ra_test_points = [$ra_test_points]; 2098 $numPoints = scalar $ra_test_points->[0]; 2099 } 2100 # The input format for test points is the transpose of what is used 2101 # internally below, so take care of that now. 2102 my ($j1, $j2); 2103 for ($j1 = 0; $j1 < scalar @{$ra_test_points}; $j1++) { 2104 for ($j2 = 0; $j2 < scalar @{$ra_test_points->[$j1]}; $j2++) { 2105 $evaluation_points[$j2][$j1] = $ra_test_points->[$j1][$j2]; 2106 } 2107 } 2108 } # end of handling of user supplied evaluation points 2109 2110 if ($mode eq 'antider') { 2111 # doctor the equation to allow addition of a constant 2112 my $CONSTANT_PARAM = 'Q'; # unfortunately parameters must be single letters. 2113 # There is the possibility of conflict here. 2114 # 'Q' seemed less dangerous than 'C'. 2115 $correctEqn = "( $correctEqn ) + $CONSTANT_PARAM"; 2116 push @PARAMS, $CONSTANT_PARAM; 2117 } 2118 my $dim_of_param_space = @PARAMS; # dimension of equivalence space 2119 2120 if($tolType eq 'relative') { 2121 $tol = $functRelPercentTolDefault unless defined $tol; 2122 $tol *= .01; 2123 } else { 2124 $tol = $functAbsTolDefault unless defined $tol; 2125 } 2126 2127 #loop ensures that number of limits matches number of variables 2128 for(my $i = 0; $i < scalar @VARS; $i++) { 2129 $limits[$i][0] = $functLLimitDefault unless defined $limits[$i][0]; 2130 $limits[$i][1] = $functULimitDefault unless defined $limits[$i][1]; 2131 } 2132 $numPoints = $functNumOfPoints unless defined $numPoints; 2133 $maxConstantOfIntegration = $functMaxConstantOfIntegration unless defined $maxConstantOfIntegration; 2134 $zeroLevel = $functZeroLevelDefault unless defined $zeroLevel; 2135 $zeroLevelTol = $functZeroLevelTolDefault unless defined $zeroLevelTol; 2136 2137 $func_params{'var'} = $var; 2138 $func_params{'limits'} = \@limits; 2139 $func_params{'tolerance'} = $tol; 2140 $func_params{'tolType'} = $tolType; 2141 $func_params{'numPoints'} = $numPoints; 2142 $func_params{'mode'} = $mode; 2143 $func_params{'maxConstantOfIntegration'} = $maxConstantOfIntegration; 2144 $func_params{'zeroLevel'} = $zeroLevel; 2145 $func_params{'zeroLevelTol'} = $zeroLevelTol; 2146 2147 ######################################################## 2148 # End of cleanup of calling parameters 2149 ######################################################## 2150 2151 my $i; # for use with loops 2152 my $PGanswerMessage = ""; 2153 my $originalCorrEqn = $correctEqn; 2154 2155 ###################################################################### 2156 # prepare the correct answer and check its syntax 2157 ###################################################################### 2158 2159 my $rh_correct_ans = new AnswerHash; 2160 $rh_correct_ans->input($correctEqn); 2161 $rh_correct_ans = check_syntax($rh_correct_ans); 2162 warn $rh_correct_ans->{error_message} if $rh_correct_ans->{error_flag}; 2163 $rh_correct_ans->clear_error(); 2164 $rh_correct_ans = function_from_string2($rh_correct_ans, 2165 ra_vars => [ @VARS, @PARAMS ], 2166 stdout => 'rf_correct_ans', 2167 debug => $func_params{debug} 2168 ); 2169 my $correct_eqn_sub = $rh_correct_ans->{rf_correct_ans}; 2170 warn $rh_correct_ans->{error_message} if $rh_correct_ans->{error_flag}; 2171 2172 ###################################################################### 2173 # define the points at which the functions are to be evaluated 2174 ###################################################################### 2175 2176 if(not defined $ra_test_points) { 2177 #create the evaluation points 2178 my $random_for_answers = new PGrandom($main::PG_original_problemSeed); 2179 my $NUMBER_OF_STEPS_IN_RANDOM = 1000; # determines the granularity of the random_for_answers number generator 2180 for(my $count = 0; $count < @PARAMS+1+$numPoints; $count++) { 2181 my (@vars,$iteration_limit); 2182 for(my $i = 0; $i < @VARS; $i++) { 2183 my $iteration_limit = 10; 2184 while (0 < --$iteration_limit) { # make sure that the endpoints of the interval are not included 2185 $vars[$i] = $random_for_answers->random($limits[$i][0], $limits[$i][1], abs($limits[$i][1] - $limits[$i][0])/$NUMBER_OF_STEPS_IN_RANDOM); 2186 last if $vars[$i]!=$limits[$i][0] and $vars[$i]!=$limits[$i][1]; 2187 } 2188 warn "Unable to properly choose evaluation points for this function in the interval ( $limits[$i][0] , $limits[$i][1] )" 2189 if $iteration_limit == 0; 2190 } 2191 2192 push @evaluation_points, \@vars; 2193 } 2194 } 2195 my $evaluation_points = Matrix->new_from_array_ref(\@evaluation_points); 2196 2197 #my $COEFFS = determine_param_coeffs($correct_eqn_sub,$evaluation_points[0],$numOfParameters); 2198 #warn "coeff", join(" | ", @{$COEFFS}); 2199 2200 #construct the answer evaluator 2201 my $answer_evaluator = new AnswerEvaluator; 2202 $answer_evaluator->{debug} = $func_params{debug}; 2203 $answer_evaluator->ans_hash( 2204 correct_ans => $originalCorrEqn, 2205 rf_correct_ans => $rh_correct_ans->{rf_correct_ans}, 2206 evaluation_points => \@evaluation_points, 2207 ra_param_vars => \@PARAMS, 2208 ra_vars => \@VARS, 2209 type => 'function', 2210 score => 0, 2211 ); 2212 2213 ######################################################### 2214 # Prepare the previous answer for evaluation, discard errors 2215 ######################################################### 2216 2217 $answer_evaluator->install_pre_filter( 2218 sub { 2219 my $rh_ans = shift; 2220 $rh_ans->{_filter_name} = "fetch_previous_answer"; 2221 my $prev_ans_label = "previous_".$rh_ans->{ans_label}; 2222 $rh_ans->{prev_ans} = (defined $inputs_ref->{$prev_ans_label} and $inputs_ref->{$prev_ans_label} =~/\S/) 2223 ? $inputs_ref->{$prev_ans_label} 2224 : undef; 2225 $rh_ans; 2226 } 2227 ); 2228 2229 $answer_evaluator->install_pre_filter( 2230 sub { 2231 my $rh_ans = shift; 2232 return $rh_ans unless defined $rh_ans->{prev_ans}; 2233 check_syntax($rh_ans, 2234 stdin => 'prev_ans', 2235 stdout => 'prev_ans', 2236 error_msg_flag => 0 2237 ); 2238 $rh_ans->{_filter_name} = "check_syntax_of_previous_answer"; 2239 $rh_ans; 2240 } 2241 ); 2242 2243 $answer_evaluator->install_pre_filter( 2244 sub { 2245 my $rh_ans = shift; 2246 return $rh_ans unless defined $rh_ans->{prev_ans}; 2247 function_from_string2($rh_ans, 2248 stdin => 'prev_ans', 2249 stdout => 'rf_prev_ans', 2250 ra_vars => \@VARS, 2251 debug => $func_params{debug} 2252 ); 2253 $rh_ans->{_filter_name} = "compile_previous_answer"; 2254 $rh_ans; 2255 } 2256 ); 2257 2258 ######################################################### 2259 # Prepare the current answer for evaluation 2260 ######################################################### 2261 2262 $answer_evaluator->install_pre_filter(\&check_syntax); 2263 $answer_evaluator->install_pre_filter(\&function_from_string2, 2264 ra_vars => \@VARS, 2265 debug => $func_params{debug} 2266 ); # @VARS has been guaranteed to be an array, $var might be a single string. 2267 2268 ######################################################### 2269 # Compare the previous and current answer. Discard errors 2270 ######################################################### 2271 2272 $answer_evaluator->install_evaluator( 2273 sub { 2274 my $rh_ans = shift; 2275 return $rh_ans unless defined $rh_ans->{rf_prev_ans}; 2276 calculate_difference_vector($rh_ans, 2277 %func_params, 2278 stdin1 => 'rf_student_ans', 2279 stdin2 => 'rf_prev_ans', 2280 stdout => 'ra_diff_with_prev_ans', 2281 error_msg_flag => 0, 2282 ); 2283 $rh_ans->{_filter_name} = "calculate_difference_vector_of_previous_answer"; 2284 $rh_ans; 2285 } 2286 ); 2287 2288 $answer_evaluator->install_evaluator( 2289 sub { 2290 my $rh_ans = shift; 2291 return $rh_ans unless defined $rh_ans->{ra_diff_with_prev_ans}; 2292 ## 2293 ## DPVC -- only give the message if the answer is specified differently 2294 ## 2295 return $rh_ans if $rh_ans->{prev_ans} eq $rh_ans->{student_ans}; 2296 ## 2297 ## /DPVC 2298 ## 2299 is_zero_array($rh_ans, 2300 stdin => 'ra_diff_with_prev_ans', 2301 stdout => 'ans_equals_prev_ans' 2302 ); 2303 } 2304 ); 2305 2306 ######################################################### 2307 # Calculate values for approximation parameters and 2308 # compare the current answer with the correct answer. Keep errors this time. 2309 ######################################################### 2310 2311 $answer_evaluator->install_pre_filter(\&best_approx_parameters, %func_params, param_vars => \@PARAMS); 2312 $answer_evaluator->install_evaluator(\&calculate_difference_vector, %func_params); 2313 $answer_evaluator->install_evaluator(\&is_zero_array, tolerance => $tol ); 2314 2315 $answer_evaluator->install_post_filter( 2316 sub { 2317 my $rh_ans = shift; 2318 $rh_ans->clear_error('SYNTAX'); 2319 $rh_ans; 2320 } 2321 ); 2322 2323 $answer_evaluator->install_post_filter( 2324 sub { 2325 my $rh_ans = shift; 2326 if ($rh_ans->catch_error('EVAL')) { 2327 $rh_ans->{ans_message} = $rh_ans->{error_message}; 2328 $rh_ans->clear_error('EVAL'); 2329 } 2330 $rh_ans; 2331 } 2332 ); 2333 2334 $answer_evaluator->install_post_filter( 2335 sub { 2336 my $rh_ans = shift; 2337 if ( defined($rh_ans->{'ans_equals_prev_ans'}) and $rh_ans->{'ans_equals_prev_ans'} and $rh_ans->{score}==0) { 2338 ## $rh_ans->{ans_message} = "This answer is the same as the one you just submitted or previewed."; 2339 $rh_ans->{ans_message} = "This answer is equivalent to the one you just submitted or previewed."; ## DPVC 2340 } 2341 $rh_ans; 2342 } 2343 ); 2344 2345 $answer_evaluator; 2346 } 2347 2348 2349 ## LOW-LEVEL ROUTINE -- NOT NORMALLY FOR END USERS -- USE WITH CAUTION 2350 ## 2351 ## IN: a hash containing the following items (error-checking to be added later?): 2352 ## correctAnswer -- the correct answer 2353 ## tolerance -- the allowable margin of error 2354 ## tolType -- 'relative' or 'absolute' 2355 ## format -- the display format of the answer 2356 ## mode -- one of 'std', 'strict', 'arith', or 'frac'; 2357 ## determines allowable formats for the input 2358 ## zeroLevel -- if the correct answer is this close to zero, then zeroLevelTol applies 2359 ## zeroLevelTol -- absolute tolerance to allow when answer is close to zero 2360 2361 2362 ########################################################################## 2363 ########################################################################## 2364 ## String answer evaluators 2365 2366 =head2 String Answer Evaluators 2367 2368 String answer evaluators compare a student string to the correct string. 2369 Different filters can be applied to allow various degrees of variation. 2370 Both the student and correct answers are subject to the same filters, to 2371 ensure that there are no unexpected matches or rejections. 2372 2373 String Filters 2374 2375 remove_whitespace -- Removes all whitespace from the string. 2376 It applies the following substitution 2377 to the string: 2378 $filteredAnswer =~ s/\s+//g; 2379 2380 compress_whitespace -- Removes leading and trailing whitespace, and 2381 replaces all other blocks of whitespace by a 2382 single space. Applies the following substitutions: 2383 $filteredAnswer =~ s/^\s*//; 2384 $filteredAnswer =~ s/\s*$//; 2385 $filteredAnswer =~ s/\s+/ /g; 2386 2387 trim_whitespace -- Removes leading and trailing whitespace. 2388 Applies the following substitutions: 2389 $filteredAnswer =~ s/^\s*//; 2390 $filteredAnswer =~ s/\s*$//; 2391 2392 ignore_case -- Ignores the case of the string. More accurately, 2393 it converts the string to uppercase (by convention). 2394 Applies the following function: 2395 $filteredAnswer = uc $filteredAnswer; 2396 2397 ignore_order -- Ignores the order of the letters in the string. 2398 This is used for problems of the form "Choose all 2399 that apply." Specifically, it removes all 2400 whitespace and lexically sorts the letters in 2401 ascending alphabetical order. Applies the following 2402 functions: 2403 $filteredAnswer = join( "", lex_sort( 2404 split( /\s*/, $filteredAnswer ) ) ); 2405 2406 =cut 2407 2408 ################################ 2409 ## STRING ANSWER FILTERS 2410 2411 ## IN: --the string to be filtered 2412 ## --a list of the filters to use 2413 ## 2414 ## OUT: --the modified string 2415 ## 2416 ## Use this subroutine instead of the 2417 ## individual filters below it 2418 2419 sub str_filters { 2420 my $stringToFilter = shift @_; 2421 # filters now take an answer hash, so encapsulate the string 2422 # in the answer hash. 2423 my $rh_ans = new AnswerHash; 2424 $rh_ans->{student_ans} = $stringToFilter; 2425 $rh_ans->{correct_ans}=''; 2426 my @filters_to_use = @_; 2427 my %known_filters = ( 2428 'remove_whitespace' => \&remove_whitespace, 2429 'compress_whitespace' => \&compress_whitespace, 2430 'trim_whitespace' => \&trim_whitespace, 2431 'ignore_case' => \&ignore_case, 2432 'ignore_order' => \&ignore_order, 2433 ); 2434 2435 #test for unknown filters 2436 foreach my $filter ( @filters_to_use ) { 2437 #check that filter is known 2438 die "Unknown string filter $filter (try checking the parameters to str_cmp() )" 2439 unless exists $known_filters{$filter}; 2440 $rh_ans = $known_filters{$filter}($rh_ans); # apply filter. 2441 } 2442 # foreach $filter (@filters_to_use) { 2443 # die "Unknown string filter $filter (try checking the parameters to str_cmp() )" 2444 # unless exists $known_filters{$filter}; 2445 # } 2446 # 2447 # if( grep( /remove_whitespace/i, @filters_to_use ) ) { 2448 # $rh_ans = remove_whitespace( $rh_ans ); 2449 # } 2450 # if( grep( /compress_whitespace/i, @filters_to_use ) ) { 2451 # $rh_ans = compress_whitespace( $rh_ans ); 2452 # } 2453 # if( grep( /trim_whitespace/i, @filters_to_use ) ) { 2454 # $rh_ans = trim_whitespace( $rh_ans ); 2455 # } 2456 # if( grep( /ignore_case/i, @filters_to_use ) ) { 2457 # $rh_ans = ignore_case( $rh_ans ); 2458 # } 2459 # if( grep( /ignore_order/i, @filters_to_use ) ) { 2460 # $rh_ans = ignore_order( $rh_ans ); 2461 # } 2462 2463 return $rh_ans->{student_ans}; 2464 } 2465 sub remove_whitespace { 2466 my $rh_ans = shift; 2467 die "expected an answer hash" unless ref($rh_ans)=~/HASH/i; 2468 $rh_ans->{_filter_name} = 'remove_whitespace'; 2469 $rh_ans->{student_ans} =~ s/\s+//g; # remove all whitespace 2470 $rh_ans->{correct_ans} =~ s/\s+//g; # remove all whitespace 2471 return $rh_ans; 2472 } 2473 2474 sub compress_whitespace { 2475 my $rh_ans = shift; 2476 die "expected an answer hash" unless ref($rh_ans)=~/HASH/i; 2477 $rh_ans->{_filter_name} = 'compress_whitespace'; 2478 $rh_ans->{student_ans} =~ s/^\s*//; # remove initial whitespace 2479 $rh_ans->{student_ans} =~ s/\s*$//; # remove trailing whitespace 2480 $rh_ans->{student_ans} =~ s/\s+/ /g; # replace spaces by single space 2481 $rh_ans->{correct_ans} =~ s/^\s*//; # remove initial whitespace 2482 $rh_ans->{correct_ans} =~ s/\s*$//; # remove trailing whitespace 2483 $rh_ans->{correct_ans} =~ s/\s+/ /g; # replace spaces by single space 2484 2485 return $rh_ans; 2486 } 2487 2488 sub trim_whitespace { 2489 my $rh_ans = shift; 2490 die "expected an answer hash" unless ref($rh_ans)=~/HASH/i; 2491 $rh_ans->{_filter_name} = 'trim_whitespace'; 2492 $rh_ans->{student_ans} =~ s/^\s*//; # remove initial whitespace 2493 $rh_ans->{student_ans} =~ s/\s*$//; # remove trailing whitespace 2494 $rh_ans->{correct_ans} =~ s/^\s*//; # remove initial whitespace 2495 $rh_ans->{correct_ans} =~ s/\s*$//; # remove trailing whitespace 2496 2497 return $rh_ans; 2498 } 2499 2500 sub ignore_case { 2501 my $rh_ans = shift; 2502 die "expected an answer hash" unless ref($rh_ans)=~/HASH/i; 2503 $rh_ans->{_filter_name} = 'ignore_case'; 2504 $rh_ans->{student_ans} =~ tr/a-z/A-Z/; 2505 $rh_ans->{correct_ans} =~ tr/a-z/A-Z/; 2506 return $rh_ans; 2507 } 2508 2509 sub ignore_order { 2510 my $rh_ans = shift; 2511 die "expected an answer hash" unless ref($rh_ans)=~/HASH/i; 2512 $rh_ans->{_filter_name} = 'ignore_order'; 2513 $rh_ans->{student_ans} = join( "", lex_sort( split( /\s*/, $rh_ans->{student_ans} ) ) ); 2514 $rh_ans->{correct_ans} = join( "", lex_sort( split( /\s*/, $rh_ans->{correct_ans} ) ) ); 2515 2516 return $rh_ans; 2517 } 2518 # sub remove_whitespace { 2519 # my $filteredAnswer = shift; 2520 # 2521 # $filteredAnswer =~ s/\s+//g; # remove all whitespace 2522 # 2523 # return $filteredAnswer; 2524 # } 2525 # 2526 # sub compress_whitespace { 2527 # my $filteredAnswer = shift; 2528 # 2529 # $filteredAnswer =~ s/^\s*//; # remove initial whitespace 2530 # $filteredAnswer =~ s/\s*$//; # remove trailing whitespace 2531 # $filteredAnswer =~ s/\s+/ /g; # replace spaces by single space 2532 # 2533 # return $filteredAnswer; 2534 # } 2535 # 2536 # sub trim_whitespace { 2537 # my $filteredAnswer = shift; 2538 # 2539 # $filteredAnswer =~ s/^\s*//; # remove initial whitespace 2540 # $filteredAnswer =~ s/\s*$//; # remove trailing whitespace 2541 # 2542 # return $filteredAnswer; 2543 # } 2544 # 2545 # sub ignore_case { 2546 # my $filteredAnswer = shift; 2547 # #warn "filtered answer is ", $filteredAnswer; 2548 # #$filteredAnswer = uc $filteredAnswer; # this didn't work on webwork xmlrpc, but does elsewhere ???? 2549 # $filteredAnswer =~ tr/a-z/A-Z/; 2550 # 2551 # return $filteredAnswer; 2552 # } 2553 # 2554 # sub ignore_order { 2555 # my $filteredAnswer = shift; 2556 # 2557 # $filteredAnswer = join( "", lex_sort( split( /\s*/, $filteredAnswer ) ) ); 2558 # 2559 # return $filteredAnswer; 2560 # } 2561 ################################ 2562 ## END STRING ANSWER FILTERS 2563 2564 2565 =head3 str_cmp() 2566 2567 Compares a string or a list of strings, using a named hash of options to set 2568 parameters. This can make for more readable code than using the "mode"_str_cmp() 2569 style, but some people find one or the other easier to remember. 2570 2571 ANS( str_cmp( answer or answer_array_ref, options_hash ) ); 2572 2573 1. the correct answer or a reference to an array of answers 2574 2. either a list of filters, or: 2575 a hash consisting of 2576 filters - a reference to an array of filters 2577 2578 Returns an answer evaluator, or (if given a reference to an array of answers), 2579 a list of answer evaluators 2580 2581 FILTERS: 2582 2583 remove_whitespace -- removes all whitespace 2584 compress_whitespace -- removes whitespace from the beginning and end of the string, 2585 and treats one or more whitespace characters in a row as a 2586 single space (true by default) 2587 trim_whitespace -- removes whitespace from the beginning and end of the string 2588 ignore_case -- ignores the case of the letters (true by default) 2589 ignore_order -- ignores the order in which letters are entered 2590 2591 EXAMPLES: 2592 2593 str_cmp( "Hello" ) -- matches "Hello", " hello" (same as std_str_cmp() ) 2594 str_cmp( ["Hello", "Goodbye"] ) -- same as std_str_cmp_list() 2595 str_cmp( " hello ", trim_whitespace ) -- matches "hello", " hello " 2596 str_cmp( "ABC", filters => 'ignore_order' ) -- matches "ACB", "A B C", but not "abc" 2597 str_cmp( "D E F", remove_whitespace, ignore_case ) -- matches "def" and "d e f" but not "fed" 2598 2599 2600 =cut 2601 2602 sub str_cmp { 2603 my $correctAnswer = shift @_; 2604 $correctAnswer = '' unless defined($correctAnswer); 2605 my @options = @_; 2606 my %options = (); 2607 # backward compatibility 2608 if (grep /filters|debug|filter/, @options) { # see whether we have hash keys in the input. 2609 %options = @options; 2610 } elsif (@options) { # all options are names of filters. 2611 $options{filters} = [@options]; 2612 } 2613 my $ra_filters; 2614 assign_option_aliases( \%options, 2615 'filter' => 'filters', 2616 ); 2617 set_default_options( \%options, 2618 'filters' => [qw(trim_whitespace compress_whitespace ignore_case)], 2619 'debug' => 0, 2620 'type' => 'str_cmp', 2621 ); 2622 $options{filters} = (ref($options{filters}))?$options{filters}:[$options{filters}]; 2623 # make sure this is a reference to an array. 2624 # error-checking for filters occurs in the filters() subroutine 2625 # if( not defined( $options[0] ) ) { # used with no filters as alias for std_str_cmp() 2626 # @options = ( 'compress_whitespace', 'ignore_case' ); 2627 # } 2628 # 2629 # if( $options[0] eq 'filters' ) { # using filters => [f1, f2, ...] notation 2630 # $ra_filters = $options[1]; 2631 # } 2632 # else { # using a list of filters 2633 # $ra_filters = \@options; 2634 # } 2635 2636 # thread over lists 2637 my @ans_list = (); 2638 2639 if ( ref($correctAnswer) eq 'ARRAY' ) { 2640 @ans_list = @{$correctAnswer}; 2641 } 2642 else { 2643 push( @ans_list, $correctAnswer ); 2644 } 2645 2646 # final_answer; 2647 my @output_list = (); 2648 2649 foreach my $ans (@ans_list) { 2650 push(@output_list, STR_CMP( 2651 'correct_ans' => $ans, 2652 'filters' => $options{filters}, 2653 'type' => $options{type}, 2654 'debug' => $options{debug}, 2655 ) 2656 ); 2657 } 2658 2659 return (wantarray) ? @output_list : $output_list[0] ; 2660 } 2661 2662 =head3 "mode"_str_cmp functions 2663 2664 The functions of the the form "mode"_str_cmp() use different functions to 2665 specify which filters to apply. They take no options except the correct 2666 string. There are also versions which accept a list of strings. 2667 2668 std_str_cmp( $correctString ) 2669 std_str_cmp_list( @correctStringList ) 2670 Filters: compress_whitespace, ignore_case 2671 2672 std_cs_str_cmp( $correctString ) 2673 std_cs_str_cmp_list( @correctStringList ) 2674 Filters: compress_whitespace 2675 2676 strict_str_cmp( $correctString ) 2677 strict_str_cmp_list( @correctStringList ) 2678 Filters: trim_whitespace 2679 2680 unordered_str_cmp( $correctString ) 2681 unordered_str_cmp_list( @correctStringList ) 2682 Filters: ignore_order, ignore_case 2683 2684 unordered_cs_str_cmp( $correctString ) 2685 unordered_cs_str_cmp_list( @correctStringList ) 2686 Filters: ignore_order 2687 2688 ordered_str_cmp( $correctString ) 2689 ordered_str_cmp_list( @correctStringList ) 2690 Filters: remove_whitespace, ignore_case 2691 2692 ordered_cs_str_cmp( $correctString ) 2693 ordered_cs_str_cmp_list( @correctStringList ) 2694 Filters: remove_whitespace 2695 2696 Examples 2697 2698 ANS( std_str_cmp( "W. Mozart" ) ) -- Accepts "W. Mozart", "W. MOZarT", 2699 and so forth. Case insensitive. All internal spaces treated 2700 as single spaces. 2701 ANS( std_cs_str_cmp( "Mozart" ) ) -- Rejects "mozart". Same as 2702 std_str_cmp() but case sensitive. 2703 ANS( strict_str_cmp( "W. Mozart" ) ) -- Accepts only the exact string. 2704 ANS( unordered_str_cmp( "ABC" ) ) -- Accepts "a c B", "CBA" and so forth. 2705 Unordered, case insensitive, spaces ignored. 2706 ANS( unordered_cs_str_cmp( "ABC" ) ) -- Rejects "abc". Same as 2707 unordered_str_cmp() but case sensitive. 2708 ANS( ordered_str_cmp( "ABC" ) ) -- Accepts "a b C", "A B C" and so forth. 2709 Ordered, case insensitive, spaces ignored. 2710 ANS( ordered_cs_str_cmp( "ABC" ) ) -- Rejects "abc", accepts "A BC" and 2711 so forth. Same as ordered_str_cmp() but case sensitive. 2712 2713 =cut 2714 2715 sub std_str_cmp { # compare strings 2716 my $correctAnswer = shift @_; 2717 my @filters = ( 'compress_whitespace', 'ignore_case' ); 2718 my $type = 'std_str_cmp'; 2719 STR_CMP('correct_ans' => $correctAnswer, 2720 'filters' => \@filters, 2721 'type' => $type 2722 ); 2723 } 2724 2725 sub std_str_cmp_list { # alias for std_str_cmp 2726 my @answerList = @_; 2727 my @output; 2728 while (@answerList) { 2729 push( @output, std_str_cmp(shift @answerList) ); 2730 } 2731 @output; 2732 } 2733 2734 sub std_cs_str_cmp { # compare strings case sensitive 2735 my $correctAnswer = shift @_; 2736 my @filters = ( 'compress_whitespace' ); 2737 my $type = 'std_cs_str_cmp'; 2738 STR_CMP( 'correct_ans' => $correctAnswer, 2739 'filters' => \@filters, 2740 'type' => $type 2741 ); 2742 } 2743 2744 sub std_cs_str_cmp_list { # alias for std_cs_str_cmp 2745 my @answerList = @_; 2746 my @output; 2747 while (@answerList) { 2748 push( @output, std_cs_str_cmp(shift @answerList) ); 2749 } 2750 @output; 2751 } 2752 2753 sub strict_str_cmp { # strict string compare 2754 my $correctAnswer = shift @_; 2755 my @filters = ( 'trim_whitespace' ); 2756 my $type = 'strict_str_cmp'; 2757 STR_CMP( 'correct_ans' => $correctAnswer, 2758 'filters' => \@filters, 2759 'type' => $type 2760 ); 2761 } 2762 2763 sub strict_str_cmp_list { # alias for strict_str_cmp 2764 my @answerList = @_; 2765 my @output; 2766 while (@answerList) { 2767 push( @output, strict_str_cmp(shift @answerList) ); 2768 } 2769 @output; 2770 } 2771 2772 sub unordered_str_cmp { # unordered, case insensitive, spaces ignored 2773 my $correctAnswer = shift @_; 2774 my @filters = ( 'ignore_order', 'ignore_case' ); 2775 my $type = 'unordered_str_cmp'; 2776 STR_CMP( 'correct_ans' => $correctAnswer, 2777 'filters' => \@filters, 2778 'type' => $type 2779 ); 2780 } 2781 2782 sub unordered_str_cmp_list { # alias for unordered_str_cmp 2783 my @answerList = @_; 2784 my @output; 2785 while (@answerList) { 2786 push( @output, unordered_str_cmp(shift @answerList) ); 2787 } 2788 @output; 2789 } 2790 2791 sub unordered_cs_str_cmp { # unordered, case sensitive, spaces ignored 2792 my $correctAnswer = shift @_; 2793 my @filters = ( 'ignore_order' ); 2794 my $type = 'unordered_cs_str_cmp'; 2795 STR_CMP( 'correct_ans' => $correctAnswer, 2796 'filters' => \@filters, 2797 'type' => $type 2798 ); 2799 } 2800 2801 sub unordered_cs_str_cmp_list { # alias for unordered_cs_str_cmp 2802 my @answerList = @_; 2803 my @output; 2804 while (@answerList) { 2805 push( @output, unordered_cs_str_cmp(shift @answerList) ); 2806 } 2807 @output; 2808 } 2809 2810 sub ordered_str_cmp { # ordered, case insensitive, spaces ignored 2811 my $correctAnswer = shift @_; 2812 my @filters = ( 'remove_whitespace', 'ignore_case' ); 2813 my $type = 'ordered_str_cmp'; 2814 STR_CMP( 'correct_ans' => $correctAnswer, 2815 'filters' => \@filters, 2816 'type' => $type 2817 ); 2818 } 2819 2820 sub ordered_str_cmp_list { # alias for ordered_str_cmp 2821 my @answerList = @_; 2822 my @output; 2823 while (@answerList) { 2824 push( @output, ordered_str_cmp(shift @answerList) ); 2825 } 2826 @output; 2827 } 2828 2829 sub ordered_cs_str_cmp { # ordered, case sensitive, spaces ignored 2830 my $correctAnswer = shift @_; 2831 my @filters = ( 'remove_whitespace' ); 2832 my $type = 'ordered_cs_str_cmp'; 2833 STR_CMP( 'correct_ans' => $correctAnswer, 2834 'filters' => \@filters, 2835 'type' => $type 2836 ); 2837 } 2838 2839 sub ordered_cs_str_cmp_list { # alias for ordered_cs_str_cmp 2840 my @answerList = @_; 2841 my @output; 2842 while (@answerList) { 2843 push( @output, ordered_cs_str_cmp(shift @answerList) ); 2844 } 2845 @output; 2846 } 2847 2848 2849 ## LOW-LEVEL ROUTINE -- NOT NORMALLY FOR END USERS -- USE WITH CAUTION 2850 ## 2851 ## IN: a hashtable with the following entries (error-checking to be added later?): 2852 ## correctAnswer -- the correct answer, before filtering 2853 ## filters -- reference to an array containing the filters to be applied 2854 ## type -- a string containing the type of answer evaluator in use 2855 ## OUT: a reference to an answer evaluator subroutine 2856 sub STR_CMP { 2857 my %str_params = @_; 2858 #my $correctAnswer = str_filters( $str_params{'correct_ans'}, @{$str_params{'filters'}} ); 2859 my $answer_evaluator = new AnswerEvaluator; 2860 $answer_evaluator->{debug} = $str_params{debug}; 2861 $answer_evaluator->ans_hash( 2862 correct_ans => "$str_params{correct_ans}", 2863 type => $str_params{type}||'str_cmp', 2864 score => 0, 2865 2866 ); 2867 my %known_filters = ( 2868 'remove_whitespace' => \&remove_whitespace, 2869 'compress_whitespace' => \&compress_whitespace, 2870 'trim_whitespace' => \&trim_whitespace, 2871 'ignore_case' => \&ignore_case, 2872 'ignore_order' => \&ignore_order, 2873 ); 2874 2875 foreach my $filter ( @{$str_params{filters}} ) { 2876 #check that filter is known 2877 die "Unknown string filter |$filter|. Known filters are ". 2878 join(" ", keys %known_filters) . 2879 "(try checking the parameters to str_cmp() )" 2880 unless exists $known_filters{$filter}; 2881 # install related pre_filter 2882 $answer_evaluator->install_pre_filter( $known_filters{$filter} ); 2883 } 2884 $answer_evaluator->install_evaluator(sub { 2885 my $rh_ans = shift; 2886 $rh_ans->{_filter_name} = "Evaluator: Compare string answers with eq"; 2887 $rh_ans->{score} = ($rh_ans->{student_ans} eq $rh_ans->{correct_ans})?1:0 ; 2888 $rh_ans; 2889 }); 2890 $answer_evaluator->install_post_filter(sub { 2891 my $rh_hash = shift; 2892 $rh_hash->{_filter_name} = "clean up preview strings"; 2893 $rh_hash->{'preview_text_string'} = $rh_hash->{student_ans}; 2894 $rh_hash->{'preview_latex_string'} = "\\text{ ".$rh_hash->{student_ans}." }"; 2895 $rh_hash; 2896 }); 2897 return $answer_evaluator; 2898 } 2899 2900 # sub STR_CMP_old { 2901 # my %str_params = @_; 2902 # $str_params{'correct_ans'} = str_filters( $str_params{'correct_ans'}, @{$str_params{'filters'}} ); 2903 # my $answer_evaluator = sub { 2904 # my $in = shift @_; 2905 # $in = '' unless defined $in; 2906 # my $original_student_ans = $in; 2907 # $in = str_filters( $in, @{$str_params{'filters'}} ); 2908 # my $correctQ = ( $in eq $str_params{'correct_ans'} ) ? 1: 0; 2909 # my $ans_hash = new AnswerHash( 'score' => $correctQ, 2910 # 'correct_ans' => $str_params{'correctAnswer'}, 2911 # 'student_ans' => $in, 2912 # 'ans_message' => '', 2913 # 'type' => $str_params{'type'}, 2914 # 'preview_text_string' => $in, 2915 # 'preview_latex_string' => $in, 2916 # 'original_student_ans' => $original_student_ans 2917 # ); 2918 # return $ans_hash; 2919 # }; 2920 # return $answer_evaluator; 2921 # } 2922 2923 ########################################################################## 2924 ########################################################################## 2925 ## Miscellaneous answer evaluators 2926 2927 =head2 Miscellaneous Answer Evaluators (Checkboxes and Radio Buttons) 2928 2929 These evaluators do not fit any of the other categories. 2930 2931 checkbox_cmp( $correctAnswer ) 2932 2933 $correctAnswer -- a string containing the names of the correct boxes, 2934 e.g. "ACD". Note that this means that individual 2935 checkbox names can only be one character. Internally, 2936 this is largely the same as unordered_cs_str_cmp(). 2937 2938 radio_cmp( $correctAnswer ) 2939 2940 $correctAnswer -- a string containing the name of the correct radio 2941 button, e.g. "Choice1". This is case sensitive and 2942 whitespace sensitive, so the correct answer must match 2943 the name of the radio button exactly. 2944 2945 =cut 2946 2947 # added 6/14/2000 by David Etlinger 2948 # because of the conversion of the answer 2949 # string to an array, I thought it better not 2950 # to force STR_CMP() to work with this 2951 2952 #added 2/26/2003 by Mike Gage 2953 # handled the case where multiple answers are passed as an array reference 2954 # rather than as a \0 delimited string. 2955 sub checkbox_cmp { 2956 my $correctAnswer = shift @_; 2957 my %options = @_; 2958 assign_option_aliases( \%options, 2959 ); 2960 set_default_options( \%options, 2961 'debug' => 0, 2962 'type' => 'checkbox_cmp', 2963 ); 2964 my $answer_evaluator = new AnswerEvaluator( 2965 correct_ans => $correctAnswer, 2966 type => $options{type}, 2967 ); 2968 # pass along debug requests 2969 $answer_evaluator->{debug} = $options{debug}; 2970 2971 # join student answer array into a single string if necessary 2972 $answer_evaluator->install_pre_filter(sub { 2973 my $rh_ans = shift; 2974 $rh_ans->{_filter_name} = 'convert student_ans to string'; 2975 $rh_ans->{student_ans} = join("", @{$rh_ans->{student_ans}}) 2976 if ref($rh_ans->{student_ans}) =~/ARRAY/i; 2977 $rh_ans; 2978 }); 2979 # ignore order of check boxes 2980 $answer_evaluator->install_pre_filter(\&ignore_order); 2981 # compare as strings 2982 $answer_evaluator->install_evaluator(sub { 2983 my $rh_ans = shift; 2984 $rh_ans->{_filter_name} = 'compare strings generated by checked boxes'; 2985 $rh_ans->{score} = ($rh_ans->{student_ans} eq $rh_ans->{correct_ans}) ? 1 : 0; 2986 $rh_ans; 2987 }); 2988 # fix up preview displays 2989 $answer_evaluator->install_post_filter( sub { 2990 my $rh_ans = shift; 2991 $rh_ans->{_filter_name} = 'adjust preview strings'; 2992 $rh_ans->{type} = $options{type}; 2993 $rh_ans->{preview_text_string} = '\\text{'.$rh_ans->{student_ans}.'}', 2994 $rh_ans->{preview_latex_string} = '\\text{'.$rh_ans->{student_ans}.'}', 2995 $rh_ans; 2996 2997 2998 }); 2999 3000 # my $answer_evaluator = sub { 3001 # my $in = shift @_; 3002 # $in = '' unless defined $in; #in case no boxes checked 3003 # # multiple answers could come in two forms 3004 # # either a \0 delimited string or 3005 # # an array reference. We handle both. 3006 # if (ref($in) eq 'ARRAY') { 3007 # $in = join("",@{$in}); # convert array to single no-delimiter string 3008 # } else { 3009 # my @temp = split( "\0", $in ); #convert "\0"-delimited string to array... 3010 # $in = join( "", @temp ); #and then to a single no-delimiter string 3011 # } 3012 # my $original_student_ans = $in; #well, almost original 3013 # $in = str_filters( $in, 'ignore_order' ); 3014 # 3015 # my $correctQ = ($in eq $correctAnswer) ? 1: 0; 3016 # 3017 # my $ans_hash = new AnswerHash( 3018 # 'score' => $correctQ, 3019 # 'correct_ans' => "$correctAnswer", 3020 # 'student_ans' => $in, 3021 # 'ans_message' => "", 3022 # 'type' => "checkbox_cmp", 3023 # 'preview_text_string' => $in, 3024 # 'preview_latex_string' => $in, 3025 # 'original_student_ans' => $original_student_ans 3026 # ); 3027 # return $ans_hash; 3028 # 3029 # }; 3030 return $answer_evaluator; 3031 } 3032 # sub checkbox_cmp { 3033 # my $correctAnswer = shift @_; 3034 # $correctAnswer = str_filters( $correctAnswer, 'ignore_order' ); 3035 # 3036 # my $answer_evaluator = sub { 3037 # my $in = shift @_; 3038 # $in = '' unless defined $in; #in case no boxes checked 3039 # # multiple answers could come in two forms 3040 # # either a \0 delimited string or 3041 # # an array reference. We handle both. 3042 # if (ref($in) eq 'ARRAY') { 3043 # $in = join("",@{$in}); # convert array to single no-delimiter string 3044 # } else { 3045 # my @temp = split( "\0", $in ); #convert "\0"-delimited string to array... 3046 # $in = join( "", @temp ); #and then to a single no-delimiter string 3047 # } 3048 # my $original_student_ans = $in; #well, almost original 3049 # $in = str_filters( $in, 'ignore_order' ); 3050 # 3051 # my $correctQ = ($in eq $correctAnswer) ? 1: 0; 3052 # 3053 # my $ans_hash = new AnswerHash( 3054 # 'score' => $correctQ, 3055 # 'correct_ans' => "$correctAnswer", 3056 # 'student_ans' => $in, 3057 # 'ans_message' => "", 3058 # 'type' => "checkbox_cmp", 3059 # 'preview_text_string' => $in, 3060 # 'preview_latex_string' => $in, 3061 # 'original_student_ans' => $original_student_ans 3062 # ); 3063 # return $ans_hash; 3064 # 3065 # }; 3066 # return $answer_evaluator; 3067 # } 3068 3069 #added 6/28/2000 by David Etlinger 3070 #exactly the same as strict_str_cmp, 3071 #but more intuitive to the user 3072 3073 # check that answer is really a string and not an array 3074 # also use ordinary string compare 3075 sub radio_cmp { 3076 #strict_str_cmp( @_ ); 3077 my $response = shift; # there should be only one item. 3078 warn "Multiple choices -- this should not happen with radio buttons. Have 3079 you used checkboxes perhaps?" if ref($response); #triggered if an ARRAY is passed 3080 str_cmp($response); 3081 } 3082 3083 ########################################################################## 3084 ########################################################################## 3085 ## Text and e-mail routines 3086 3087 sub store_ans_at { 3088 my $answerStringRef = shift; 3089 my %options = @_; 3090 my $ans_eval= ''; 3091 if ( ref($answerStringRef) eq 'SCALAR' ) { 3092 $ans_eval= sub { 3093 my $text = shift; 3094 $text = '' unless defined($text); 3095 $$answerStringRef = $$answerStringRef . $text; 3096 my $ans_hash = new AnswerHash( 3097 'score' => 1, 3098 'correct_ans' => '', 3099 'student_ans' => $text, 3100 'ans_message' => '', 3101 'type' => 'store_ans_at', 3102 'original_student_ans' => $text, 3103 'preview_text_string' => '' 3104 ); 3105 3106 return $ans_hash; 3107 }; 3108 } 3109 else { 3110 die "Syntax error: \n The argument to store_ans_at() must be a pointer to a scalar.\n(e.g. store_ans_at(~~\$MSG) )\n\n"; 3111 } 3112 3113 return $ans_eval; 3114 } 3115 3116 #### subroutines used in producing a questionnaire 3117 #### these are at least good models for other answers of this type 3118 3119 # my $QUESTIONNAIRE_ANSWERS=''; # stores the answers until it is time to send them 3120 # this must be initialized before the answer evaluators are run 3121 # but that happens long after all of the text in the problem is 3122 # evaluated. 3123 # this is a utility script for cleaning up the answer output for display in 3124 #the answers. 3125 3126 sub DUMMY_ANSWER { 3127 my $num = shift; 3128 qq{<INPUT TYPE="HIDDEN" NAME="answer$num" VALUE="">} 3129 } 3130 3131 sub escapeHTML { 3132 my $string = shift; 3133 $string =~ s/\n/$BR/ge; 3134 $string; 3135 } 3136 3137 # these next three subroutines show how to modify the "store_ans_at()" answer 3138 # evaluator to add extra information before storing the info 3139 # They provide a good model for how to tweak answer evaluators in special cases. 3140 3141 sub anstext { 3142 my $num = shift; 3143 my $ans_eval_template = store_ans_at(\$QUESTIONNAIRE_ANSWERS); 3144 my $psvnNumber = PG_restricted_eval(q!$main::psvnNumber!); 3145 my $probNum = PG_restricted_eval(q!$main::probNum!); 3146 my $courseName = PG_restricted_eval(q!$main::courseName!); 3147 my $setNumber = PG_restricted_eval(q!$main::setNumber!); 3148 3149 my $ans_eval = sub { 3150 my $text = shift; 3151 $text = '' unless defined($text); 3152 my $new_text = "\n$setNumber$courseName$psvnNumber-Problem-$probNum-Question-$num:\n $text "; # modify entered text 3153 my $out = &$ans_eval_template($new_text); # standard evaluator 3154 #warn "$QUESTIONNAIRE_ANSWERS"; 3155 $out->{student_ans} = escapeHTML($text); # restore original entered text 3156 $out->{correct_ans} = "Question $num answered"; 3157 $out->{original_student_ans} = escapeHTML($text); 3158 $out; 3159 }; 3160 $ans_eval; 3161 } 3162 3163 3164 sub ansradio { 3165 my $num = shift; 3166 my $psvnNumber = PG_restricted_eval(q!$main::psvnNumber!); 3167 my $probNum = PG_restricted_eval(q!$main::probNum!); 3168 3169 my $ans_eval_template = store_ans_at(\$QUESTIONNAIRE_ANSWERS); 3170 my $ans_eval = sub { 3171 my $text = shift; 3172 $text = '' unless defined($text); 3173 my $new_text = "\n$psvnNumber-Problem-$probNum-RADIO-$num:\n $text "; # modify entered text 3174 my $out = $ans_eval_template->($new_text); # standard evaluator 3175 $out->{student_ans} =escapeHTML($text); # restore original entered text 3176 $out->{original_student_ans} = escapeHTML($text); 3177 $out; 3178 }; 3179 3180 $ans_eval; 3181 } 3182 3183 sub anstext_non_anonymous { 3184 ## this emails identifying information 3185 my $num = shift; 3186 my $psvnNumber = PG_restricted_eval(q!$main::psvnNumber!); 3187 my $probNum = PG_restricted_eval(q!$main::probNum!); 3188 my $studentLogin = PG_restricted_eval(q!$main::studentLogin!); 3189 my $studentID = PG_restricted_eval(q!$main::studentID!); 3190 my $studentName = PG_restricted_eval(q!$main::studentName!); 3191 3192 3193 my $ans_eval_template = store_ans_at(\$QUESTIONNAIRE_ANSWERS); 3194 my $ans_eval = sub { 3195 my $text = shift; 3196 $text = '' unless defined($text); 3197 my $new_text = "\n$psvnNumber-Problem-$probNum-Question-$num:\n$studentLogin $main::studentID $studentName\n$text "; # modify entered text 3198 my $out = &$ans_eval_template($new_text); # standard evaluator 3199 #warn "$QUESTIONNAIRE_ANSWERS"; 3200 $out->{student_ans} = escapeHTML($text); # restore original entered text 3201 $out->{correct_ans} = "Question $num answered"; 3202 $out->{original_student_ans} = escapeHTML($text); 3203 $out; 3204 }; 3205 $ans_eval; 3206 } 3207 3208 3209 # This is another example of how to modify an answer evaluator to obtain 3210 # the desired behavior in a special case. Here the object is to have 3211 # have the last answer trigger the send_mail_to subroutine which mails 3212 # all of the answers to the designated address. 3213 # (This address must be listed in PG_environment{'ALLOW_MAIL_TO'} or an error occurs.) 3214 3215 # Fix me?? why is the body hard wired to the string QUESTIONNAIRE_ANSWERS? 3216 3217 sub mail_answers_to { #accepts the last answer and mails off the result 3218 my $user_address = shift; 3219 my $ans_eval = sub { 3220 3221 # then mail out all of the answers, including this last one. 3222 3223 send_mail_to( $user_address, 3224 'subject' => "$main::courseName WeBWorK questionnaire", 3225 'body' => $QUESTIONNAIRE_ANSWERS, 3226 'ALLOW_MAIL_TO' => $rh_envir->{ALLOW_MAIL_TO} 3227 ); 3228 3229 my $ans_hash = new AnswerHash( 'score' => 1, 3230 'correct_ans' => '', 3231 'student_ans' => 'Answer recorded', 3232 'ans_message' => '', 3233 'type' => 'send_mail_to', 3234 ); 3235 3236 return $ans_hash; 3237 }; 3238 3239 return $ans_eval; 3240 } 3241 3242 sub save_answer_to_file { #accepts the last answer and mails off the result 3243 my $fileID = shift; 3244 my $ans_eval = new AnswerEvaluator; 3245 $ans_eval->install_evaluator( 3246 sub { 3247 my $rh_ans = shift; 3248 3249 unless ( defined( $rh_ans->{student_ans} ) ) { 3250 $rh_ans->throw_error("save_answers_to_file","{student_ans} field not defined"); 3251 return $rh_ans; 3252 } 3253 3254 my $error; 3255 my $string = ''; 3256 $string = qq![[<$main::studentLogin> $main::studentName /!. time() . qq!/]]\n!. 3257 $rh_ans->{student_ans}. qq!\n\n============================\n\n!; 3258 3259 if ($error = AnswerIO::saveAnswerToFile('preflight',$string) ) { 3260 $rh_ans->throw_error("save_answers_to_file","Error: $error"); 3261 } else { 3262 $rh_ans->{'student_ans'} = 'Answer saved'; 3263 $rh_ans->{'score'} = 1; 3264 } 3265 $rh_ans; 3266 } 3267 ); 3268 3269 return $ans_eval; 3270 } 3271 3272 sub mail_answers_to2 { #accepts the last answer and mails off the result 3273 my $user_address = shift; 3274 my $subject = shift; 3275 my $ra_allow_mail_to = shift; 3276 $subject = "$main::courseName WeBWorK questionnaire" unless defined $subject; 3277 send_mail_to($user_address, 3278 'subject' => $subject, 3279 'body' => $QUESTIONNAIRE_ANSWERS, 3280 'ALLOW_MAIL_TO' => $rh_envir->{ALLOW_MAIL_TO}, 3281 ); 3282 } 3283 3284 ########################################################################## 3285 ########################################################################## 3286 3287 3288 ########################################################################### 3289 ### THE FOLLOWING ARE LOCAL SUBROUTINES THAT ARE MEANT TO BE CALLED ONLY FROM THIS SCRIPT. 3290 3291 ## Internal routine that converts variables into the standard array format 3292 ## 3293 ## IN: one of the following: 3294 ## an undefined value (i.e., no variable was specified) 3295 ## a reference to an array of variable names -- [var1, var2] 3296 ## a number (the number of variables desired) -- 3 3297 ## one or more variable names -- (var1, var2) 3298 ## OUT: an array of variable names 3299 3300 sub get_var_array { 3301 my $in = shift @_; 3302 my @out; 3303 3304 if( not defined($in) ) { #if nothing defined, build default array and return 3305 @out = ( $functVarDefault ); 3306 return @out; 3307 } 3308 elsif( ref( $in ) eq 'ARRAY' ) { #if given an array ref, dereference and return 3309 return @{$in}; 3310 } 3311 elsif( $in =~ /^\d+/ ) { #if given a number, set up the array and return 3312 if( $in == 1 ) { 3313 $out[0] = 'x'; 3314 } 3315 elsif( $in == 2 ) { 3316 $out[0] = 'x'; 3317 $out[1] = 'y'; 3318 } 3319 elsif( $in == 3 ) { 3320 $out[0] = 'x'; 3321 $out[1] = 'y'; 3322 $out[2] = 'z'; 3323 } 3324 else { #default to the x_1, x_2, ... convention 3325 my ($i, $tag); 3326 for($i = 0; $i < $in; $i++) {$out[$i] = "${functVarDefault}_".($i+1)} 3327 } 3328 return @out; 3329 } 3330 else { #if given one or more names, return as an array 3331 unshift( @_, $in ); 3332 return @_; 3333 } 3334 } 3335 3336 ## Internal routine that converts limits into the standard array of arrays format 3337 ## Some of the cases are probably unneccessary, but better safe than sorry 3338 ## 3339 ## IN: one of the following: 3340 ## an undefined value (i.e., no limits were specified) 3341 ## a reference to an array of arrays of limits -- [[llim,ulim], [llim,ulim]] 3342 ## a reference to an array of limits -- [llim, ulim] 3343 ## an array of array references -- ([llim,ulim], [llim,ulim]) 3344 ## an array of limits -- (llim,ulim) 3345 ## OUT: an array of array references -- ([llim,ulim], [llim,ulim]) or ([llim,ulim]) 3346 3347 sub get_limits_array { 3348 my $in = shift @_; 3349 my @out; 3350 3351 if( not defined($in) ) { #if nothing defined, build default array and return 3352 @out = ( [$functLLimitDefault, $functULimitDefault] ); 3353 return @out; 3354 } 3355 elsif( ref($in) eq 'ARRAY' ) { #$in is either ref to array, or ref to array of refs 3356 my @deref = @{$in}; 3357 3358 if( ref( $in->[0] ) eq 'ARRAY' ) { #$in is a ref to an array of array refs 3359 return @deref; 3360 } 3361 else { #$in was just a ref to an array of numbers 3362 @out = ( $in ); 3363 return @out; 3364 } 3365 } 3366 else { #$in was an array of references or numbers 3367 unshift( @_, $in ); 3368 3369 if( ref($_[0]) eq 'ARRAY' ) { #$in was an array of references, so just return it 3370 return @_; 3371 } 3372 else { #$in was an array of numbers 3373 @out = ( \@_ ); 3374 return @out; 3375 } 3376 } 3377 } 3378 3379 #sub check_option_list { 3380 # my $size = scalar(@_); 3381 # if( ( $size % 2 ) != 0 ) { 3382 # warn "ERROR in answer evaluator generator:\n" . 3383 # "Usage: <CODE>str_cmp([\$ans1, \$ans2],%options)</CODE> 3384 # or <CODE> num_cmp([\$num1, \$num2], %options)</CODE><BR> 3385 # A list of inputs must be inclosed in square brackets <CODE>[\$ans1, \$ans2]</CODE>"; 3386 # } 3387 #} 3388 3389 # simple subroutine to display an error message when 3390 # function compares are called with invalid parameters 3391 sub function_invalid_params { 3392 my $correctEqn = shift @_; 3393 my $error_response = sub { 3394 my $PGanswerMessage = "Tell your professor that there is an error with the parameters " . 3395 "to the function answer evaluator"; 3396 return ( 0, $correctEqn, "", $PGanswerMessage ); 3397 }; 3398 return $error_response; 3399 } 3400 3401 sub clean_up_error_msg { 3402 my $msg = $_[0]; 3403 $msg =~ s/^\[[^\]]*\][^:]*://; 3404 $msg =~ s/Unquoted string//g; 3405 $msg =~ s/may\s+clash.*/does not make sense here/; 3406 $msg =~ s/\sat.*line [\d]*//g; 3407 $msg = 'Error: '. $msg; 3408 3409 return $msg; 3410 } 3411 3412 #formats the student and correct answer as specified 3413 #format must be of a form suitable for sprintf (e.g. '%0.5g'), 3414 #with the exception that a '#' at the end of the string 3415 #will cause trailing zeros in the decimal part to be removed 3416 sub prfmt { 3417 my($number,$format) = @_; # attention, the order of format and number are reversed 3418 my $out; 3419 if ($format) { 3420 warn "Incorrect format used: $format. <BR> Format should look something like %4.5g<BR>" 3421 unless $format =~ /^\s*%\d*\.?\d*\w#?\s*$/; 3422 3423 if( $format =~ s/#\s*$// ) { # remove trailing zeros in the decimal 3424 $out = sprintf( $format, $number ); 3425 $out =~ s/(\.\d*?)0+$/$1/; 3426 $out =~ s/\.$//; # in case all decimal digits were zero, remove the decimal 3427 $out =~ s/e/E/g; # only use capital E's for exponents. Little e is for 2.71828... 3428 } elsif (is_a_number($number) ){ 3429 $out = sprintf( $format, $number ); 3430 $out =~ s/e/E/g; # only use capital E's for exponents. Little e is for 2.71828... 3431 } else { # number is probably a string representing an arithmetic expression 3432 $out = $number; 3433 } 3434 3435 } else { 3436 if (is_a_number($number)) {# only use capital E's for exponents. Little e is for 2.71828... 3437 $out = $number; 3438 $out =~ s/e/E/g; 3439 } else { # number is probably a string representing an arithmetic expression 3440 $out = $number; 3441 } 3442 } 3443 return $out; 3444 } 3445 ######################################################################### 3446 # Filters for answer evaluators 3447 ######################################################################### 3448 3449 =head2 Filters 3450 3451 =pod 3452 3453 A filter is a short subroutine with the following structure. It accepts an 3454 AnswerHash, followed by a hash of options. It returns an AnswerHash 3455 3456 $ans_hash = filter($ans_hash, %options); 3457 3458 See the AnswerHash.pm file for a list of entries which can be expected to be found 3459 in an AnswerHash, such as 'student_ans', 'score' and so forth. Other entries 3460 may be present for specialized answer evaluators. 3461 3462 The hope is that a well designed set of filters can easily be combined to form 3463 a new answer_evaluator and that this method will produce answer evaluators which are 3464 are more robust than the method of copying existing answer evaluators and modifying them. 3465 3466 Here is an outline of how a filter is constructed: 3467 3468 sub filter{ 3469 my $rh_ans = shift; 3470 my %options = @_; 3471 assign_option_aliases(\%options, 3472 'alias1' => 'option5' 3473 'alias2' => 'option7' 3474 ); 3475 set_default_options(\%options, 3476 '_filter_name' => 'filter', 3477 'option5' => .0001, 3478 'option7' => 'ascii', 3479 'allow_unknown_options => 0, 3480 } 3481 .... body code of filter ....... 3482 if ($error) { 3483 $rh_ans->throw_error("FILTER_ERROR", "Something went wrong"); 3484 # see AnswerHash.pm for details on using the throw_error method. 3485 3486 $rh_ans; #reference to an AnswerHash object is returned. 3487 } 3488 3489 =cut 3490 3491 =head4 compare_numbers 3492 3493 3494 =cut 3495 3496 3497 sub compare_numbers { 3498 my ($rh_ans, %options) = @_; 3499 my ($inVal,$PG_eval_errors,$PG_full_error_report) = PG_answer_eval($rh_ans->{student_ans}); 3500 if ($PG_eval_errors) { 3501 $rh_ans->throw_error('EVAL','There is a syntax error in your answer'); 3502 $rh_ans->{ans_message} = clean_up_error_msg($PG_eval_errors); 3503 # return $rh_ans; 3504 } else { 3505 $rh_ans->{student_ans} = prfmt($inVal,$options{format}); 3506 } 3507 3508 my $permitted_error; 3509 3510 if ($rh_ans->{tolType} eq 'absolute') { 3511 $permitted_error = $rh_ans->{tolerance}; 3512 } 3513 elsif ( abs($rh_ans->{correct_ans}) <= $options{zeroLevel}) { 3514 $permitted_error = $options{zeroLevelTol}; ## want $tol to be non zero 3515 } 3516 else { 3517 $permitted_error = abs($rh_ans->{tolerance}*$rh_ans->{correct_ans}); 3518 } 3519 3520 my $is_a_number = is_a_number($inVal); 3521 $rh_ans->{score} = 1 if ( ($is_a_number) and 3522 (abs( $inVal - $rh_ans->{correct_ans} ) <= $permitted_error) ); 3523 if (not $is_a_number) { 3524 $rh_ans->{error_message} = "$rh_ans->{error_message}". 'Your answer does not evaluate to a number '; 3525 } 3526 3527 $rh_ans; 3528 } 3529 3530 =head4 std_num_filter 3531 3532 std_num_filter($rh_ans, %options) 3533 returns $rh_ans 3534 3535 Replaces some constants using math_constants, then evaluates a perl expression. 3536 3537 3538 =cut 3539 3540 sub std_num_filter { 3541 my $rh_ans = shift; 3542 my %options = @_; 3543 my $in = $rh_ans->input(); 3544 $in = math_constants($in); 3545 $rh_ans->{type} = 'std_number'; 3546 my ($inVal,$PG_eval_errors,$PG_full_error_report); 3547 if ($in =~ /\S/) { 3548 ($inVal,$PG_eval_errors,$PG_full_error_report) = PG_answer_eval($in); 3549 } else { 3550 $PG_eval_errors = ''; 3551 } 3552 3553 if ($PG_eval_errors) { ##error message from eval or above 3554 $rh_ans->{ans_message} = 'There is a syntax error in your answer'; 3555 $rh_ans->{student_ans} = 3556 clean_up_error_msg($PG_eval_errors); 3557 } else { 3558 $rh_ans->{student_ans} = $inVal; 3559 } 3560 $rh_ans; 3561 } 3562 3563 =head std_num_array_filter 3564 3565 std_num_array_filter($rh_ans, %options) 3566 returns $rh_ans 3567 3568 Assumes the {student_ans} field is a numerical array, and applies BOTH check_syntax and std_num_filter 3569 to each element of the array. Does it's best to generate sensible error messages for syntax errors. 3570 A typical error message displayed in {studnet_ans} might be ( 56, error message, -4). 3571 3572 =cut 3573 3574 sub std_num_array_filter { 3575 my $rh_ans= shift; 3576 my %options = @_; 3577 set_default_options( \%options, 3578 '_filter_name' => 'std_num_array_filter', 3579 ); 3580 my @in = @{$rh_ans->{student_ans}}; 3581 my $temp_hash = new AnswerHash; 3582 my @out=(); 3583 my $PGanswerMessage = ''; 3584 foreach my $item (@in) { # evaluate each number in the vector 3585 $temp_hash->input($item); 3586 $temp_hash = check_syntax($temp_hash); 3587 if (defined($temp_hash->{error_flag}) and $temp_hash->{error_flag} eq 'SYNTAX') { 3588 $PGanswerMessage .= $temp_hash->{ans_message}; 3589 $temp_hash->{ans_message} = undef; 3590 } else { 3591 #continue processing 3592 $temp_hash = std_num_filter($temp_hash); 3593 if (defined($temp_hash->{ans_message}) and $temp_hash->{ans_message} ) { 3594 $PGanswerMessage .= $temp_hash->{ans_message}; 3595 $temp_hash->{ans_message} = undef; 3596 } 3597 } 3598 push(@out, $temp_hash->input()); 3599 3600 } 3601 if ($PGanswerMessage) { 3602 $rh_ans->input( "( " . join(", ", @out ) . " )" ); 3603 $rh_ans->throw_error('SYNTAX', 'There is a syntax error in your answer.'); 3604 } else { 3605 $rh_ans->input( [@out] ); 3606 } 3607 $rh_ans; 3608 } 3609 3610 =head4 function_from_string2 3611 3612 3613 3614 =cut 3615 3616 sub function_from_string2 { 3617 my $rh_ans = shift; 3618 my %options = @_; 3619 assign_option_aliases(\%options, 3620 'vars' => 'ra_vars', 3621 'var' => 'ra_vars', 3622 'store_in' => 'stdout', 3623 ); 3624 set_default_options( \%options, 3625 'stdin' => 'student_ans', 3626 'stdout' => 'rf_student_ans', 3627 'ra_vars' => [qw( x y )], 3628 'debug' => 0, 3629 '_filter_name' => 'function_from_string2', 3630 ); 3631 # initialize 3632 $rh_ans->{_filter_name} = $options{_filter_name}; 3633 3634 my $eqn = $rh_ans->{ $options{stdin} }; 3635 my @VARS = @{ $options{ 'ra_vars'} }; 3636 #warn "VARS = ", join("<>", @VARS) if defined($options{debug}) and $options{debug} ==1; 3637 my $originalEqn = $eqn; 3638 $eqn = &math_constants($eqn); 3639 for( my $i = 0; $i < @VARS; $i++ ) { 3640 # This next line is a hack required for 5.6.0 -- it doesn't appear to be needed in 5.6.1 3641 my ($temp,$er1,$er2) = PG_restricted_eval('"'. $VARS[$i] . '"'); 3642 #$eqn =~ s/\b$VARS[$i]\b/\$VARS[$i]/g; 3643 $eqn =~ s/\b$temp\b/\$VARS[$i]/g; 3644 3645 } 3646 #warn "equation evaluated = $eqn",$rh_ans->pretty_print(), "<br>\noptions<br>\n", 3647 # pretty_print(\%options) 3648 # if defined($options{debug}) and $options{debug} ==1; 3649 my ($function_sub,$PG_eval_errors, $PG_full_errors) = PG_answer_eval( q! 3650 sub { 3651 my @VARS = @_; 3652 my $input_str = ''; 3653 for( my $i=0; $i<@VARS; $i++ ) { 3654 $input_str .= "\$VARS[$i] = $VARS[$i]; "; 3655 } 3656 my $PGanswerMessage; 3657 $input_str .= '! . $eqn . q!'; # need the single quotes to keep the contents of $eqn from being 3658 # evaluated when it is assigned to $input_str; 3659 my ($out, $PG_eval_errors, $PG_full_errors) = PG_answer_eval($input_str); #Finally evaluated 3660 3661 if ( defined($PG_eval_errors) and $PG_eval_errors =~ /\S/ ) { 3662 $PGanswerMessage = clean_up_error_msg($PG_eval_errors); 3663 # This message seemed too verbose, but it does give extra information, we'll see if it is needed. 3664 # "<br> There was an error in evaluating your function <br> 3665 # !. $originalEqn . q! <br> 3666 # at ( " . join(', ', @VARS) . " ) <br> 3667 # $PG_eval_errors 3668 # "; # this message appears in the answer section which is not process by Latex2HTML so it must 3669 # # be in HTML. That is why $BR is NOT used. 3670 3671 } 3672 (wantarray) ? ($out, $PGanswerMessage): $out; # PGanswerMessage may be undefined. 3673 }; 3674 !); 3675 3676 if (defined($PG_eval_errors) and $PG_eval_errors =~/\S/ ) { 3677 $PG_eval_errors = clean_up_error_msg($PG_eval_errors); 3678 3679 my $PGanswerMessage = "There was an error in converting the expression 3680 $BR $originalEqn $BR into a function. 3681 $BR $PG_eval_errors."; 3682 $rh_ans->{rf_student_ans} = $function_sub; 3683 $rh_ans->{ans_message} = $PGanswerMessage; 3684 $rh_ans->{error_message} = $PGanswerMessage; 3685 $rh_ans->{error_flag} = 1; 3686 # we couldn't compile the equation, we'll return an error message. 3687 } else { 3688 # if (defined($options{stdout} )) { 3689 # $rh_ans ->{$options{stdout}} = $function_sub; 3690 # } else { 3691 # $rh_ans->{rf_student_ans} = $function_sub; 3692 # } 3693 $rh_ans ->{$options{stdout}} = $function_sub; 3694 } 3695 3696 $rh_ans; 3697 } 3698 3699 =head4 is_zero_array 3700 3701 3702 =cut 3703 3704 3705 sub is_zero_array { 3706 my $rh_ans = shift; 3707 my %options = @_; 3708 set_default_options( \%options, 3709 '_filter_name' => 'is_zero_array', 3710 'tolerance' => 0.000001, 3711 'stdin' => 'ra_differences', 3712 'stdout' => 'score', 3713 ); 3714 #intialize 3715 $rh_ans->{_filter_name} = $options{_filter_name}; 3716 3717 my $array = $rh_ans -> {$options{stdin}}; # default ra_differences 3718 my $num = @$array; 3719 my $i; 3720 my $max = 0; my $mm; 3721 for ($i=0; $i< $num; $i++) { 3722 $mm = $array->[$i] ; 3723 if (not is_a_number($mm) ) { 3724 $max = $mm; # break out if one of the elements is not a number 3725 last; 3726 } 3727 $max = abs($mm) if abs($mm) > $max; 3728 } 3729 if (not is_a_number($max)) { 3730 $rh_ans->{score} = 0; 3731 my $error = "WeBWorK was unable evaluate your function. Please check that your 3732 expression doesn't take roots of negative numbers, or divide by zero."; 3733 $rh_ans->throw_error('EVAL',$error); 3734 } else { 3735 $rh_ans->{$options{stdout}} = ($max < $options{tolerance} ) ? 1: 0; # set 'score' to 1 if the array is close to 0; 3736 } 3737 $rh_ans; 3738 } 3739 3740 =head4 best_approx_parameters 3741 3742 best_approx_parameters($rh_ans,%options); #requires the following fields in $rh_ans 3743 {rf_student_ans} # reference to the test answer 3744 {rf_correct_ans} # reference to the comparison answer 3745 {evaluation_points}, # an array of row vectors indicating the points 3746 # to evaluate when comparing the functions 3747 3748 %options # debug => 1 gives more error answers 3749 # param_vars => [''] additional parameters used to adapt to function 3750 ) 3751 3752 3753 The parameters for the comparison function which best approximates the test_function are stored 3754 in the field {ra_parameters}. 3755 3756 3757 The last $dim_of_parms_space variables are assumed to be parameters, and it is also 3758 assumed that the function \&comparison_fun 3759 depends linearly on these variables. This function finds the values for these parameters which minimizes the 3760 Euclidean distance (L2 distance) between the test function and the comparison function and the test points specified 3761 by the array reference \@rows_of_test_points. This is assumed to be an array of arrays, with the inner arrays 3762 determining a test point. 3763 3764 The comparison function should have $dim_of_params_space more input variables than the test function. 3765 3766 3767 3768 3769 3770 =cut 3771 3772 # Used internally: 3773 # 3774 # &$determine_param_coeff( $rf_comparison_function # a reference to the correct answer function 3775 # $ra_variables # an array of the active input variables to the functions 3776 # $dim_of_params_space # indicates the number of parameters upon which the 3777 # # the comparison function depends linearly. These are assumed to 3778 # # be the last group of inputs to the comparison function. 3779 # 3780 # %options # $options{debug} gives more error messages 3781 # 3782 # # A typical function might look like 3783 # # f(x,y,z,a,b) = x^2+a*cos(xz) + b*sin(x) with a parameter 3784 # # space of dimension 2 and a variable space of dimension 3. 3785 # ) 3786 # # returns a list of coefficients 3787 3788 sub best_approx_parameters { 3789 my $rh_ans = shift; 3790 my %options = @_; 3791 set_default_options(\%options, 3792 '_filter_name' => 'best_approx_paramters', 3793 'allow_unknown_options' => 1, 3794 ); 3795 my $errors = undef; 3796 # This subroutine for the determining the coefficents of the parameters at a given point 3797 # is pretty specialized, so it is included here as a sub-subroutine. 3798 my $determine_param_coeffs = sub { 3799 my ($rf_fun, $ra_variables, $dim_of_params_space, %options) =@_; 3800 my @zero_params=(); 3801 for(my $i=1;$i<=$dim_of_params_space;$i++){push(@zero_params,0); } 3802 my @vars = @$ra_variables; 3803 my @coeff = (); 3804 my @inputs = (@vars,@zero_params); 3805 my ($f0, $f1, $err); 3806 ($f0, $err) = &{$rf_fun}(@inputs); 3807 if (defined($err) ) { 3808 $errors .= "$err "; 3809 } else { 3810 for (my $i=@vars;$i<@inputs;$i++) { 3811 $inputs[$i]=1; # set one parameter to 1; 3812 my($f1,$err) = &$rf_fun(@inputs); 3813 if (defined($err) ) { 3814 $errors .= " $err "; 3815 } else { 3816 push(@coeff, $f1-$f0); 3817 } 3818 $inputs[$i]=0; # set it back 3819 } 3820 } 3821 (\@coeff, $errors); 3822 }; 3823 my $rf_fun = $rh_ans->{rf_student_ans}; 3824 my $rf_correct_fun = $rh_ans->{rf_correct_ans}; 3825 my $ra_vars_matrix = $rh_ans->{evaluation_points}; 3826 my $dim_of_param_space = @{$options{param_vars}}; 3827 # Short cut. Bail if there are no param_vars 3828 unless ($dim_of_param_space >0) { 3829 $rh_ans ->{ra_parameters} = []; 3830 return $rh_ans; 3831 } 3832 # inputs are row arrays in this case. 3833 my @zero_params=(); 3834 3835 for(my $i=1;$i<=$dim_of_param_space;$i++){push(@zero_params,0); } 3836 my @rows_of_vars = @$ra_vars_matrix; 3837 warn "input rows ", pretty_print(\@rows_of_vars) if defined($options{debug}) and $options{debug}; 3838 my $rows = @rows_of_vars; 3839 my $matrix =new Matrix($rows,$dim_of_param_space); 3840 my $rhs_vec = new Matrix($rows, 1); 3841 my $row_num = 1; 3842 my ($ra_coeff,$val2, $val1, $err1,$err2,@inputs,@vars); 3843 my $number_of_data_points = $dim_of_param_space +2; 3844 while (@rows_of_vars and $row_num <= $number_of_data_points) { 3845 # get one set of data points from the test function; 3846 @vars = @{ shift(@rows_of_vars) }; 3847 ($val2, $err1) = &{$rf_fun}(@vars); 3848 $errors .= " $err1 " if defined($err1); 3849 @inputs = (@vars,@zero_params); 3850 ($val1, $err2) = &{$rf_correct_fun}(@inputs); 3851 $errors .= " $err2 " if defined($err2); 3852 3853 unless (defined($err1) or defined($err2) ) { 3854 $rhs_vec->assign($row_num,1, $val2-$val1 ); 3855 3856 # warn "rhs data val1=$val1, val2=$val2, val2 - val1 = ", $val2 - $val1 if $options{debug}; 3857 # warn "vars ", join(" | ", @vars) if $options{debug}; 3858 3859 ($ra_coeff, $err1) = &{$determine_param_coeffs}($rf_correct_fun,\@vars,$dim_of_param_space,%options); 3860 if (defined($err1) ) { 3861 $errors .= " $err1 "; 3862 } else { 3863 my @coeff = @$ra_coeff; 3864 my $col_num=1; 3865 while(@coeff) { 3866 $matrix->assign($row_num,$col_num, shift(@coeff) ); 3867 $col_num++; 3868 } 3869 } 3870 } 3871 $row_num++; 3872 last if $errors; # break if there are any errors. 3873 # This cuts down on the size of error messages. 3874 # However it impossible to check for equivalence at 95% of points 3875 # which might be useful for functions that are not defined at some points. 3876 } 3877 warn "<br> best_approx_parameters: matrix1 <br> ", " $matrix " if $options{debug}; 3878 warn "<br> best_approx_parameters: vector <br> ", " $rhs_vec " if $options{debug}; 3879 3880 # we have Matrix * parameter = data_vec + perpendicular vector 3881 # where the matrix has column vectors defining the span of the parameter space 3882 # multiply both sides by Matrix_transpose and solve for the parameters 3883 # This is exactly what the method proj_coeff method does. 3884 my @array; 3885 if (defined($errors) ) { 3886 @array = (); # new Matrix($dim_of_param_space,1); 3887 } else { 3888 @array = $matrix->proj_coeff($rhs_vec)->list(); 3889 } 3890 # check size (hack) 3891 my $max = 0; 3892 foreach my $val (@array ) { 3893 $max = abs($val) if $max < abs($val); 3894 if (not is_a_number($val) ) { 3895 $max = "NaN: $val"; 3896 last; 3897 } 3898 } 3899 if ($max =~/NaN/) { 3900 $errors .= "WeBWorK was unable evaluate your function. Please check that your 3901 expression doesn't take roots of negative numbers, or divide by zero."; 3902 } elsif ($max > $options{maxConstantOfIntegration} ) { 3903 $errors .= "At least one of the adapting parameters 3904 (perhaps the constant of integration) is too large: $max, 3905 ( the maximum allowed is $options{maxConstantOfIntegration} )"; 3906 } 3907 3908 $rh_ans->{ra_parameters} = \@array; 3909 $rh_ans->throw_error('EVAL', $errors) if defined($errors); 3910 $rh_ans; 3911 } 3912 3913 =head4 calculate_difference_vector 3914 3915 calculate_difference_vector( $ans_hash, %options); 3916 3917 {rf_student_ans}, # a reference to the test function 3918 {rf_correct_ans}, # a reference to the correct answer function 3919 {evaluation_points}, # an array of row vectors indicating the points 3920 # to evaluate when comparing the functions 3921 {ra_parameters} # these are the (optional) additional inputs to 3922 # the comparison function which adapt it properly 3923 # to the problem at hand. 3924 3925 %options # mode => 'rel' specifies that each element in the 3926 # difference matrix is divided by the correct answer. 3927 # unless the correct answer is nearly 0. 3928 ) 3929 3930 =cut 3931 3932 sub calculate_difference_vector { 3933 my $rh_ans = shift; 3934 my %options = @_; 3935 assign_option_aliases( \%options, 3936 ); 3937 set_default_options( \%options, 3938 allow_unknown_options => 1, 3939 stdin1 => 'rf_student_ans', 3940 stdin2 => 'rf_correct_ans', 3941 stdout => 'ra_differences', 3942 debug => 0, 3943 tolType => 'absolute', 3944 error_msg_flag => 1, 3945 ); 3946 # initialize 3947 $rh_ans->{_filter_name} = 'calculate_difference_vector'; 3948 my $rf_fun = $rh_ans -> {$options{stdin1}}; # rf_student_ans by default 3949 my $rf_correct_fun = $rh_ans -> {$options{stdin2}}; # rf_correct_ans by default 3950 my $ra_parameters = $rh_ans -> {ra_parameters}; 3951 my @evaluation_points = @{$rh_ans->{evaluation_points} }; 3952 my @parameters = (); 3953 @parameters = @$ra_parameters if defined($ra_parameters) and ref($ra_parameters) eq 'ARRAY'; 3954 my $errors = undef; 3955 my @zero_params = (); 3956 for (my $i=1;$i<=@{$ra_parameters};$i++) { 3957 push(@zero_params,0); 3958 } 3959 my @differences = (); 3960 my @student_values; 3961 my @adjusted_student_values; 3962 my @instructorVals; 3963 my ($diff,$instructorVal); 3964 # calculate the vector of differences between the test function and the comparison function. 3965 while (@evaluation_points) { 3966 my ($err1, $err2,$err3); 3967 my @vars = @{ shift(@evaluation_points) }; 3968 my @inputs = (@vars, @parameters); 3969 my ($inVal, $correctVal); 3970 ($inVal, $err1) = &{$rf_fun}(@vars); 3971 $errors .= " $err1 " if defined($err1); 3972 $errors .= " Error detected evaluating student input at (".join(' , ',@vars) ." ) " if defined($options{debug}) and $options{debug}==1 and defined($err1); 3973 ($correctVal, $err2) =&{$rf_correct_fun}(@inputs); 3974 $errors .= " There is an error in WeBWorK's answer to this problem, please alert your instructor.<br> $err2 " if defined($err2); 3975 $errors .= " Error detected evaluating correct adapted answer at (".join(' , ',@inputs) ." ) " if defined($options{debug}) and $options{debug}=1 and defined($err2); 3976 ($instructorVal,$err3)= &$rf_correct_fun(@vars, @zero_params); 3977 $errors .= " There is an error in WeBWorK's answer to this problem, please alert your instructor.<br> $err3 " if defined($err3); 3978 $errors .= " Error detected evaluating instructor answer at (".join(' , ',@vars, @zero_params) ." ) " if defined($options{debug}) and $options{debug}=1 and defined($err3); 3979 unless (defined($err1) or defined($err2) or defined($err3) ) { 3980 $diff = ( $inVal - ($correctVal -$instructorVal ) ) - $instructorVal; #prevents entering too high a number? 3981 #warn "taking the difference of ", $inVal, " and ", $correctVal, " is ", $diff; 3982 if ( $options{tolType} eq 'relative' ) { #relative tolerance 3983 #warn "diff = $diff"; 3984 #$diff = ( $inVal - ($correctVal-$instructorVal ) )/abs($instructorVal) -1 if abs($instructorVal) > $options{zeroLevel}; 3985 $diff = ( $inVal - ($correctVal-$instructorVal ) )/$instructorVal -1 if abs($instructorVal) > $options{zeroLevel}; 3986 #$diff = ( $inVal - ($correctVal-$instructorVal- $instructorVal ) )/abs($instructorVal) if abs($instructorVal) > $options{zeroLevel}; 3987 #warn "diff = $diff, ", abs( &$rf_correct_fun(@inputs) ) , "-- $correctVal"; 3988 } 3989 } 3990 last if $errors; # break if there are any errors. 3991 # This cuts down on the size of error messages. 3992 # However it impossible to check for equivalence at 95% of points 3993 # which might be useful for functions that are not defined at some points. 3994 push(@student_values,$inVal); 3995 push(@adjusted_student_values,( $inVal - ($correctVal -$instructorVal) ) ); 3996 push(@differences, $diff); 3997 push(@instructorVals,$instructorVal); 3998 } 3999 if (( not defined($errors) ) or $errors eq '' or $options{error_msg_flag} ) { 4000 $rh_ans ->{$options{stdout}} = \@differences; 4001 $rh_ans ->{ra_student_values} = \@student_values; 4002 $rh_ans ->{ra_adjusted_student_values} = \@adjusted_student_values; 4003 $rh_ans->{ra_instructor_values}=\@instructorVals; 4004 $rh_ans->throw_error('EVAL', $errors) if defined($errors); 4005 } else { 4006 4007 } # no output if error_msg_flag is set to 0. 4008 4009 $rh_ans; 4010 } 4011 4012 =head4 fix_answer_for_display 4013 4014 =cut 4015 4016 sub fix_answers_for_display { 4017 my ($rh_ans, %options) = @_; 4018 if ( $rh_ans->{answerIsString} ==1) { 4019 $rh_ans = evaluatesToNumber ($rh_ans, %options); 4020 } 4021 if (defined ($rh_ans->{student_units})) { 4022 $rh_ans->{student_ans} = $rh_ans->{student_ans}. ' '. $rh_ans->{student_units}; 4023 4024 } 4025 if ( $rh_ans->catch_error('UNITS') ) { # create preview latex string for expressions even if the units are incorrect 4026 my $rh_temp = new AnswerHash; 4027 $rh_temp->{student_ans} = $rh_ans->{student_ans}; 4028 $rh_temp = check_syntax($rh_temp); 4029 $rh_ans->{preview_latex_string} = $rh_temp->{preview_latex_string}; 4030 } 4031 $rh_ans->{correct_ans} = $rh_ans->{original_correct_ans}; 4032 4033 $rh_ans; 4034 } 4035 4036 =head4 evaluatesToNumber 4037 4038 =cut 4039 4040 sub evaluatesToNumber { 4041 my ($rh_ans, %options) = @_; 4042 if (is_a_numeric_expression($rh_ans->{student_ans})) { 4043 my ($inVal,$PG_eval_errors,$PG_full_error_report) = PG_answer_eval($rh_ans->{student_ans}); 4044 if ($PG_eval_errors) { # this if statement should never be run 4045 # change nothing 4046 } else { 4047 # change this 4048 $rh_ans->{student_ans} = prfmt($inVal,$options{format}); 4049 } 4050 } 4051 $rh_ans; 4052 } 4053 4054 =head4 is_numeric_expression 4055 4056 =cut 4057 4058 sub is_a_numeric_expression { 4059 my $testString = shift; 4060 my $is_a_numeric_expression = 0; 4061 my ($inVal,$PG_eval_errors,$PG_full_error_report) = PG_answer_eval($testString); 4062 if ($PG_eval_errors) { 4063 $is_a_numeric_expression = 0; 4064 } else { 4065 $is_a_numeric_expression = 1; 4066 } 4067 $is_a_numeric_expression; 4068 } 4069 4070 =head4 is_a_number 4071 4072 =cut 4073 4074 sub is_a_number { 4075 my ($num,%options) = @_; 4076 my $process_ans_hash = ( ref( $num ) eq 'AnswerHash' ) ? 1 : 0 ; 4077 my ($rh_ans); 4078 if ($process_ans_hash) { 4079 $rh_ans = $num; 4080 $num = $rh_ans->{student_ans}; 4081 } 4082 4083 my $is_a_number = 0; 4084 return $is_a_number unless defined($num); 4085 $num =~ s/^\s*//; ## remove initial spaces 4086 $num =~ s/\s*$//; ## remove trailing spaces 4087 4088 ## the following is copied from the online perl manual 4089 if ($num =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/){ 4090 $is_a_number = 1; 4091 } 4092 4093 if ($process_ans_hash) { 4094 if ($is_a_number == 1 ) { 4095 $rh_ans->{student_ans}=$num; 4096 return $rh_ans; 4097 } else { 4098 $rh_ans->{student_ans} = "Incorrect number format: You must enter a number, e.g. -6, 5.3, or 6.12E-3"; 4099 $rh_ans->throw_error('NUMBER', 'You must enter a number, e.g. -6, 5.3, or 6.12E-3'); 4100 return $rh_ans; 4101 } 4102 } else { 4103 return $is_a_number; 4104 } 4105 } 4106 4107 =head4 is_a_fraction 4108 4109 =cut 4110 4111 sub is_a_fraction { 4112 my ($num,%options) = @_; 4113 my $process_ans_hash = ( ref( $num ) eq 'AnswerHash' ) ? 1 : 0 ; 4114 my ($rh_ans); 4115 if ($process_ans_hash) { 4116 $rh_ans = $num; 4117 $num = $rh_ans->{student_ans}; 4118 } 4119 4120 my $is_a_fraction = 0; 4121 return $is_a_fraction unless defined($num); 4122 $num =~ s/^\s*//; ## remove initial spaces 4123 $num =~ s/\s*$//; ## remove trailing spaces 4124 4125 if ($num =~ /^\s*\-?\s*[\/\d\.Ee\s]*$/) { 4126 $is_a_fraction = 1; 4127 } 4128 4129 if ($process_ans_hash) { 4130 if ($is_a_fraction == 1 ) { 4131 $rh_ans->{student_ans}=$num; 4132 return $rh_ans; 4133 } else { 4134 $rh_ans->{student_ans} = "Not a number of fraction: You must enter a number or fraction, e.g. -6 or 7/13"; 4135 $rh_ans->throw_error('NUMBER', 'You must enter a number, e.g. -6, 5.3, or 6.12E-3'); 4136 return $rh_ans; 4137 } 4138 4139 } else { 4140 return $is_a_fraction; 4141 } 4142 } 4143 4144 =head4 phase_pi 4145 I often discovered that the answers I was getting, when using the arctan function would be off by phases of 4146 pi, which for the tangent function, were equivalent values. This method allows for this. 4147 =cut 4148 4149 sub phase_pi { 4150 my ($num,%options) = @_; 4151 my $process_ans_hash = ( ref( $num ) eq 'AnswerHash' ) ? 1 : 0 ; 4152 my ($rh_ans); 4153 if ($process_ans_hash) { 4154 $rh_ans = $num; 4155 $num = $rh_ans->{correct_ans}; 4156 } 4157 while( ($rh_ans->{correct_ans}) > 3.14159265358979/2 ){ 4158 $rh_ans->{correct_ans} -= 3.14159265358979; 4159 } 4160 while( ($rh_ans->{correct_ans}) <= -3.14159265358979/2 ){ 4161 $rh_ans->{correct_ans} += 3.14159265358979; 4162 } 4163 $rh_ans; 4164 } 4165 4166 =head4 is_an_arithemetic_expression 4167 4168 =cut 4169 4170 sub is_an_arithmetic_expression { 4171 my ($num,%options) = @_; 4172 my $process_ans_hash = ( ref( $num ) eq 'AnswerHash' ) ? 1 : 0 ; 4173 my ($rh_ans); 4174 if ($process_ans_hash) { 4175 $rh_ans = $num; 4176 $num = $rh_ans->{student_ans}; 4177 } 4178 4179 my $is_an_arithmetic_expression = 0; 4180 return $is_an_arithmetic_expression unless defined($num); 4181 $num =~ s/^\s*//; ## remove initial spaces 4182 $num =~ s/\s*$//; ## remove trailing spaces 4183 4184 if ($num =~ /^[+\-*\/\^\(\)\[\]\{\}\s\d\.Ee]*$/) { 4185 $is_an_arithmetic_expression = 1; 4186 } 4187 4188 if ($process_ans_hash) { 4189 if ($is_an_arithmetic_expression == 1 ) { 4190 $rh_ans->{student_ans}=$num; 4191 return $rh_ans; 4192 } else { 4193 4194 $rh_ans->{student_ans} = "Not an arithmetic expression: You must enter an arithmetic expression, e.g. -6 or (2.3*4+5/3)^2"; 4195 $rh_ans->throw_error('NUMBER', 'You must enter an arithmetic expression, e.g. -6 or (2.3*4+5/3)^2'); 4196 return $rh_ans; 4197 } 4198 4199 } else { 4200 return $is_an_arithmetic_expression; 4201 } 4202 } 4203 4204 # 4205 4206 =head4 math_constants 4207 4208 replaces pi, e, and ^ with their Perl equivalents 4209 if useBaseTenLog is non-zero, convert log to logten 4210 4211 =cut 4212 4213 sub math_constants { 4214 my($in,%options) = @_; 4215 my $rh_ans; 4216 my $process_ans_hash = ( ref( $in ) eq 'AnswerHash' ) ? 1 : 0 ; 4217 if ($process_ans_hash) { 4218 $rh_ans = $in; 4219 $in = $rh_ans->{student_ans}; 4220 } 4221 # The code fragment above allows this filter to be used when the input is simply a string 4222 # as well as when the input is an AnswerHash, and options. 4223 $in =~s/\bpi\b/(4*atan2(1,1))/ge; 4224 $in =~s/\be\b/(exp(1))/ge; 4225 $in =~s/\^/**/g; 4226 if($useBaseTenLog) { 4227 $in =~ s/\blog\b/logten/g; 4228 } 4229 4230 if ($process_ans_hash) { 4231 $rh_ans->{student_ans}=$in; 4232 return $rh_ans; 4233 } else { 4234 return $in; 4235 } 4236 } 4237 4238 4239 4240 =head4 is_array 4241 4242 is_array($rh_ans) 4243 returns: $rh_ans. Throws error "NOTARRAY" if this is not an array 4244 4245 =cut 4246 4247 sub is_array { 4248 my $rh_ans = shift; 4249 # return if the result is an array 4250 return($rh_ans) if ref($rh_ans->{student_ans}) eq 'ARRAY' ; 4251 $rh_ans->throw_error("NOTARRAY","The answer is not an array"); 4252 $rh_ans; 4253 } 4254 4255 =head4 check_syntax 4256 4257 check_syntax( $rh_ans, %options) 4258 returns an answer hash. 4259 4260 latex2html preview code are installed in the answer hash. 4261 The input has been transformed, changing 7pi to 7*pi or 7x to 7*x. 4262 Syntax error messages may be generated and stored in student_ans 4263 Additional syntax error messages are stored in {ans_message} and duplicated in {error_message} 4264 4265 4266 =cut 4267 4268 sub check_syntax { 4269 my $rh_ans = shift; 4270 my %options = @_; 4271 assign_option_aliases(\%options, 4272 ); 4273 set_default_options( \%options, 4274 'stdin' => 'student_ans', 4275 'stdout' => 'student_ans', 4276 'ra_vars' => [qw( x y )], 4277 'debug' => 0, 4278 '_filter_name' => 'check_syntax', 4279 error_msg_flag => 1, 4280 ); 4281 #initialize 4282 $rh_ans->{_filter_name} = $options{_filter_name}; 4283 unless ( defined( $rh_ans->{$options{stdin}} ) ) { 4284 warn "Check_syntax requires an equation in the field '$options{stdin}' or input"; 4285 $rh_ans->throw_error("1","'$options{stdin}' field not defined"); 4286 return $rh_ans; 4287 } 4288 my $in = $rh_ans->{$options{stdin}}; 4289 my $parser = new AlgParserWithImplicitExpand; 4290 my $ret = $parser -> parse($in); #for use with loops 4291 4292 if ( ref($ret) ) { ## parsed successfully 4293 # $parser -> tostring(); # FIXME? was this needed for some reason????? 4294 $parser -> normalize(); 4295 $rh_ans -> {$options{stdout}} = $parser -> tostring(); 4296 $rh_ans -> {preview_text_string} = $in; 4297 $rh_ans -> {preview_latex_string} = $parser -> tolatex(); 4298 4299 } elsif ($options{error_msg_flag} ) { ## error in parsing 4300 4301 $rh_ans->{$options{stdout}} = 'syntax error:'. $parser->{htmlerror}, 4302 $rh_ans->{'ans_message'} = $parser -> {error_msg}, 4303 $rh_ans->{'preview_text_string'} = '', 4304 $rh_ans->{'preview_latex_string'} = '', 4305 $rh_ans->throw_error('SYNTAX', 'syntax error in answer:'. $parser->{htmlerror} . "$BR" .$parser -> {error_msg}); 4306 } # no output is produced if there is an error and the error_msg_flag is set to zero 4307 $rh_ans; 4308 4309 } 4310 4311 =head4 check_strings 4312 4313 check_strings ($rh_ans, %options) 4314 returns $rh_ans 4315 4316 =cut 4317 4318 sub check_strings { 4319 my ($rh_ans, %options) = @_; 4320 4321 # if the student's answer is a number, simply return the answer hash (unchanged). 4322 4323 # we allow constructions like -INF to be treated as a string. Thus we ignore an initial 4324 # - in deciding whether the student's answer is a number or string 4325 4326 my $temp_ans = $rh_ans->{student_ans}; 4327 $temp_ans =~ s/^\s*\-//; # remove an initial - 4328 4329 if ( $temp_ans =~ m/[\d+\-*\/^(){}\[\]]|^\s*e\s*$|^\s*pi\s*$/) { 4330 # if ( $rh_ans->{answerIsString} == 1) { 4331 # #$rh_ans->throw_error('STRING','Incorrect Answer'); # student's answer is a number 4332 # } 4333 return $rh_ans; 4334 } 4335 # the student's answer is recognized as a string 4336 my $ans = $rh_ans->{student_ans}; 4337 4338 # OVERVIEW of reminder of function: 4339 # if answer is correct, return correct. (adjust score to 1) 4340 # if answer is incorect: 4341 # 1) determine if the answer is sensible. if it is, return incorrect. 4342 # 2) if the answer is not sensible (and incorrect), then return an error message indicating so. 4343 # no matter what: throw a 'STRING' error to skip numerical evaluations. (error flag skips remainder of pre_filters and evaluators) 4344 # last: 'STRING' post_filter will clear the error (avoiding pink screen.) 4345 4346 my $sensibleAnswer = 0; 4347 $ans = str_filters( $ans, 'compress_whitespace' ); # remove trailing, leading, and double spaces. 4348 my ($ans_eval) = str_cmp($rh_ans->{correct_ans}); 4349 my $temp_ans_hash = $ans_eval->evaluate($ans); 4350 $rh_ans->{test} = $temp_ans_hash; 4351 4352 if ($temp_ans_hash->{score} ==1 ) { # students answer matches the correct answer. 4353 $rh_ans->{score} = 1; 4354 $sensibleAnswer = 1; 4355 } else { # students answer does not match the correct answer. 4356 my $legalString = ''; # find out if string makes sense 4357 my @legalStrings = @{$options{strings}}; 4358 foreach $legalString (@legalStrings) { 4359 if ( uc($ans) eq uc($legalString) ) { 4360 $sensibleAnswer = 1; 4361 last; 4362 } 4363 } 4364 $sensibleAnswer = 1 unless $ans =~ /\S/; ## empty answers are sensible 4365 $rh_ans->throw_error('EVAL', "Your answer is not a recognized answer") unless ($sensibleAnswer); 4366 # $temp_ans_hash -> setKeys( 'ans_message' => 'Your answer is not a recognized answer' ) unless ($sensibleAnswer); 4367 # $temp_ans_hash -> setKeys( 'student_ans' => uc($ans) ); 4368 } 4369 4370 $rh_ans->{student_ans} = $ans; 4371 4372 if ($sensibleAnswer) { 4373 $rh_ans->throw_error('STRING', "The student's answer $rh_ans->{student_ans} is interpreted as a string."); 4374 } 4375 4376 $rh_ans->{'preview_text_string'} = $ans, 4377 $rh_ans->{'preview_latex_string'} = $ans, 4378 4379 # warn ("\$rh_ans->{answerIsString} = $rh_ans->{answerIsString}"); 4380 $rh_ans; 4381 } 4382 4383 =head4 check_units 4384 4385 check_strings ($rh_ans, %options) 4386 returns $rh_ans 4387 4388 4389 =cut 4390 4391 sub check_units { 4392 my ($rh_ans, %options) = @_; 4393 my %correct_units = %{$rh_ans-> {rh_correct_units}}; 4394 my $ans = $rh_ans->{student_ans}; 4395 # $ans = '' unless defined ($ans); 4396 $ans = str_filters ($ans, 'trim_whitespace'); 4397 my $original_student_ans = $ans; 4398 $rh_ans->{original_student_ans} = $original_student_ans; 4399 4400 # it surprises me that the match below works since the first .* is greedy. 4401 my ($num_answer, $units) = $ans =~ /^(.*)\s+([^\s]*)$/; 4402 4403 unless ( defined($num_answer) && $units ) { 4404 # there is an error reading the input 4405 if ( $ans =~ /\S/ ) { # the answer is not blank 4406 $rh_ans -> setKeys( 'ans_message' => "The answer \"$ans\" could not be interpreted " . 4407 "as a number or an arithmetic expression followed by a unit specification. " . 4408 "Your answer must contain units." ); 4409 $rh_ans->throw_error('UNITS', "The answer \"$ans\" could not be interpreted " . 4410 "as a number or an arithmetic expression followed by a unit specification. " . 4411 "Your answer must contain units." ); 4412 } 4413 return $rh_ans; 4414 } 4415 4416 # we have been able to parse the answer into a numerical part and a unit part 4417 4418 # $num_answer = $1; #$1 and $2 from the regular expression above 4419 # $units = $2; 4420 4421 my %units = Units::evaluate_units($units); 4422 if ( defined( $units{'ERROR'} ) ) { 4423 # handle error condition 4424 $units{'ERROR'} = clean_up_error_msg($units{'ERROR'}); 4425 $rh_ans -> setKeys( 'ans_message' => "$units{'ERROR'}" ); 4426 $rh_ans -> throw_error('UNITS', "$units{'ERROR'}"); 4427 return $rh_ans; 4428 } 4429 4430 my $units_match = 1; 4431 my $fund_unit; 4432 foreach $fund_unit (keys %correct_units) { 4433 next if $fund_unit eq 'factor'; 4434 $units_match = 0 unless $correct_units{$fund_unit} == $units{$fund_unit}; 4435 } 4436 4437 if ( $units_match ) { 4438 # units are ok. Evaluate the numerical part of the answer 4439 $rh_ans->{'tolerance'} = $rh_ans->{'tolerance'}* $correct_units{'factor'}/$units{'factor'} if 4440 $rh_ans->{'tolType'} eq 'absolute'; # the tolerance is in the units specified by the instructor. 4441 $rh_ans->{correct_ans} = prfmt($rh_ans->{correct_ans}*$correct_units{'factor'}/$units{'factor'}); 4442 $rh_ans->{student_units} = $units; 4443 $rh_ans->{student_ans} = $num_answer; 4444 4445 } else { 4446 $rh_ans -> setKeys( ans_message => 'There is an error in the units for this answer.' ); 4447 $rh_ans -> throw_error ( 'UNITS', 'There is an error in the units for this answer.' ); 4448 } 4449 4450 return $rh_ans; 4451 } 4452 4453 4454 4455 =head2 Filter utilities 4456 4457 These two subroutines can be used in filters to set default options. They 4458 help make filters perform in uniform, predictable ways, and also make it 4459 easy to recognize from the code which options a given filter expects. 4460 4461 4462 =head4 assign_option_aliases 4463 4464 Use this to assign aliases for the standard options. It must come before set_default_options 4465 within the subroutine. 4466 4467 assign_option_aliases(\%options, 4468 'alias1' => 'option5' 4469 'alias2' => 'option7' 4470 ); 4471 4472 4473 If the subroutine is called with an option " alias1 => 23 " it will behave as if it had been 4474 called with the option " option5 => 23 " 4475 4476 =cut 4477 4478 4479 4480 sub assign_option_aliases { 4481 my $rh_options = shift; 4482 warn "The first entry to set_default_options must be a reference to the option hash" unless ref($rh_options) eq 'HASH'; 4483 my @option_aliases = @_; 4484 while (@option_aliases) { 4485 my $alias = shift @option_aliases; 4486 my $option_key = shift @option_aliases; 4487 4488 if (defined($rh_options->{$alias} )) { # if the alias appears in the option list 4489 if (not defined($rh_options->{$option_key}) ) { # and the option itself is not defined, 4490 $rh_options->{$option_key} = $rh_options->{$alias}; # insert the value defined by the alias into the option value 4491 # the FIRST alias for a given option takes precedence 4492 # (after the option itself) 4493 } else { 4494 warn "option $option_key is already defined as", $rh_options->{$option_key}, "<br>\n", 4495 "The attempt to override this option with the alias $alias with value ", $rh_options->{$alias}, 4496 " was ignored."; 4497 } 4498 } 4499 delete($rh_options->{$alias}); # remove the alias from the initial list 4500 } 4501 4502 } 4503 4504 =head4 set_default_options 4505 4506 set_default_options(\%options, 4507 '_filter_name' => 'filter', 4508 'option5' => .0001, 4509 'option7' => 'ascii', 4510 'allow_unknown_options => 0, 4511 } 4512 4513 Note that the first entry is a reference to the options with which the filter was called. 4514 4515 The option5 is set to .0001 unless the option is explicitly set when the subroutine is called. 4516 4517 The B<'_filter_name'> option should always be set, although there is no error if it is missing. 4518 It is used mainly for debugging answer evaluators and allows 4519 you to keep track of which filter is currently processing the answer. 4520 4521 If B<'allow_unknown_options'> is set to 0 then if the filter is called with options which do NOT appear in the 4522 set_default_options list an error will be signaled and a warning message will be printed out. This provides 4523 error checking against misspelling an option and is generally what is desired for most filters. 4524 4525 Occasionally one wants to write a filter which accepts a long list of options, not all of which are known in advance, 4526 but only uses a subset of the options 4527 provided. In this case, setting 'allow_unkown_options' to 1 prevents the error from being signaled. 4528 4529 =cut 4530 4531 sub set_default_options { 4532 my $rh_options = shift; 4533 warn "The first entry to set_default_options must be a reference to the option hash" unless ref($rh_options) eq 'HASH'; 4534 my %default_options = @_; 4535 unless ( defined($default_options{allow_unknown_options}) and $default_options{allow_unknown_options} == 1 ) { 4536 foreach my $key1 (keys %$rh_options) { 4537 warn "This option |$key1| is not recognized in this subroutine<br> ", pretty_print($rh_options) unless exists($default_options{$key1}); 4538 } 4539 } 4540 foreach my $key (keys %default_options) { 4541 if ( not defined($rh_options->{$key} ) and defined( $default_options{$key} ) ) { 4542 $rh_options->{$key} = $default_options{$key}; #this allows tol => undef to allow the tol option, but doesn't define 4543 # this key unless tol is explicitly defined. 4544 } 4545 } 4546 } 4547 4548 =head2 Problem Grader Subroutines 4549 4550 =cut 4551 4552 ## Problem Grader Subroutines 4553 4554 ##################################### 4555 # This is a model for plug-in problem graders 4556 ##################################### 4557 sub install_problem_grader { 4558 my $rf_problem_grader = shift; 4559 my $rh_flags = PG_restricted_eval(q!\\%main::PG_FLAGS!); 4560 $rh_flags->{PROBLEM_GRADER_TO_USE} = $rf_problem_grader; 4561 } 4562 4563 =head4 std_problem_grader 4564 4565 This is an all-or-nothing grader. A student must get all parts of the problem write 4566 before receiving credit. You should make sure to use this grader on multiple choice 4567 and true-false questions, otherwise students will be able to deduce how many 4568 answers are correct by the grade reported by webwork. 4569 4570 4571 install_problem_grader(~~&std_problem_grader); 4572 4573 =cut 4574 4575 sub std_problem_grader { 4576 my $rh_evaluated_answers = shift; 4577 my $rh_problem_state = shift; 4578 my %form_options = @_; 4579 my %evaluated_answers = %{$rh_evaluated_answers}; 4580 # The hash $rh_evaluated_answers typically contains: 4581 # 'answer1' => 34, 'answer2'=> 'Mozart', etc. 4582 4583 # By default the old problem state is simply passed back out again. 4584 my %problem_state = %$rh_problem_state; 4585 4586 # %form_options might include 4587 # The user login name 4588 # The permission level of the user 4589 # The studentLogin name for this psvn. 4590 # Whether the form is asking for a refresh or is submitting a new answer. 4591 4592 # initial setup of the answer 4593 my %problem_result = ( score => 0, 4594 errors => '', 4595 type => 'std_problem_grader', 4596 msg => '', 4597 ); 4598 # Checks 4599 4600 my $ansCount = keys %evaluated_answers; # get the number of answers 4601 4602 unless ($ansCount > 0 ) { 4603 4604 $problem_result{msg} = "This problem did not ask any questions."; 4605 return(\%problem_result,\%problem_state); 4606 } 4607 4608 if ($ansCount > 1 ) { 4609 $problem_result{msg} = 'In order to get credit for this problem all answers must be correct.' ; 4610 } 4611 4612 unless ($form_options{answers_submitted} == 1) { 4613 return(\%problem_result,\%problem_state); 4614 } 4615 4616 my $allAnswersCorrectQ=1; 4617 foreach my $ans_name (keys %evaluated_answers) { 4618 # I'm not sure if this check is really useful. 4619 if ( ( ref($evaluated_answers{$ans_name} ) eq 'HASH' ) or ( ref($evaluated_answers{$ans_name}) eq 'AnswerHash' ) ) { 4620 $allAnswersCorrectQ = 0 unless( 1 == $evaluated_answers{$ans_name}->{score} ); 4621 } 4622 else { 4623 die "Error at file ",__FILE__,"line ", __LINE__,": Answer |$ans_name| is not a hash reference\n". 4624 $evaluated_answers{$ans_name} . 4625 "This probably means that the answer evaluator for this answer\n" . 4626 "is not working correctly."; 4627 $problem_result{error} = "Error: Answer $ans_name is not a hash: $evaluated_answers{$ans_name}"; 4628 } 4629 } 4630 # report the results 4631 $problem_result{score} = $allAnswersCorrectQ; 4632 4633 # I don't like to put in this bit of code. 4634 # It makes it hard to construct error free problem graders 4635 # I would prefer to know that the problem score was numeric. 4636 unless (defined($problem_state{recorded_score}) and $problem_state{recorded_score} =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/ ) { 4637 $problem_state{recorded_score} = 0; # This gets rid of non-numeric scores 4638 } 4639 # 4640 if ($allAnswersCorrectQ == 1 or $problem_state{recorded_score} == 1) { 4641 $problem_state{recorded_score} = 1; 4642 } 4643 else { 4644 $problem_state{recorded_score} = 0; 4645 } 4646 4647 $problem_state{num_of_correct_ans}++ if $allAnswersCorrectQ == 1; 4648 $problem_state{num_of_incorrect_ans}++ if $allAnswersCorrectQ == 0; 4649 4650 $problem_state{state_summary_msg} = ''; # an HTML formatted message printed at the bottom of the problem page 4651 4652 (\%problem_result, \%problem_state); 4653 } 4654 4655 =head4 std_problem_grader2 4656 4657 This is an all-or-nothing grader. A student must get all parts of the problem write 4658 before receiving credit. You should make sure to use this grader on multiple choice 4659 and true-false questions, otherwise students will be able to deduce how many 4660 answers are correct by the grade reported by webwork. 4661 4662 4663 install_problem_grader(~~&std_problem_grader2); 4664 4665 The only difference between the two versions 4666 is at the end of the subroutine, where std_problem_grader2 4667 records the attempt only if there have been no syntax errors, 4668 whereas std_problem_grader records it regardless. 4669 4670 =cut 4671 4672 4673 4674 sub std_problem_grader2 { 4675 my $rh_evaluated_answers = shift; 4676 my $rh_problem_state = shift; 4677 my %form_options = @_; 4678 my %evaluated_answers = %{$rh_evaluated_answers}; 4679 # The hash $rh_evaluated_answers typically contains: 4680 # 'answer1' => 34, 'answer2'=> 'Mozart', etc. 4681 4682 # By default the old problem state is simply passed back out again. 4683 my %problem_state = %$rh_problem_state; 4684 4685 # %form_options might include 4686 # The user login name 4687 # The permission level of the user 4688 # The studentLogin name for this psvn. 4689 # Whether the form is asking for a refresh or is submitting a new answer. 4690 4691 # initial setup of the answer 4692 my %problem_result = ( score => 0, 4693 errors => '', 4694 type => 'std_problem_grader', 4695 msg => '', 4696 ); 4697 4698 # syntax errors are not counted. 4699 my $record_problem_attempt = 1; 4700 # Checks 4701 4702 my $ansCount = keys %evaluated_answers; # get the number of answers 4703 unless ($ansCount > 0 ) { 4704 $problem_result{msg} = "This problem did not ask any questions."; 4705 return(\%problem_result,\%problem_state); 4706 } 4707 4708 if ($ansCount > 1 ) { 4709 $problem_result{msg} = 'In order to get credit for this problem all answers must be correct.' ; 4710 } 4711 4712 unless ($form_options{answers_submitted} == 1) { 4713 return(\%problem_result,\%problem_state); 4714 } 4715 4716 my $allAnswersCorrectQ=1; 4717 foreach my $ans_name (keys %evaluated_answers) { 4718 # I'm not sure if this check is really useful. 4719 if ( ( ref($evaluated_answers{$ans_name} ) eq 'HASH' ) or ( ref($evaluated_answers{$ans_name}) eq 'AnswerHash' ) ) { 4720 $allAnswersCorrectQ = 0 unless( 1 == $evaluated_answers{$ans_name}->{score} ); 4721 } 4722 else { 4723 die "Error at file ",__FILE__,"line ", __LINE__,": Answer |$ans_name| is not a hash reference\n". 4724 $evaluated_answers{$ans_name} . 4725 "This probably means that the answer evaluator for this answer\n" . 4726 "is not working correctly."; 4727 $problem_result{error} = "Error: Answer $ans_name is not a hash: $evaluated_answers{$ans_name}"; 4728 } 4729 } 4730 # report the results 4731 $problem_result{score} = $allAnswersCorrectQ; 4732 4733 # I don't like to put in this bit of code. 4734 # It makes it hard to construct error free problem graders 4735 # I would prefer to know that the problem score was numeric. 4736 unless ($problem_state{recorded_score} =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/ ) { 4737 $problem_state{recorded_score} = 0; # This gets rid of non-numeric scores 4738 } 4739 # 4740 if ($allAnswersCorrectQ == 1 or $problem_state{recorded_score} == 1) { 4741 $problem_state{recorded_score} = 1; 4742 } 4743 else { 4744 $problem_state{recorded_score} = 0; 4745 } 4746 # record attempt only if there have been no syntax errors. 4747 4748 if ($record_problem_attempt == 1) { 4749 $problem_state{num_of_correct_ans}++ if $allAnswersCorrectQ == 1; 4750 $problem_state{num_of_incorrect_ans}++ if $allAnswersCorrectQ == 0; 4751 $problem_state{state_summary_msg} = ''; # an HTML formatted message printed at the bottom of the problem page 4752 4753 } 4754 else { 4755 $problem_result{show_partial_correct_answers} = 0 ; # prevent partial correct answers from being shown for syntax errors. 4756 } 4757 (\%problem_result, \%problem_state); 4758 } 4759 4760 =head4 avg_problem_grader 4761 4762 This grader gives a grade depending on how many questions from the problem are correct. (The highest 4763 grade is the one that is kept. One can never lower the recorded grade on a problem by repeating it.) 4764 Many professors (and almost all students :-) ) prefer this grader. 4765 4766 4767 install_problem_grader(~~&avg_problem_grader); 4768 4769 =cut 4770 4771 4772 sub avg_problem_grader { 4773 my $rh_evaluated_answers = shift; 4774 my $rh_problem_state = shift; 4775 my %form_options = @_; 4776 my %evaluated_answers = %{$rh_evaluated_answers}; 4777 # The hash $rh_evaluated_answers typically contains: 4778 # 'answer1' => 34, 'answer2'=> 'Mozart', etc. 4779 4780 # By default the old problem state is simply passed back out again. 4781 my %problem_state = %$rh_problem_state; 4782 4783 4784 # %form_options might include 4785 # The user login name 4786 # The permission level of the user 4787 # The studentLogin name for this psvn. 4788 # Whether the form is asking for a refresh or is submitting a new answer. 4789 4790 # initial setup of the answer 4791 my $total=0; 4792 my %problem_result = ( score => 0, 4793 errors => '', 4794 type => 'avg_problem_grader', 4795 msg => '', 4796 ); 4797 my $count = keys %evaluated_answers; 4798 $problem_result{msg} = 'You can earn partial credit on this problem.' if $count >1; 4799 # Return unless answers have been submitted 4800 unless ($form_options{answers_submitted} == 1) { 4801 return(\%problem_result,\%problem_state); 4802 } 4803 4804 # Answers have been submitted -- process them. 4805 foreach my $ans_name (keys %evaluated_answers) { 4806 # I'm not sure if this check is really useful. 4807 if ( ( ref($evaluated_answers{$ans_name} ) eq 'HASH' ) or ( ref($evaluated_answers{$ans_name}) eq 'AnswerHash' ) ) { 4808 $total += $evaluated_answers{$ans_name}->{score}; 4809 } 4810 else { 4811 die "Error: Answer |$ans_name| is not a hash reference\n". 4812 $evaluated_answers{$ans_name} . 4813 "This probably means that the answer evaluator for this answer\n" . 4814 "is not working correctly."; 4815 $problem_result{error} = "Error: Answer $ans_name is not a hash: $evaluated_answers{$ans_name}"; 4816 } 4817 } 4818 # Calculate score rounded to three places to avoid roundoff problems 4819 $problem_result{score} = $total/$count if $count; 4820 # increase recorded score if the current score is greater. 4821 $problem_state{recorded_score} = $problem_result{score} if $problem_result{score} > $problem_state{recorded_score}; 4822 4823 4824 $problem_state{num_of_correct_ans}++ if $total == $count; 4825 $problem_state{num_of_incorrect_ans}++ if $total < $count ; 4826 4827 $problem_state{state_summary_msg} = ''; # an HTML formatted message printed at the bottom of the problem page 4828 4829 warn "Error in grading this problem the total $total is larger than $count" if $total > $count; 4830 (\%problem_result, \%problem_state); 4831 } 4832 4833 =head2 Utility subroutines 4834 4835 =head4 4836 4837 warn pretty_print( $rh_hash_input) 4838 4839 This can be very useful for printing out messages about objects while debugging 4840 4841 =cut 4842 4843 sub pretty_print { 4844 my $r_input = shift; 4845 my $out = ''; 4846 if ( not ref($r_input) ) { 4847 $out = $r_input; # not a reference 4848 } elsif ("$r_input" =~/hash/i) { # this will pick up objects whose '$self' is hash and so works better than ref($r_iput). 4849 local($^W) = 0; 4850 $out .= "$r_input " ."<TABLE border = \"2\" cellpadding = \"3\" BGCOLOR = \"#FFFFFF\">"; 4851 foreach my $key (lex_sort( keys %$r_input )) { 4852 $out .= "<tr><TD> $key</TD><TD>=></td><td> ".pretty_print($r_input->{$key}) . "</td></tr>"; 4853 } 4854 $out .="</table>"; 4855 } elsif (ref($r_input) eq 'ARRAY' ) { 4856 my @array = @$r_input; 4857 $out .= "( " ; 4858 while (@array) { 4859 $out .= pretty_print(shift @array) . " , "; 4860 } 4861 $out .= " )"; 4862 } elsif (ref($r_input) eq 'CODE') { 4863 $out = "$r_input"; 4864 } else { 4865 $out = $r_input; 4866 } 4867 $out; 4868 } 4869 4870 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |