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