[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 4997 - (download) (as text) (annotate)
Mon Jun 11 18:16:40 2007 UTC (12 years, 7 months ago) by gage
File size: 179180 byte(s)
Fixing docementation so that it can be read from the web.

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9