[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 5663 - (download) (as text) (annotate)
Thu May 8 00:37:31 2008 UTC (11 years, 9 months ago) by sh002i
File size: 64205 byte(s)
add "my" and "our" specifiers to ^variable definitions. (This breaks
compatibility with the current version of ww-symbol-map, but it is the
format that the upcoming version will use. I hope to commit that new
version soon but testing is taking longer than expected.)

    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.67 2008/05/03 17:43:29 sh002i 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 
  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/</&lt;/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>=&gt;</td><td>&nbsp;".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/</&lt;/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