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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 6248 - (download) (as text) (annotate)
Fri May 14 01:17:21 2010 UTC (9 years, 7 months ago) by gage
File size: 64226 byte(s)
major update which adds objective methods to the basic code of PG.
HEAD should be considered more beta than usual for a few days until minor glitches
are shaken out.
new modules needed:

PGcore PGalias PGresource PGloadfiles PGanswergroup PGresponsegroup  Tie::IxHash

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9