[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 5585 - (download) (as text) (annotate)
Sat Nov 10 20:55:23 2007 UTC (12 years, 1 month ago) by gage
File size: 61639 byte(s)
Made changes in the way the default values for answer evaluators are set.
(They were frequently undefined.)

We now get them from the envir variable which seems to work.  For example:

$functAbsTolDefault            = PG_restricted_eval(q/$envir{functAbsTolDefault}/);

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9