[system] / trunk / pg / lib / Value / AnswerChecker.pm Repository:
ViewVC logotype

View of /trunk/pg/lib/Value/AnswerChecker.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 5692 - (download) (as text) (annotate)
Sat Jun 14 11:46:28 2008 UTC (11 years, 5 months ago) by dpvc
File size: 69873 byte(s)
Make sure the previous answer is of the same MathObject class as the
object being checked (so the comparison is done by the right object).
This came up with the ImplicitEquation object).

    1 
    2 =head1 DESCRIPTION
    3 
    4  #############################################################
    5  #
    6  #  Implements the ->cmp method for Value objects.
    7  #  Otherwise known as MathObjects.  This produces
    8  #  an answer checker appropriate for the type of object.
    9  #  Additional options can be passed to the cmp method to
   10  #  modify its action.
   11  #
   12  #   Usage:  $num = Real(3.45); # Real can be replaced by any other MathObject
   13  #       ANS($num->cmp(compareOptionName => compareOptionValue, ... ))
   14  #
   15  #  The individual Value packages are modified below to add the
   16  #  needed methods.
   17  #
   18  #############################################################
   19 
   20 =cut
   21 
   22 package Value;
   23 
   24 #
   25 #  Context can add default values to the answer checkers by class;
   26 #
   27 $Value::defaultContext->{cmpDefaults} = {};
   28 
   29 =head5 $mathObject->cmp_defaults()
   30 
   31 #  Internal use.
   32 #  Set default flags for the answer checker in this object
   33 #     showTypeWarnings => 1
   34 #       showEqualErrors  => 1
   35 #       ignoreStrings    => 1
   36 #       studentsMustReduceUnions => 1
   37 #       show UnionReduceWarnings => 1
   38 #
   39 
   40 =cut
   41 
   42 sub cmp_defaults {(
   43   showTypeWarnings => 1,
   44   showEqualErrors  => 1,
   45   ignoreStrings    => 1,
   46   studentsMustReduceUnions => 1,
   47   showUnionReduceWarnings => 1,
   48 )}
   49 
   50 
   51 #
   52 #  Special Context flags to be set for the student answer
   53 #
   54 
   55 sub cmp_contextFlags {
   56   my $self = shift; my $ans = shift;
   57   return (
   58     StringifyAsTeX => 0,                 # reset this, just in case.
   59     no_parameters => 1,                  # don't let students enter parameters
   60     showExtraParens => 2,                # make student answer painfully unambiguous
   61     reduceConstants => 0,                # don't combine student constants
   62     reduceConstantFunctions => 0,        # don't reduce constant functions
   63     ($ans->{studentsMustReduceUnions} ?
   64       (reduceUnions => 0, reduceSets => 0,
   65        reduceUnionsForComparison => $ans->{showUnionReduceWarnings},
   66        reduceSetsForComparison => $ans->{showUnionReduceWarnings}) :
   67       (reduceUnions => 1, reduceSets => 1,
   68        reduceUnionsForComparison => 1, reduceSetsForComparison => 1)),
   69     ($ans->{requireParenMatch}? (): ignoreEndpointTypes => 1),  # for Intervals
   70   );
   71 }
   72 
   73 
   74 #
   75 #  Create an answer checker for the given type of object
   76 #
   77 
   78 sub cmp {
   79   my $self = shift;
   80   my $ans = new AnswerEvaluator;
   81   my $correct = preformat($self->{correct_ans});
   82   $correct = $self->correct_ans unless defined($correct);
   83   $self->{context} = Value->context unless defined($self->{context});
   84   $ans->ans_hash(
   85     type => "Value (".$self->class.")",
   86     correct_ans => $correct,
   87     correct_value => $self,
   88     $self->cmp_defaults(@_),
   89     %{$self->{context}{cmpDefaults}{$self->class} || {}},  # context-specified defaults
   90     @_,
   91   );
   92   $ans->{debug} = $ans->{rh_ans}{debug};
   93   $ans->install_evaluator(sub {
   94      my $ans = shift;
   95      $ans->{_filter_name} = "MathObjects answer checker";
   96      $ans->{correct_value}->cmp_parse($ans);
   97   });
   98   $ans->install_pre_filter('erase') if $self->{ans_name}; # don't do blank check if answer_array
   99   $self->cmp_diagnostics($ans);
  100   return $ans;
  101 }
  102 
  103 sub correct_ans {preformat(shift->string)}
  104 sub cmp_diagnostics {}
  105 
  106 #
  107 #  Parse the student answer and compute its value,
  108 #    produce the preview strings, and then compare the
  109 #    student and professor's answers for equality.
  110 #
  111 sub cmp_parse {
  112   my $self = shift; my $ans = shift;
  113   #
  114   #  Do some setup
  115   #
  116   my $current = Value->context; # save it for later
  117   my $context = $ans->{correct_value}{context} || $current;
  118   Parser::Context->current(undef,$context); # change to correct answser's context
  119   my $flags = contextSet($context,$self->cmp_contextFlags($ans)); # save old context flags
  120   my $inputs = $self->getPG('$inputs_ref');
  121   $ans->{isPreview} = $inputs->{previewAnswers} || ($inputs->{action} =~ m/^Preview/);
  122   $ans->{cmp_class} = $self->cmp_class($ans) unless $ans->{cmp_class};
  123   $ans->{error_message} = $ans->{ans_message} = ''; # clear any old messages
  124   $ans->{preview_latex_string} = $ans->{preview_text_string} = '';
  125   $context->clearError();
  126   $context->{answerHash} = $ans; # values here can override context flags
  127 
  128   #
  129   #  Parse and evaluate the student answer
  130   #
  131   $ans->score(0);  # assume failure
  132   $ans->{student_value} = $ans->{student_formula} = Parser::Formula($ans->{student_ans});
  133   $ans->{student_value} = Parser::Evaluate($ans->{student_formula})
  134     if defined($ans->{student_formula}) && $ans->{student_formula}->isConstant;
  135 
  136   #
  137   #  If it parsed OK, save the output forms and check if it is correct
  138   #   otherwise report an error
  139   #
  140   if (defined $ans->{student_value}) {
  141     $ans->{student_value} = $self->Package("Formula")->new($ans->{student_value})
  142        unless Value::isValue($ans->{student_value});
  143     $ans->{student_value}{isStudent} = 1;
  144     $ans->{preview_latex_string} = $ans->{student_formula}->TeX;
  145     $ans->{preview_text_string}  = preformat($ans->{student_formula}->string);
  146     #
  147     #  Get the string for the student answer
  148     #
  149     for ($self->getFlag('formatStudentAnswer')) {
  150       /evaluated/i  and do {$ans->{student_ans} = preformat($ans->{student_value}->string); last};
  151       /parsed/i     and do {$ans->{student_ans} = $ans->{preview_text_string}; last};
  152       /reduced/i    and do {
  153   my $oldFlags = contextSet($context,reduceConstants=>1,reduceConstantFunctions=>0);
  154   $ans->{student_ans} = preformat($ans->{student_formula}->substitute()->string);
  155   contextSet($context,%{$oldFags}); last;
  156       };
  157       warn "Unkown student answer format |$ans->{formatStudentAnswer}|";
  158     }
  159     if ($self->cmp_collect($ans)) {
  160       $self->cmp_preprocess($ans);
  161       $self->cmp_equal($ans);
  162       $self->cmp_postprocess($ans) if !$ans->{error_message} && !$ans->{typeError};
  163       $self->cmp_diagnostics($ans);
  164     }
  165   } else {
  166     $self->cmp_collect($ans);
  167     $self->cmp_error($ans);
  168   }
  169   $context->{answerHash} = undef;
  170   contextSet($context,%{$flags});            # restore context values
  171   Parser::Context->current(undef,$current);  # put back the old context
  172   return $ans;
  173 }
  174 
  175 #
  176 #  Check if the object has an answer array and collect the results
  177 #  Build the combined student answer and set the preview values
  178 #
  179 sub cmp_collect {
  180   my $self = shift; my $ans = shift;
  181   return 1 unless $self->{ans_name};
  182   $ans->{preview_latex_string} = $ans->{preview_text_string} = "";
  183   my $OK = $self->ans_collect($ans);
  184   $ans->{student_ans} = $self->format_matrix($ans->{student_formula},@{$self->{format_options}},tth_delims=>1);
  185   return 0 unless $OK;
  186   my $array = $ans->{student_formula};
  187   if ($self->{ColumnVector}) {
  188     my @V = (); foreach my $x (@{$array}) {push(@V,$x->[0])}
  189     $array = [@V];
  190   } elsif (scalar(@{$array}) == 1) {$array = $array->[0]}
  191   my $type = $self;
  192   $type = $self->Package($self->{tree}->type) if $self->isFormula;
  193   $ans->{student_formula} = eval {$type->new($array)->with(ColumnVector=>$self->{ColumnVector})};
  194   if (!defined($ans->{student_formula}) || $self->context->{error}{flag})
  195     {Parser::reportEvalError($@); $self->cmp_error($ans); return 0}
  196   $ans->{student_value} = $ans->{student_formula};
  197   $ans->{preview_text_string} = $ans->{student_ans};
  198   $ans->{preview_latex_string} = $ans->{student_formula}->TeX;
  199   if (Value::isFormula($ans->{student_formula}) && $ans->{student_formula}->isConstant) {
  200     $ans->{student_value} = Parser::Evaluate($ans->{student_formula});
  201     return 0 unless $ans->{student_value};
  202   }
  203   return 1;
  204 }
  205 
  206 #
  207 #  Check if the parsed student answer equals the professor's answer
  208 #
  209 sub cmp_equal {
  210   my $self = shift; my $ans = shift;
  211   my $correct = $ans->{correct_value};
  212   my $student = $ans->{student_value};
  213   if ($correct->typeMatch($student,$ans)) {
  214     $self->context->clearError();
  215     my $equal = $correct->cmp_compare($student,$ans);
  216     if ($self->context->{error}{flag} != $CMP_MESSAGE &&
  217         (defined($equal) || !$ans->{showEqualErrors})) {$ans->score(1) if $equal; return}
  218     $self->cmp_error($ans);
  219   } else {
  220     return if $ans->{ignoreStrings} && (!Value::isValue($student) || $student->type eq 'String');
  221     $ans->{typeError} = 1;
  222     $ans->{ans_message} = $ans->{error_message} =
  223       "Your answer isn't ".lc($ans->{cmp_class})."\n".
  224         "(it looks like ".lc($student->showClass).")"
  225      if !$ans->{isPreview} && $ans->{showTypeWarnings} && !$ans->{error_message};
  226   }
  227 }
  228 
  229 #
  230 #  Perform the comparison, either using the checker supplied
  231 #  by the answer evaluator, or the overloaded == operator.
  232 #
  233 
  234 our $CMP_ERROR = 2;   # a fatal error was detected
  235 our $CMP_WARNING = 3; # a warning was produced
  236 our $CMP_MESSAGE = 4; # an message should be reported for this check
  237 
  238 sub cmp_compare {
  239   my $self = shift; my $other = shift; my $ans = shift; my $nth = shift || '';
  240   my $context = (Value::isValue($self) ? $self->context : Value->context);
  241   return eval {$self == $other} unless ref($ans->{checker}) eq 'CODE';
  242   my @equal = eval {&{$ans->{checker}}($self,$other,$ans,$nth,@_)};
  243   if (!defined($equal) && $@ ne '' && (!$context->{error}{flag} || $ans->{showAllErrors})) {
  244     $context->setError(["<I>An error occurred while checking your$nth answer:</I>\n".
  245       '<DIV STYLE="margin-left:1em">%s</DIV>',$@],'',undef,undef,$CMP_ERROR);
  246     warn "Please inform your instructor that an error occurred while checking your answer";
  247   }
  248   return (wantarray ? @equal : $equal[0]);
  249 }
  250 
  251 sub cmp_list_compare {Value::List::cmp_list_compare(@_)}
  252 
  253 #
  254 #  Check if types are compatible for equality check
  255 #
  256 sub typeMatch {
  257   my $self = shift;  my $other = shift;
  258   return 1 unless ref($other);
  259   $self->type eq $other->type && !$other->isFormula;
  260 }
  261 
  262 #
  263 #  Class name for cmp error messages
  264 #
  265 sub cmp_class {
  266   my $self = shift; my $ans = shift;
  267   my $class = $self->showClass; $class =~ s/Real //;
  268   return $class if $class =~ m/Formula/;
  269   return "an Interval, Set or Union" if $self->isSetOfReals;
  270   return $class;
  271 }
  272 
  273 #
  274 #  Student answer evaluation failed.
  275 #  Report the error, with formatting, if possible.
  276 #
  277 sub cmp_error {
  278   my $self = shift; my $ans = shift;
  279   my $error = $self->context->{error};
  280   my $message = $error->{message};
  281   if ($error->{pos}) {
  282     my $string = $error->{string};
  283     my ($s,$e) = @{$error->{pos}};
  284     $message =~ s/; see.*//;  # remove the position from the message
  285     $ans->{student_ans} =
  286        protectHTML(substr($string,0,$s)) .
  287        '<SPAN CLASS="parsehilight">' .
  288          protectHTML(substr($string,$s,$e-$s)) .
  289        '</SPAN>' .
  290        protectHTML(substr($string,$e));
  291   }
  292   $self->cmp_Error($ans,$message);
  293 }
  294 
  295 #
  296 #  Set the error message
  297 #
  298 sub cmp_Error {
  299   my $self = shift; my $ans = shift;
  300   return unless scalar(@_) > 0;
  301   $ans->score(0);
  302   $ans->{ans_message} = $ans->{error_message} = join("\n",@_);
  303 }
  304 
  305 #
  306 #  Force a message into the results message column and die
  307 #  (To be used when overriding Parser classes that need
  308 #  to report errors to the student but can't do it in
  309 #  the overridden == since errors are trapped.)
  310 #
  311 sub cmp_Message {
  312   my $message = shift; my $context = Value->context;
  313   $message = [$message,@_] if scalar(@_) > 0;
  314   $context->setError($message,'',undef,undef,$CMP_MESSAGE);
  315   $message = $context->{error}{message};
  316   die $message . traceback() if $context->flags('showTraceback');
  317   die $message . getCaller();
  318 }
  319 
  320 #
  321 #  filled in by sub-classes
  322 #
  323 sub cmp_preprocess {}
  324 sub cmp_postprocess {}
  325 
  326 #
  327 #  Check for unreduced reduced Unions and Sets
  328 #
  329 sub cmp_checkUnionReduce {
  330   my $self = shift; my $student = shift; my $ans = shift; my $nth = shift || '';
  331   return unless $ans->{studentsMustReduceUnions} &&
  332                 $ans->{showUnionReduceWarnings} &&
  333                 !$ans->{isPreview} && !Value::isFormula($student);
  334   return unless $student->isSetOfReals;
  335   my ($result,$error) = $student->isReduced;
  336   return unless $error;
  337   return {
  338     "overlaps" => "Your$nth union contains overlapping intervals",
  339     "overlaps in sets" => "Your$nth union contains sets and intervals that overlap",
  340     "uncombined intervals" => "Your$nth union can be simplified by combining intervals",
  341     "uncombined sets" => "Your$nth union can be simplified by combining some sets",
  342     "repeated elements in set" => "Your$nth union contains sets with repeated elements",
  343     "repeated elements" => "Your$nth set should have no repeated elements",
  344   }->{$error};
  345 }
  346 
  347 #
  348 #  create answer rules of various types
  349 #
  350 sub ans_rule {shift; pgCall('ans_rule',@_)}
  351 sub named_ans_rule {shift; pgCall('NAMED_ANS_RULE',@_)}
  352 sub named_ans_rule_extension {shift; pgCall('NAMED_ANS_RULE_EXTENSION',@_)}
  353 sub ans_array {shift->ans_rule(@_)};
  354 sub named_ans_array {shift->named_ans_rule(@_)};
  355 sub named_ans_array_extension {shift->named_ans_rule_extension(@_)};
  356 
  357 sub pgCall {my $call = shift; &{WeBWorK::PG::Translator::PG_restricted_eval('\&'.$call)}(@_)}
  358 sub pgRef {WeBWorK::PG::Translator::PG_restricted_eval('\&'.shift)}
  359 
  360 our $answerPrefix = "MaTrIx";
  361 
  362 #
  363 #  Lay out a matrix of answer rules
  364 #
  365 sub ans_matrix {
  366   my $self = shift;
  367   my ($extend,$name,$rows,$cols,$size,$open,$close,$sep) = @_;
  368   my $named_extension = pgRef('NAMED_ANS_RULE_EXTENSION');
  369   my $new_name = pgRef('RECORD_FORM_LABEL');
  370   my $HTML = ""; my $ename = $name;
  371   if ($name eq '') {
  372     my $n = pgCall('inc_ans_rule_count');
  373     $name = pgCall('NEW_ANS_NAME',$n);
  374     $ename = $answerPrefix.$n;
  375   }
  376   $self->{ans_name} = $ename;
  377   $self->{ans_rows} = $rows;
  378   $self->{ans_cols} = $cols;
  379   my @array = ();
  380   foreach my $i (0..$rows-1) {
  381     my @row = ();
  382     foreach my $j (0..$cols-1) {
  383       if ($i == 0 && $j == 0) {
  384   if ($extend) {push(@row,&$named_extension(&$new_name($name),$size))}
  385           else {push(@row,pgCall('NAMED_ANS_RULE',$name,$size))}
  386       } else {
  387   push(@row,&$named_extension(&$new_name(ANS_NAME($ename,$i,$j)),$size));
  388       }
  389     }
  390     push(@array,[@row]);
  391   }
  392   $self->format_matrix([@array],open=>$open,close=>$close,sep=>$sep);
  393 }
  394 
  395 sub ANS_NAME {
  396   my ($name,$i,$j) = @_;
  397   $name.'_'.$i.'_'.$j;
  398 }
  399 
  400 
  401 #
  402 #  Lay out an arbitrary matrix
  403 #
  404 sub format_matrix {
  405   my $self = shift; my $array = shift;
  406   my $displayMode = $self->getPG('$displayMode');
  407   $array = [$array] unless ref($array->[0]) eq 'ARRAY';
  408   return $self->format_matrix_tex($array,@_) if ($displayMode eq 'TeX');
  409   return $self->format_matrix_HTML($array,@_);
  410 }
  411 
  412 sub format_matrix_tex {
  413   my $self = shift; my $array = shift;
  414   my %options = (open=>'.',close=>'.',sep=>'',@_);
  415   $self->{format_options} = [%options] unless $self->{format_options};
  416   my ($open,$close,$sep) = ($options{open},$options{close},$options{sep});
  417   my ($rows,$cols) = (scalar(@{$array}),scalar(@{$array->[0]}));
  418   my $tex = "";
  419   $open = '\\'.$open if $open =~ m/[{}]/; $close = '\\'.$close if $close =~ m/[{}]/;
  420   $tex .= '\(\left'.$open;
  421   $tex .= '\setlength{\arraycolsep}{2pt}', $sep = '\,'.$sep if $sep;
  422   $tex .= '\begin{array}{'.('c'x$cols).'}';
  423   foreach my $i (0..$rows-1) {$tex .= join($sep.'&',@{$array->[$i]}).'\cr'."\n"}
  424   $tex .= '\end{array}\right'.$close.'\)';
  425   return $tex;
  426 }
  427 
  428 sub format_matrix_HTML {
  429   my $self = shift; my $array = shift;
  430   my %options = (open=>'',close=>'',sep=>'',tth_delims=>0,@_);
  431   $self->{format_options} = [%options] unless $self->{format_options};
  432   my ($open,$close,$sep) = ($options{open},$options{close},$options{sep});
  433   my ($rows,$cols) = (scalar(@{$array}),scalar(@{$array->[0]}));
  434   my $HTML = "";
  435   if ($sep) {$sep = '</TD><TD STYLE="padding: 0px 1px">'.$sep.'</TD><TD>'}
  436        else {$sep = '</TD><TD WIDTH="8px"></TD><TD>'}
  437   foreach my $i (0..$rows-1) {
  438     $HTML .= '<TR><TD HEIGHT="6px"></TD></TR>' if $i;
  439     $HTML .= '<TR ALIGN="MIDDLE"><TD>'.join($sep,EVALUATE(@{$array->[$i]})).'</TD></TR>'."\n";
  440   }
  441   $open = $self->format_delimiter($open,$rows,$options{tth_delims});
  442   $close = $self->format_delimiter($close,$rows,$options{tth_delims});
  443   if ($open ne '' || $close ne '') {
  444     $HTML = '<TR ALIGN="MIDDLE">'
  445           . '<TD>'.$open.'</TD>'
  446           . '<TD WIDTH="2"></TD>'
  447           . '<TD><TABLE BORDER="0" CELLSPACING="0" CELLPADDING="0" CLASS="ArrayLayout">'
  448           .   $HTML
  449           . '</TABLE></TD>'
  450           . '<TD WIDTH="4"></TD>'
  451           . '<TD>'.$close.'</TD>'
  452           . '</TR>'."\n";
  453   }
  454   return '<TABLE BORDER="0" CELLSPACING="0" CELLPADDING="0" CLASS="ArrayLayout"'
  455           . ' STYLE="display:inline;vertical-align:-'.(1.1*$rows-.6).'em">'
  456           . $HTML
  457           . '</TABLE>';
  458 }
  459 
  460 sub EVALUATE {map {(Value::isFormula($_) && $_->isConstant? $_->eval: $_)} @_}
  461 
  462 sub VERBATIM {
  463   my $string = shift;
  464   my $displayMode = Value->getPG('$displayMode');
  465   $string = '\end{verbatim}'.$string.'\begin{verbatim}' if $displayMode eq 'TeX';
  466   return $string;
  467 }
  468 
  469 #
  470 #  Create a tall delimiter to match the line height
  471 #
  472 sub format_delimiter {
  473   my $self = shift; my $delim = shift; my $rows = shift; my $tth = shift;
  474   return '' if $delim eq '' || $delim eq '.';
  475   my $displayMode = $self->getPG('$displayMode');
  476   return $self->format_delimiter_tth($delim,$rows,$tth)
  477     if $tth || $displayMode eq 'HTML_tth' || $displayMode !~ m/^HTML_/;
  478   my $rule = '\vrule width 0pt height '.(.8*$rows).'em depth 0pt';
  479   $rule = '\rule 0pt '.(.8*$rows).'em 0pt' if $displayMode eq 'HTML_jsMath';
  480   $delim = '\\'.$delim if $delim eq '{' || $delim eq '}';
  481   return '\(\left'.$delim.$rule.'\right.\)';
  482 }
  483 
  484 #
  485 #  Data for tth delimiters [top,mid,bot,rep]
  486 #
  487 my %tth_delim = (
  488   '[' => ['&#xF8EE;','','&#xF8F0;','&#xF8EF;'],
  489   ']' => ['&#xF8F9;','','&#xF8FB;','&#xF8FA;'],
  490   '(' => ['&#xF8EB;','','&#xF8ED;','&#xF8EC;'],
  491   ')' => ['&#xF8F6;','','&#xF8F8;','&#xF8F7;'],
  492   '{' => ['&#xF8F1;','&#xF8F2;','&#xF8F3;','&#xF8F4;'],
  493   '}' => ['&#xF8FC;','&#xF8FD;','&#xF8FE;','&#xF8F4;'],
  494   '|' => ['|','','|','|'],
  495   '<' => ['&lt;'],
  496   '>' => ['&gt;'],
  497   '\lgroup' => ['&#xF8F1;','','&#xF8F3;','&#xF8F4;'],
  498   '\rgroup' => ['&#xF8FC;','','&#xF8FE;','&#xF8F4;'],
  499 );
  500 
  501 #
  502 #  Make delimiters as stacks of characters
  503 #
  504 sub format_delimiter_tth {
  505   my $self = shift;
  506   my $delim = shift; my $rows = shift; my $tth = shift;
  507   return '' if $delim eq '' || !defined($tth_delim{$delim});
  508   my $c = $delim; $delim = $tth_delim{$delim};
  509   $c = $delim->[0] if scalar(@{$delim}) == 1;
  510   my $size = ($tth? "": "font-size:175%; ");
  511   return '<SPAN STYLE="'.$size.'margin:0px 2px">'.$c.'</SPAN>'
  512     if $rows == 1 || scalar(@{$delim}) == 1;
  513   my $HTML = "";
  514   if ($delim->[1] eq '') {
  515     $HTML = join('<BR>',$delim->[0],($delim->[3])x(2*($rows-1)),$delim->[2]);
  516   } else {
  517     $HTML = join('<BR>',$delim->[0],($delim->[3])x($rows-1),
  518             $delim->[1],($delim->[3])x($rows-1),
  519             $delim->[2]);
  520   }
  521   return '<DIV STYLE="line-height:90%; margin: 0px 2px">'.$HTML.'</DIV>';
  522 }
  523 
  524 
  525 #
  526 #  Look up the values of the answer array entries, and check them
  527 #  for syntax and other errors.  Build the student answer
  528 #  based on these, and keep track of error messages.
  529 #
  530 
  531 my @ans_cmp_defaults = (showCoodinateHints => 0, checker => sub {0});
  532 
  533 sub ans_collect {
  534   my $self = shift; my $ans = shift;
  535   my $inputs = $self->getPG('$inputs_ref');
  536   my $blank = ($self->getPG('$displayMode') eq 'TeX') ? '\_\_' : '__';
  537   my ($rows,$cols) = ($self->{ans_rows},$self->{ans_cols});
  538   my @array = (); my $data = [$self->value]; my $errors = []; my $OK = 1;
  539   if ($self->{ColumnVector}) {foreach my $x (@{$data}) {$x = [$x]}}
  540   $data = [$data] unless ref($data->[0]) eq 'ARRAY';
  541   foreach my $i (0..$rows-1) {
  542     my @row = (); my $entry;
  543     foreach my $j (0..$cols-1) {
  544       if ($i || $j) {
  545   $entry = $inputs->{ANS_NAME($self->{ans_name},$i,$j)};
  546       } else {
  547   $entry = $ans->{original_student_ans};
  548   $ans->{student_formula} = $ans->{student_value} = undef unless $entry =~ m/\S/;
  549       }
  550       my $result = $data->[$i][$j]->cmp(@ans_cmp_defaults)->evaluate($entry);
  551       $OK &= entryCheck($result,$blank);
  552       push(@row,$result->{student_formula});
  553       entryMessage($result->{ans_message},$errors,$i,$j,$rows,$cols);
  554     }
  555     push(@array,[@row]);
  556   }
  557   $ans->{student_formula} = [@array];
  558   $ans->{ans_message} = $ans->{error_message} = "";
  559   if (scalar(@{$errors})) {
  560     $ans->{ans_message} = $ans->{error_message} =
  561       '<TABLE BORDER="0" CELLSPACING="0" CELLPADDING="0" CLASS="ArrayLayout">'.
  562       join('<TR><TD HEIGHT="4"></TD></TR>',@{$errors}).
  563       '</TABLE>';
  564     $OK = 0;
  565   }
  566   return $OK;
  567 }
  568 
  569 sub entryMessage {
  570   my $message = shift; return unless $message;
  571   my ($errors,$i,$j,$rows,$cols) = @_; $i++; $j++;
  572   my $title;
  573   if ($rows == 1) {$title = "In entry $j"}
  574   elsif ($cols == 1) {$title = "In entry $i"}
  575   else {$title = "In entry ($i,$j)"}
  576   push(@{$errors},"<TR VALIGN=\"TOP\"><TD NOWRAP STYLE=\"text-align:right; border:0px\"><I>$title</I>:&nbsp;</TD>".
  577                   "<TD STYLE=\"text-align:left; border:0px\">$message</TD></TR>");
  578 }
  579 
  580 sub entryCheck {
  581   my $ans = shift; my $blank = shift;
  582   return 1 if defined($ans->{student_value});
  583   if (!defined($ans->{student_formula})) {
  584     $ans->{student_formula} = $ans->{student_ans};
  585     $ans->{student_formula} = $blank unless $ans->{student_formula};
  586   }
  587   return 0
  588 }
  589 
  590 
  591 #
  592 #  Get and Set values in context
  593 #
  594 sub contextSet {
  595   my $context = shift; my %set = (@_);
  596   my $flags = $context->{flags}; my $get = {};
  597   foreach my $id (keys %set) {$get->{$id} = $flags->{$id}; $flags->{$id} = $set{$id}}
  598   return $get;
  599 }
  600 
  601 #
  602 #  Quote HTML characters
  603 #
  604 sub protectHTML {
  605   my $string = shift;
  606   return unless defined($string);
  607   return $string if eval ('$main::displayMode') eq 'TeX';
  608   $string =~ s/&/\&amp;/g;
  609   $string =~ s/</\&lt;/g;
  610   $string =~ s/>/\&gt;/g;
  611   $string;
  612 }
  613 
  614 #
  615 #  Convert newlines to <BR>
  616 #
  617 sub preformat {
  618   my $string = protectHTML(shift);
  619   $string =~ s!\n!<br />!g unless eval('$main::displayMode') eq 'TeX';
  620   $string;
  621 }
  622 
  623 #
  624 #  names for numbers
  625 #
  626 sub NameForNumber {
  627   my $self = shift; my $n = shift;
  628   my $name =  ('zeroth','first','second','third','fourth','fifth',
  629                'sixth','seventh','eighth','ninth','tenth')[$n];
  630   $name = "$n-th" if ($n > 10);
  631   return $name;
  632 }
  633 
  634 #
  635 #  Get a value from the safe compartment
  636 #
  637 sub getPG {
  638   my $self = shift;
  639 #  (WeBWorK::PG::Translator::PG_restricted_eval(shift))[0];
  640   eval ('package main; '.shift);  # faster
  641 }
  642 
  643 #############################################################
  644 #############################################################
  645 
  646 =head3 Value::Real
  647 
  648   Usage ANS( Real(3.56)->cmp() )
  649     Compares response to a real value using 'fuzzy' comparison
  650     compareOptions and default values:
  651         showTypeWarnings => 1,
  652         showEqualErrors  => 1,
  653         ignoreStrings    => 1,
  654 
  655 =cut
  656 
  657 
  658 package Value::Real;
  659 
  660 sub cmp_defaults {(
  661   shift->SUPER::cmp_defaults(@_),
  662   ignoreInfinity => 1,
  663 )}
  664 
  665 sub typeMatch {
  666   my $self = shift; my $other = shift; my $ans = shift;
  667   return 1 unless ref($other);
  668   return 0 if Value::isFormula($other);
  669   return 1 if $other->type eq 'Infinity' && $ans->{ignoreInfinity};
  670   $self->type eq $other->type;
  671 }
  672 
  673 #############################################################
  674 
  675 package Value::Infinity;
  676 
  677 sub cmp_class {'a Number'};
  678 
  679 sub typeMatch {
  680   my $self = shift; my $other = shift; my $ans = shift;
  681   return 1 unless ref($other);
  682   return 0 if Value::isFormula($other);
  683   return 1 if $other->type eq 'Number';
  684   $self->type eq $other->type;
  685 }
  686 
  687 #############################################################
  688 
  689 =head3 Value::String
  690 
  691   Usage:  $s = String("pole");
  692     ANS($s->cmp(typeMatch => Complex("4+i")));
  693         # compare to response 'pole', don't complain about complex number responses.
  694 
  695     compareOptions and default values:
  696       showTypeWarnings => 1,
  697       showEqualErrors  => 1,
  698       ignoreStrings    => 1   # don't complain about string-valued responses
  699       typeMatch        => 'Value::Real'
  700 
  701   Initial and final spaces are ignored when comparing strings.
  702 
  703 =cut
  704 
  705 package Value::String;
  706 
  707 sub cmp_defaults {(
  708   Value::Real->cmp_defaults(@_),
  709   typeMatch => 'Value::Real',
  710 )}
  711 
  712 sub cmp_class {
  713   my $self = shift; my $ans = shift; my $typeMatch = $ans->{typeMatch};
  714   return 'a Word' if !Value::isValue($typeMatch) || $typeMatch->classMatch('String');
  715   return $typeMatch->cmp_class;
  716 };
  717 
  718 sub typeMatch {
  719   my $self = shift; my $other = shift; my $ans = shift;
  720   my $typeMatch = $ans->{typeMatch};
  721   return &$typeMatch($other,$ans) if ref($typeMatch) eq 'CODE';
  722   return 1 if !Value::isValue($typeMatch) || $typeMatch->classMatch('String') ||
  723                  $self->type eq $other->type;
  724   return $typeMatch->typeMatch($other,$ans);
  725 }
  726 
  727 #
  728 #  Remove the blank-check prefilter when the string is empty,
  729 #  and add a filter that removes leading and trailing whitespace.
  730 #
  731 sub cmp {
  732   my $self = shift;
  733   my $cmp = $self->SUPER::cmp(@_);
  734   if ($self->value =~ m/^\s*$/) {
  735     $cmp->install_pre_filter('erase');
  736     $cmp->install_pre_filter(sub {
  737       my $ans = shift;
  738       $ans->{student_ans} =~ s/^\s+//g;
  739       $ans->{student_ans} =~ s/\s+$//g;
  740       return $ans;
  741     });
  742   }
  743   return $cmp;
  744 }
  745 
  746 #############################################################
  747 
  748 =head3 Value::Point
  749 
  750   Usage: $pt = Point("(3,6)"); # preferred
  751          or $pt = Point(3,6);
  752          or $pt = Point([3,6]);
  753          ANS($pt->cmp());
  754 
  755     compareOptions:
  756       showTypeWarnings => 1,   # warns if student response is of incorrect type
  757       showEqualErrors  => 1,
  758       ignoreStrings    => 1,
  759       showDimensionHints => 1, # reports incorrect number of coordinates
  760       showCoordinateHints =>1, # flags individual coordinates that are incorrect
  761 
  762 =cut
  763 
  764 package Value::Point;
  765 
  766 sub cmp_defaults {(
  767   shift->SUPER::cmp_defaults(@_),
  768   showDimensionHints => 1,
  769   showCoordinateHints => 1,
  770 )}
  771 
  772 sub typeMatch {
  773   my $self = shift; my $other = shift; my $ans = shift;
  774   return ref($other) && $other->type eq 'Point' && !$other->isFormula;
  775 }
  776 
  777 #
  778 #  Check for dimension mismatch and incorrect coordinates
  779 #
  780 sub cmp_postprocess {
  781   my $self = shift; my $ans = shift;
  782   return unless $ans->{score} == 0 && !$ans->{isPreview};
  783   my $student = $ans->{student_value};
  784   return if $ans->{ignoreStrings} && (!Value::isValue($student) || $student->type eq 'String');
  785   if ($ans->{showDimensionHints} && $self->length != $student->length) {
  786     $self->cmp_Error($ans,"The number of coordinates is incorrect"); return;
  787   }
  788   if ($ans->{showCoordinateHints}) {
  789     my @errors;
  790     foreach my $i (1..$self->length) {
  791       push(@errors,"The ".$self->NameForNumber($i)." coordinate is incorrect")
  792   if ($self->{data}[$i-1] != $student->{data}[$i-1]);
  793     }
  794     $self->cmp_Error($ans,@errors); return;
  795   }
  796 }
  797 
  798 sub correct_ans {
  799   my $self = shift;
  800   return $self->SUPER::correct_ans unless $self->{ans_name};
  801   Value::VERBATIM($self->format_matrix([[@{$self->{data}}]],@{$self->{format_options}},tth_delims=>1));
  802 }
  803 
  804 sub ANS_MATRIX {
  805   my $self = shift;
  806   my $extend = shift; my $name = shift;
  807   my $size = shift || 5;
  808   my $def = $self->context->lists->get('Point');
  809   my $open = $self->{open} || $def->{open}; my $close = $self->{close} || $def->{close};
  810   $self->ans_matrix($extend,$name,1,$self->length,$size,$open,$close,',');
  811 }
  812 
  813 sub ans_array {my $self = shift; $self->ANS_MATRIX(0,'',@_)}
  814 sub named_ans_array {my $self = shift; $self->ANS_MATRIX(0,@_)}
  815 sub named_ans_array_extension {my $self = shift; $self->ANS_MATRIX(1,@_)}
  816 
  817 #############################################################
  818 
  819 =head3 Value::Vector
  820 
  821   Usage:  $vec = Vector("<3,6,7>");
  822           or $vec = Vector(3,6,7);
  823           or $vec = Vector([3,6,7]);
  824           ANS($vec->cmp());
  825 
  826     compareOptions:
  827       showTypeWarnings    => 1,   # warns if student response is of incorrect type
  828       showEqualErrors     => 1,
  829       ignoreStrings       => 1,
  830       showDimensionHints  => 1, # reports incorrect number of coordinates
  831       showCoordinateHints => 1, # flags individual coordinates which are incorrect
  832       promotePoints       => 0, # allow students to enter vectors as points (3,5,6)
  833       parallel            => 1, # response is correct if it is parallel to correct answer
  834       sameDirection       => 1, # response is correct if it has same orientation as correct answer
  835                                 #  (only has an effect when parallel => 1 is specified)
  836 
  837 
  838 =cut
  839 
  840 package Value::Vector;
  841 
  842 sub cmp_defaults {(
  843   shift->SUPER::cmp_defaults(@_),
  844   showDimensionHints => 1,
  845   showCoordinateHints => 1,
  846   promotePoints => 0,
  847   parallel => 0,
  848   sameDirection => 0,
  849 )}
  850 
  851 sub typeMatch {
  852   my $self = shift; my $other = shift; my $ans = shift;
  853   return 0 unless ref($other) && !$other->isFormula;
  854   return $other->type eq 'Vector' ||
  855      ($ans->{promotePoints} && $other->type eq 'Point');
  856 }
  857 
  858 #
  859 #  check for dimension mismatch
  860 #        for parallel vectors, and
  861 #        for incorrect coordinates
  862 #
  863 sub cmp_postprocess {
  864   my $self = shift; my $ans = shift;
  865   return unless $ans->{score} == 0 && !$ans->{isPreview};
  866   my $student = $ans->{student_value};
  867   return if $ans->{ignoreStrings} && (!Value::isValue($student) || $student->type eq 'String');
  868   if ($self->length != $student->length) {
  869     ($self,$student) = $self->cmp_pad($student);
  870     if ($ans->{showDimensionHints} && $self->length != $student->length) {
  871       $self->cmp_Error($ans,"The number of coordinates is incorrect"); return;
  872     }
  873   }
  874   if ($ans->{parallel} && !$student->isFormula && !$student->classMatch('String') &&
  875       $self->isParallel($student,$ans->{sameDirection})) {
  876     $ans->score(1); return;
  877   }
  878   if ($ans->{showCoordinateHints} && !$ans->{parallel}) {
  879     my @errors;
  880     foreach my $i (1..$self->length) {
  881       push(@errors,"The ".$self->NameForNumber($i)." coordinate is incorrect")
  882   if ($self->{data}[$i-1] != $student->{data}[$i-1]);
  883     }
  884     $self->cmp_Error($ans,@errors); return;
  885   }
  886 }
  887 
  888 #
  889 #  Pad the student or correct answer if either is in ijk notation
  890 #  and they are not the same dimension.  Only add zeros when the other one
  891 #  also has zeros in those places.
  892 #
  893 sub cmp_pad {
  894   my $self = shift; my $student = shift;
  895   if (($self->getFlag("ijk") || $student->getFlag("ijk")) && $self->getFlag("ijkAnyDimension")) {
  896     $self = $self->copy; $student = $student->copy;
  897     while ($self->length > $student->length && $self->{data}[$student->length] == 0)
  898       {push(@{$student->{data}},Value::Real->new(0))}
  899     while ($self->length < $student->length && $student->{data}[$self->length] == 0)
  900       {push(@{$self->{data}},Value::Real->new(0))}
  901   }
  902   return ($self,$student);
  903 }
  904 
  905 sub correct_ans {
  906   my $self = shift;
  907   return $self->SUPER::correct_ans unless $self->{ans_name};
  908   return Value::VERBATIM($self->format_matrix([[$self->value]],@{$self->{format_options}},tth_delims=>1))
  909     unless $self->{ColumnVector};
  910   my @array = (); foreach my $x ($self->value) {push(@array,[$x])}
  911   return Value::VERBATIM($self->format_matrix([@array],@{$self->{format_options}},tth_delims=>1));
  912 }
  913 
  914 sub ANS_MATRIX {
  915   my $self = shift;
  916   my $extend = shift; my $name = shift;
  917   my $size = shift || 5; my ($def,$open,$close);
  918   $def = $self->context->lists->get('Matrix');
  919   $open = $self->{open} || $def->{open}; $close = $self->{close} || $def->{close};
  920   return $self->ans_matrix($extend,$name,$self->length,1,$size,$open,$close)
  921     if ($self->{ColumnVector});
  922   $def = $self->context->lists->get('Vector');
  923   $open = $self->{open} || $def->{open}; $close = $self->{close} || $def->{close};
  924   $self->ans_matrix($extend,$name,1,$self->length,$size,$open,$close,',');
  925 }
  926 
  927 sub ans_array {my $self = shift; $self->ANS_MATRIX(0,'',@_)}
  928 sub named_ans_array {my $self = shift; $self->ANS_MATRIX(0,@_)}
  929 sub named_ans_array_extension {my $self = shift; $self->ANS_MATRIX(1,@_)}
  930 
  931 
  932 #############################################################
  933 
  934 =head3 Value::Matrix
  935 
  936   Usage   $ma = Matrix([[3,6],[2,5]]) or $ma =Matrix([3,6],[2,5])
  937           ANS($ma->cmp());
  938 
  939     compareOptions:
  940 
  941       showTypeWarnings    => 1, # warns if student response is of incorrect type
  942       showEqualErrors     => 1, # reports messages that occur during element comparisons
  943       ignoreStrings       => 1,
  944       showDimensionHints  => 1, # reports incorrect number of coordinates
  945       showCoordinateHints => 1, # flags individual coordinates which are incorrect
  946 
  947 
  948 =cut
  949 
  950 package Value::Matrix;
  951 
  952 sub cmp_defaults {(
  953   shift->SUPER::cmp_defaults(@_),
  954   showDimensionHints => 1,
  955   showEqualErrors => 0,
  956 )}
  957 
  958 sub typeMatch {
  959   my $self = shift; my $other = shift; my $ans = shift;
  960   return 0 unless ref($other) && !$other->isFormula;
  961   return $other->type eq 'Matrix' ||
  962     ($other->type =~ m/^(Point|list)$/ &&
  963      $other->{open}.$other->{close} eq $self->{open}.$self->{close});
  964 }
  965 
  966 sub cmp_preprocess {
  967   my $self = shift; my $ans = shift;
  968   my $student = $ans->{student_value};
  969   return if $student->type ne 'Matrix';
  970   my @d1 = $self->dimensions; my @d2 = $student->dimensions;
  971   $ans->{student_value} = $student->make([$student->value])
  972     if (scalar(@d2) == 1 && scalar(@d1) == 2);
  973 }
  974 
  975 sub cmp_postprocess {
  976   my $self = shift; my $ans = shift;
  977   return unless $ans->{score} == 0 &&
  978     !$ans->{isPreview} && $ans->{showDimensionHints};
  979   my $student = $ans->{student_value};
  980   return if $ans->{ignoreStrings} && (!Value::isValue($student) || $student->type eq 'String');
  981   my @d1 = $self->dimensions; my @d2 = $student->dimensions;
  982   if (scalar(@d1) != scalar(@d2)) {
  983     $self->cmp_Error($ans,"Matrix dimension is not correct");
  984     return;
  985   } else {
  986     foreach my $i (0..scalar(@d1)-1) {
  987       if ($d1[$i] != $d2[$i]) {
  988   $self->cmp_Error($ans,"Matrix dimension is not correct");
  989   return;
  990       }
  991     }
  992   }
  993 }
  994 
  995 sub correct_ans {
  996   my $self = shift;
  997   return $self->SUPER::correct_ans unless $self->{ans_name};
  998   my @array = $self->value; @array = ([@array]) if $self->isRow;
  999   Value::VERBATIM($self->format_matrix([$self->value],@{$self->{format_options}},tth_delims=>1));
 1000 }
 1001 
 1002 sub ANS_MATRIX {
 1003   my $self = shift;
 1004   my $extend = shift; my $name = shift;
 1005   my $size = shift || 5;
 1006   my $def = $self->context->lists->get('Matrix');
 1007   my $open = $self->{open} || $def->{open}; my $close = $self->{close} || $def->{close};
 1008   my @d = $self->dimensions;
 1009   Value::Error("Can't create ans_array for %d-dimensional matrix",scalar(@d))
 1010     if (scalar(@d) > 2);
 1011   @d = (1,@d) if (scalar(@d) == 1);
 1012   $self->ans_matrix($extend,$name,@d,$size,$open,$close,'');
 1013 }
 1014 
 1015 sub ans_array {my $self = shift; $self->ANS_MATRIX(0,'',@_)}
 1016 sub named_ans_array {my $self = shift; $self->ANS_MATRIX(0,@_)}
 1017 sub named_ans_array_extension {my $self = shift; $self->ANS_MATRIX(1,@_)}
 1018 
 1019 #############################################################
 1020 
 1021 =head3   Value::Interval
 1022 
 1023   Usage:    $interval = Interval("(1,2]");
 1024             or $interval = Interval('(',1,2,']');
 1025             ANS($inteval->cmp);
 1026 
 1027       compareOptions and defaults:
 1028       showTypeWarnings  => 1,
 1029       showEqualErrors   => 1,
 1030       ignoreStrings     => 1,
 1031       showEndpointHints => 1, # show hints about which end point values are correct
 1032       showEndTypeHints  => 1, # show hints about endpoint types
 1033       requireParenMatch => 1,
 1034 
 1035 
 1036 =cut
 1037 
 1038 package Value::Interval;
 1039 
 1040 sub cmp_defaults {(
 1041   shift->SUPER::cmp_defaults(@_),
 1042   showEndpointHints => 1,
 1043   showEndTypeHints => 1,
 1044   requireParenMatch => 1,
 1045 )}
 1046 
 1047 sub typeMatch {
 1048   my $self = shift; my $other = shift;
 1049   return 0 if !Value::isValue($other) || $other->isFormula;
 1050   return $other->canBeInUnion;
 1051 }
 1052 
 1053 #
 1054 #  Check for unreduced sets and unions
 1055 #
 1056 sub cmp_compare {
 1057   my $self = shift; my $student = shift; my $ans = shift;
 1058   my $error = $self->cmp_checkUnionReduce($student,$ans,@_);
 1059   if ($error) {$self->context->setError($error,'',undef,undef,$CMP_WARNING); return}
 1060   $self->SUPER::cmp_compare($student,$ans,@_);
 1061 }
 1062 
 1063 #
 1064 #  Check for wrong enpoints and wrong type of endpoints
 1065 #
 1066 sub cmp_postprocess {
 1067   my $self = shift; my $ans = shift;
 1068   return unless $ans->{score} == 0 && !$ans->{isPreview};
 1069   my $other = $ans->{student_value};
 1070   return if $ans->{ignoreStrings} && (!Value::isValue($other) || $other->type eq 'String');
 1071   return unless $other->classMatch('Interval');
 1072   my @errors;
 1073   if ($ans->{showEndpointHints}) {
 1074     push(@errors,"Your left endpoint is incorrect")
 1075       if ($self->{data}[0] != $other->{data}[0]);
 1076     push(@errors,"Your right endpoint is incorrect")
 1077       if ($self->{data}[1] != $other->{data}[1]);
 1078   }
 1079   if (scalar(@errors) == 0 && $ans->{showEndTypeHints} && $ans->{requireParenMatch}) {
 1080     push(@errors,"The type of interval is incorrect")
 1081       if ($self->{open}.$self->{close} ne $other->{open}.$other->{close});
 1082   }
 1083   $self->cmp_Error($ans,@errors);
 1084 }
 1085 
 1086 #############################################################
 1087 
 1088 =head3 Value::Set
 1089 
 1090   Usage:   $set = Set(5,6,'a', 'b')
 1091         or $set = Set("{5, 6, a, b}")
 1092 
 1093         The object is a finite set of real numbers. It can be used with Union and
 1094         Interval.
 1095 
 1096   Examples:  Interval("(-inf,inf)") - Set(0)
 1097              Compute("R-{0}")   # in Interval context: Context("Interval");
 1098 
 1099 =cut
 1100 
 1101 package Value::Set;
 1102 
 1103 sub typeMatch {
 1104   my $self = shift; my $other = shift;
 1105   return 0 if !Value::isValue($other) || $other->isFormula;
 1106   return $other->canBeInUnion;
 1107 }
 1108 
 1109 #
 1110 #  Use the List checker for sets, in order to get
 1111 #  partial credit.  Set the various types for error
 1112 #  messages.
 1113 #
 1114 sub cmp_defaults {(
 1115   Value::List::cmp_defaults(@_),
 1116   typeMatch => 'Value::Real',
 1117   list_type => 'a set',
 1118   entry_type => 'a number',
 1119   removeParens => 0,
 1120   showParenHints => 1,
 1121   implicitList => 0,
 1122 )}
 1123 
 1124 #
 1125 #  Use the list checker if the student answer is a set
 1126 #    otherwise use the standard compare (to get better
 1127 #    error messages).
 1128 #
 1129 sub cmp_equal {
 1130   my ($self,$ans) = @_;
 1131   return $self->SUPER::cmp_equal($ans) unless $ans->{student_value}->type eq 'Set';
 1132   my $error = $self->cmp_checkUnionReduce($ans->{student_value},$ans);
 1133   if ($error) {$self->cmp_Error($ans,$error); return}
 1134   return Value::List::cmp_equal(@_);
 1135 }
 1136 
 1137 #
 1138 #  Check for unreduced sets and unions
 1139 #
 1140 sub cmp_compare {
 1141   my $self = shift; my $student = shift; my $ans = shift;
 1142   my $error = $self->cmp_checkUnionReduce($student,$ans,@_);
 1143   if ($error) {$self->context->setError($error,'',undef,undef,$CMP_WARNING); return}
 1144   $self->SUPER::cmp_compare($student,$ans,@_);
 1145 }
 1146 
 1147 #############################################################
 1148 
 1149 =head3 Value::Union
 1150 
 1151   Usage: $union = Union("[4,5] U [6,7]");
 1152          or $union = Union(Interval("[4,5]",Interval("[6,7]"));
 1153          ANS($union->cmp());
 1154 
 1155 
 1156 =cut
 1157 
 1158 package Value::Union;
 1159 
 1160 sub typeMatch {
 1161   my $self = shift; my $other = shift;
 1162   return 0 unless ref($other) && !$other->isFormula;
 1163   return $other->length == 2 &&
 1164          ($other->{open} eq '(' || $other->{open} eq '[') &&
 1165          ($other->{close} eq ')' || $other->{close} eq ']')
 1166      if $other->type =~ m/^(Point|List)$/;
 1167   $other->isSetOfReals;
 1168 }
 1169 
 1170 #
 1171 #  Use the List checker for unions, in order to get
 1172 #  partial credit.  Set the various types for error
 1173 #  messages.
 1174 #
 1175 sub cmp_defaults {(
 1176   Value::List::cmp_defaults(@_),
 1177   typeMatch => 'Value::Interval',
 1178   list_type => 'an interval, set or union',
 1179   short_type => 'a union',
 1180   entry_type => 'an interval or set',
 1181 )}
 1182 
 1183 sub cmp_equal {
 1184   my $self = shift; my $ans = shift;
 1185   my $error = $self->cmp_checkUnionReduce($ans->{student_value},$ans);
 1186   if ($error) {$self->cmp_Error($ans,$error); return}
 1187   Value::List::cmp_equal($self,$ans);
 1188 }
 1189 
 1190 #
 1191 #  Check for unreduced sets and unions
 1192 #
 1193 sub cmp_compare {
 1194   my $self = shift; my $student = shift; my $ans = shift;
 1195   my $error = $self->cmp_checkUnionReduce($student,$ans,@_);
 1196   if ($error) {$self->context->setError($error,'',undef,undef,$CMP_WARNING); return}
 1197   $self->SUPER::cmp_compare($student,$ans,@_);
 1198 }
 1199 
 1200 #############################################################
 1201 
 1202 =head3 Value::List
 1203 
 1204   Usage:  $lst = List("1, x, <4,5,6>"); # list of a real, a formula and a vector.
 1205           or $lst = List(Real(1), Formula("x"), Vector(4,5,6));
 1206           ANS($lst->cmp(showHints=>1));
 1207 
 1208     compareOptions and defaults:
 1209       showTypeWarnings => 1,
 1210       showEqualErrors  => 1,         # show errors produced when checking equality of entries
 1211       ignoreStrings    => 1,         # don't show type warnings for strings
 1212       studentsMustReduceUnions => 1,
 1213       showUnionReduceWarnings => 1,
 1214       showHints => undef,            # automatically set to 1 if $showPartialCorrectAnswers == 1
 1215       showLengthHints => undef,      # automatically set to 1 if $showPartialCorrectAnswers == 1
 1216       showParenHints => undef,       # automatically set to 1 if $showPartialCorrectAnswers == 1
 1217       partialCredit => undef,        # automatically set to 1 if $showPartialCorrectAnswers == 1
 1218       ordered => 0,                  # 1 = must be in same order as correct answer
 1219       entry_type => undef,           # determined from first entry
 1220       list_type => undef,            # determined automatically
 1221       typeMatch => $element,         # used for type checking the entries
 1222       firstElement => $element,
 1223       extra => undef,                # used to check syntax of incorrect answers
 1224       requireParenMatch => 1,        # student parens must match correct parens
 1225       removeParens => 1,             # remove outermost parens, if any
 1226       implicitList => 1,             # force single answers to be lists (even if they ARE lists)
 1227 
 1228 
 1229 =cut
 1230 
 1231 package Value::List;
 1232 
 1233 sub cmp_defaults {
 1234   my $self = shift;
 1235   my %options = (@_);
 1236   my $element = Value::makeValue($self->{data}[0],context=>$self->context);
 1237   $element = $self->Package("Formula")->new($element) unless Value::isValue($element);
 1238   return (
 1239     Value::Real->cmp_defaults(@_),
 1240     showHints => undef,
 1241     showLengthHints => undef,
 1242     showParenHints => undef,
 1243     partialCredit => undef,
 1244     ordered => 0,
 1245     entry_type => undef,
 1246     list_type => undef,
 1247     typeMatch => $element,
 1248     firstElement => $element,
 1249     extra => undef,
 1250     requireParenMatch => 1,
 1251     removeParens => 1,
 1252     implicitList => 1,
 1253   );
 1254 }
 1255 
 1256 #
 1257 #  Match anything but formulas
 1258 #
 1259 sub typeMatch {return !ref($other) || !$other->isFormula}
 1260 
 1261 #
 1262 #  Handle removal of outermost parens in correct answer.
 1263 #
 1264 sub cmp {
 1265   my $self = shift;
 1266   my %params = @_;
 1267   my $cmp = $self->SUPER::cmp(@_);
 1268   if ($cmp->{rh_ans}{removeParens}) {
 1269     $self->{open} = $self->{close} = '';
 1270     $cmp->ans_hash(correct_ans => $self->stringify)
 1271       unless defined($self->{correct_ans}) || defined($params{correct_ans});
 1272   }
 1273   return $cmp;
 1274 }
 1275 
 1276 sub cmp_equal {
 1277   my $self = shift; my $ans = shift;
 1278   $ans->{showPartialCorrectAnswers} = $self->getPG('$showPartialCorrectAnswers');
 1279 
 1280   #
 1281   #  get the paramaters
 1282   #
 1283   my $showHints         = getOption($ans,'showHints');
 1284   my $showLengthHints   = getOption($ans,'showLengthHints');
 1285   my $showParenHints    = getOption($ans,'showParenHints');
 1286   my $partialCredit     = getOption($ans,'partialCredit');
 1287   my $requireParenMatch = $ans->{requireParenMatch};
 1288   my $implicitList      = $ans->{implicitList};
 1289   my $typeMatch         = $ans->{typeMatch};
 1290   my $value             = $ans->{entry_type};
 1291   my $ltype             = $ans->{list_type} || lc($self->type);
 1292   my $stype             = $ans->{short_type} || $ltype;
 1293 
 1294   $value = (Value::isValue($typeMatch)? lc($typeMatch->cmp_class): 'a value')
 1295     unless defined($value);
 1296   $value =~ s/(real|complex) //; $ans->{cmp_class} = $value;
 1297   $value =~ s/^an? //; $value = 'formula' if $value =~ m/formula/;
 1298   $ltype =~ s/^an? //; $stype =~ s/^an? //;
 1299   $showHints = $showLengthHints = 0 if $ans->{isPreview};
 1300 
 1301   #
 1302   #  Get the lists of correct and student answers
 1303   #   (split formulas that return lists or unions)
 1304   #
 1305   my @correct = (); my ($cOpen,$cClose);
 1306   if (!$self->isFormula) {
 1307     @correct = $self->value;
 1308     $cOpen = $ans->{correct_value}{open}; $cClose = $ans->{correct_value}{close};
 1309   } else {
 1310     @correct = Value::List->splitFormula($self,$ans);
 1311     $cOpen = $self->{tree}{open}; $cClose = $self->{tree}{close};
 1312   }
 1313   my $student = $ans->{student_value}; my @student = ($student);
 1314   my ($sOpen,$sClose) = ('','');
 1315   if (Value::isFormula($student) && $student->type eq $self->type) {
 1316     if ($implicitList && $student->{tree}{open} ne '') {
 1317       @student = ($student);
 1318     } else {
 1319       @student = Value::List->splitFormula($student,$ans);
 1320       $sOpen = $student->{tree}{open}; $sClose = $student->{tree}{close};
 1321     }
 1322   } elsif (!$student->isFormula && $student->classMatch($self->type)) {
 1323     if ($implicitList && $student->{open} ne '') {
 1324       @student = ($student);
 1325     } else {
 1326       @student = @{$student->{data}};
 1327       $sOpen = $student->{open}; $sClose = $student->{close};
 1328     }
 1329   }
 1330   foreach my $x (@correct) {$x->{equation} = $self};
 1331   foreach my $x (@student) {$x->{equation} = $self};
 1332   return if $ans->{split_error};
 1333   #
 1334   #  Check for parenthesis match
 1335   #
 1336   if ($requireParenMatch && ($sOpen ne $cOpen || $sClose ne $cClose)) {
 1337     if ($showParenHints && !($ans->{ignoreStrings} && $student->type eq 'String')) {
 1338       my $message = "The parentheses for your $ltype ";
 1339       if (($cOpen || $cClose) && ($sOpen || $sClose))
 1340                                 {$message .= "are of the wrong type"}
 1341       elsif ($sOpen || $sClose) {$message .= "should be removed"}
 1342       else                      {$message .= "seem to be missing"}
 1343       $self->cmp_Error($ans,$message) unless $ans->{isPreview};
 1344     }
 1345     return;
 1346   }
 1347 
 1348   #
 1349   #  Determine the maximum score
 1350   #
 1351   my $M = scalar(@correct);
 1352   my $m = scalar(@student);
 1353   my $maxscore = ($m > $M)? $m : $M;
 1354 
 1355   #
 1356   #  Compare the two lists
 1357   #  (Handle errors in user-supplied functions)
 1358   #
 1359   my ($score,@errors);
 1360   if (ref($ans->{list_checker}) eq 'CODE') {
 1361     eval {($score,@errors) = &{$ans->{list_checker}}([@correct],[@student],$ans,$value)};
 1362     if (!defined($score)) {
 1363       die $@ if $@ ne '' && $self->{context}{error}{flag} == 0;
 1364       $self->cmp_error($ans) if $self->{context}{error}{flag};
 1365     }
 1366   } else {
 1367     ($score,@errors) = $self->cmp_list_compare([@correct],[@student],$ans,$value);
 1368   }
 1369   return unless defined($score);
 1370 
 1371   #
 1372   #  Give hints about extra or missing answers
 1373   #
 1374   if ($showLengthHints) {
 1375     $value =~ s/( or|,) /s$1 /g; # fix "interval or union"
 1376     push(@errors,"There should be more ${value}s in your $stype")
 1377       if ($score < $maxscore && $score == $m);
 1378     push(@errors,"There should be fewer ${value}s in your $stype")
 1379       if ($score < $maxscore && $score == $M && !$showHints);
 1380   }
 1381 
 1382   #
 1383   #  If all the entries are in error, don't give individual messages
 1384   #
 1385   if ($score == 0) {
 1386     my $i = 0;
 1387     while ($i <= $#errors) {
 1388       if ($errors[$i++] =~ m/^Your .* is incorrect$/)
 1389         {splice(@errors,--$i,1)}
 1390     }
 1391   }
 1392 
 1393   #
 1394   #  Finalize the score
 1395   #
 1396   $score = 0 if ($score != $maxscore && !$partialCredit);
 1397   $ans->score($score/$maxscore);
 1398   push(@errors,"Score = $ans->{score}") if $ans->{debug};
 1399   my $error = join("\n",@errors); $error =~ s!</DIV>\n!</DIV>!g;
 1400   $ans->{error_message} = $ans->{ans_message} = $error;
 1401 }
 1402 
 1403 #
 1404 #  Compare the contents of the list to see of they are equal
 1405 #
 1406 sub cmp_list_compare {
 1407   my $self = shift; my $context = $self->context;
 1408   my $correct = shift; my $student = shift; my $ans = shift; my $value = shift;
 1409   my @correct = @{$correct}; my @student = @{$student}; my $m = scalar(@student);
 1410   my $ordered = $ans->{ordered};
 1411   my $showTypeWarnings = $ans->{showTypeWarnings} && !$ans->{isPreview};
 1412   my $typeMatch = $ans->{typeMatch};
 1413   my $extra = defined($ans->{extra}) ? $ans->{extra} :
 1414               (Value::isValue($typeMatch) ? $typeMatch: $ans->{firstElement});
 1415   $extra = $self->Package("List")->new() unless defined($extra);
 1416   my $showHints = getOption($ans,'showHints') && !$ans->{isPreview};
 1417   my $error = $context->{error};
 1418   my $score = 0; my @errors; my $i = 0;
 1419 
 1420   #
 1421   #  Check for empty lists
 1422   #
 1423   if (scalar(@correct) == 0) {$ans->score($m == 0); return}
 1424 
 1425   #
 1426   #  Loop through student answers looking for correct ones
 1427   #
 1428   ENTRY: foreach my $entry (@student) {
 1429     $i++; $context->clearError;
 1430     $entry = Value::makeValue($entry,$context);
 1431     $entry = $self->Package("Formula")->new($entry) if !Value::isValue($entry);
 1432 
 1433     #
 1434     #  Some words differ if ther eis only one entry in the student's list
 1435     #
 1436     my $nth = ''; my $answer = 'answer';
 1437     my $class = $ans->{list_type} || $ans->{cmp_class};
 1438     if ($m > 1) {
 1439       $nth = ' '.$self->NameForNumber($i);
 1440       $class = $ans->{cmp_class};
 1441       $answer = 'value';
 1442     }
 1443 
 1444     #
 1445     #  See if the entry matches the correct answer
 1446     #  and perform syntax checking if not
 1447     #
 1448     if ($ordered) {
 1449       if (scalar(@correct)) {
 1450   if (shift(@correct)->cmp_compare($entry,$ans,$nth,$value)) {$score++; next ENTRY}
 1451       } else {
 1452   # do syntax check
 1453   if (ref($extra) eq 'CODE') {&$extra($entry,$ans,$nth,$value)}
 1454     else {$extra->cmp_compare($entry,$ans,$nth,$value)}
 1455       }
 1456       if ($error->{flag} == $CMP_ERROR) {$self->cmp_error($ans); return}
 1457     } else {
 1458       foreach my $k (0..$#correct) {
 1459   if ($correct[$k]->cmp_compare($entry,$ans,$nth,$value)) {
 1460     splice(@correct,$k,1);
 1461     $score++; next ENTRY;
 1462   }
 1463   if ($error->{flag} == $CMP_ERROR) {$self->cmp_error($ans); return}
 1464       }
 1465       $context->clearError;
 1466       # do syntax check
 1467       if (ref($extra) eq 'CODE') {&$extra($entry,$ans,$nth,$value)}
 1468         else {$extra->cmp_compare($entry,$ans,$nth,$value)}
 1469     }
 1470     #
 1471     #  Give messages about incorrect answers
 1472     #
 1473     my $match = (ref($typeMatch) eq 'CODE')? &$typeMatch($entry,$ans) :
 1474                                              $typeMatch->typeMatch($entry,$ans);
 1475     if ($showTypeWarnings && !$match &&
 1476   !($ans->{ignoreStrings} && $entry->classMatch('String'))) {
 1477       push(@errors,"Your$nth $answer isn't ".lc($class).
 1478      " (it looks like ".lc($entry->showClass).")");
 1479     } elsif ($error->{flag} && $ans->{showEqualErrors}) {
 1480       my $message = $error->{message}; $message =~ s/\s+$//;
 1481       if ($m > 1 && $error->{flag} != $CMP_WARNING) {
 1482         push(@errors,"<SMALL>There is a problem with your$nth $value:</SMALL>",
 1483                '<DIV STYLE="margin-left:1em">'.$message.'</DIV>');
 1484       } else {push(@errors,$message)}
 1485     } elsif ($showHints && $m > 1) {
 1486       push(@errors,"Your$nth $value is incorrect");
 1487     }
 1488   }
 1489 
 1490   #
 1491   #  Return the score and errors
 1492   #
 1493   return ($score,@errors);
 1494 }
 1495 
 1496 
 1497 
 1498 #
 1499 #  Split a formula that is a list or union into a
 1500 #    list of formulas (or Value objects).
 1501 #
 1502 sub splitFormula {
 1503   my $self = shift; my $formula = shift; my $ans = shift;
 1504   my @formula; my @entries;
 1505   if ($formula->type eq 'Union') {@entries = $formula->{tree}->makeUnion}
 1506     else {@entries = @{$formula->{tree}{coords}}}
 1507   foreach my $entry (@entries) {
 1508     my $v = Parser::Formula($entry);
 1509        $v = Parser::Evaluate($v) if (defined($v) && $v->isConstant);
 1510     $v->{equation} = $self;
 1511     push(@formula,$v);
 1512     #
 1513     #  There shouldn't be an error evaluating the formula,
 1514     #    but you never know...
 1515     #
 1516     if (!defined($v)) {$ans->{split_error} = 1; $self->cmp_error; return}
 1517   }
 1518   return @formula;
 1519 }
 1520 
 1521 #  Override for List ?
 1522 #  Return the value if it is defined, otherwise use a default
 1523 #
 1524 sub getOption {
 1525   my $ans = shift; my $name = shift;
 1526   my $value = $ans->{$name};
 1527   return $value if defined($value);
 1528   return $ans->{showPartialCorrectAnswers};
 1529 }
 1530 
 1531 #############################################################
 1532 
 1533 =head3  Value::Formula
 1534 
 1535   Usage: $fun = Formula("x^2-x+1");
 1536          $set = Formula("[-1, x) U (x, 2]");
 1537 
 1538   A formula can have any of the other math object types as its range.
 1539     Union, List, Number (Complex or Real),
 1540 
 1541 
 1542 =cut
 1543 
 1544 package Value::Formula;
 1545 
 1546 sub cmp_defaults {
 1547   my $self = shift;
 1548 
 1549   return (
 1550     Value::Union::cmp_defaults($self,@_),
 1551     typeMatch => $self->Package("Formula")->new("(1,2]"),
 1552     showDomainErrors => 1,
 1553   ) if $self->type eq 'Union';
 1554 
 1555   my $type = $self->type;
 1556   $type = ($self->isComplex)? 'Complex': 'Real' if $type eq 'Number';
 1557   $type = $self->Package($type).'::';
 1558 
 1559   return (
 1560     &{$type.'cmp_defaults'}($self,@_),
 1561     upToConstant => 0,
 1562     showDomainErrors => 1,
 1563   ) if defined(%$type) && $self->type ne 'List';
 1564 
 1565   my $element;
 1566   if ($self->{tree}->class eq 'List') {$element = $self->Package("Formula")->new($self->{tree}{coords}[0])}
 1567     else {$element = $self->Package("Formula")->new(($self->createRandomPoints(1))[1]->[0]{data}[0])}
 1568   return (
 1569     Value::List::cmp_defaults($self,@_),
 1570     removeParens => $self->{autoFormula},
 1571     typeMatch => $element,
 1572     showDomainErrors => 1,
 1573   );
 1574 }
 1575 
 1576 #
 1577 #  Get the types from the values of the formulas
 1578 #     and compare those.
 1579 #
 1580 sub typeMatch {
 1581   my $self = shift; my $other = shift; my $ans = shift;
 1582   return 1 if $self->type eq $other->type;
 1583   my $typeMatch = ($self->createRandomPoints(1))[1]->[0];
 1584   $other = eval {($other->createRandomPoints(1))[1]->[0]} if Value::isFormula($other);
 1585   return 1 unless defined($other); # can't really tell, so don't report type mismatch
 1586   return 1 if $typeMatch->classMatch('String') && Value::isFormula($ans->{typeMatch});  # avoid infinite loop
 1587   $typeMatch->typeMatch($other,$ans);
 1588 }
 1589 
 1590 #
 1591 #  Handle removal of outermost parens in a list.
 1592 #  Evaluate answer, if the eval option is used.
 1593 #  Handle the UpToConstant option.
 1594 #
 1595 sub cmp {
 1596   my $self = shift;
 1597   my $cmp = $self->SUPER::cmp(@_);
 1598   if ($cmp->{rh_ans}{removeParens} && $self->type eq 'List') {
 1599     $self->{tree}{open} = $self->{tree}{close} = '';
 1600     $cmp->ans_hash(correct_ans => $self->stringify)
 1601       unless defined($self->{correct_ans});
 1602   }
 1603   if ($cmp->{rh_ans}{eval} && $self->isConstant) {
 1604     $cmp->ans_hash(correct_value => $self->eval);
 1605     return $cmp;
 1606   }
 1607   if ($cmp->{rh_ans}{upToConstant}) {
 1608     my $current = Parser::Context->current();
 1609     my $context = $self->{context} = $self->{context}->copy;
 1610     Parser::Context->current(undef,$context);
 1611     $context->variables->add('C0' => 'Parameter');
 1612     my $f = $self->Package("Formula")->new('C0')+$self;
 1613     for ('limits','test_points','test_values','num_points','granularity','resolution',
 1614    'checkUndefinedPoints','max_undefined')
 1615       {$f->{$_} = $self->{$_} if defined($self->{$_})}
 1616     $cmp->ans_hash(correct_value => $f);
 1617     Parser::Context->current(undef,$current);
 1618   }
 1619   $cmp->install_pre_filter(\&Value::Formula::cmp_call_filter,"cmp_prefilter");
 1620   $cmp->install_post_filter(\&Value::Formula::cmp_call_filter,"cmp_postfilter");
 1621   return $cmp;
 1622 }
 1623 
 1624 sub cmp_call_filter {
 1625   my $ans = shift; my $method = shift;
 1626   return $ans->{correct_value}->$method($ans);
 1627 }
 1628 
 1629 sub cmp_prefilter {
 1630   my $self = shift; my $ans = shift;
 1631   $ans->{_filter_name} = "fetch_previous_answer";
 1632   $ans->{prev_ans} = undef;
 1633   if (defined($ans->{ans_label})) {
 1634     my $label = "previous_".$ans->{ans_label};
 1635     my $inputs = $self->getPG('$inputs_ref');
 1636     if (defined $inputs->{$label} and $inputs->{$label} =~ /\S/) {
 1637       $ans->{prev_ans} = $inputs->{$label};
 1638       #FIXME -- previous answer item is not always being updated in inputs_ref (which comes from formField)
 1639     }
 1640   }
 1641   return $ans;
 1642 }
 1643 
 1644 sub cmp_postfilter {
 1645   my $self = shift; my $ans = shift;
 1646   $ans->{_filter_name} = "produce_equivalence_message";
 1647   return $ans if $ans->{ans_message}; # don't overwrite other messages
 1648   $ans->{prev_formula} = Parser::Formula($self->{context},$ans->{prev_ans});
 1649   if (defined($ans->{prev_formula}) && defined($ans->{student_formula})) {
 1650     my $prev = eval {$self->promote($ans->{prev_formula})}; break unless defined($prev);
 1651     $ans->{prev_equals_current} = Value::cmp_compare($prev,$ans->{student_formula},{});
 1652     if (   !$ans->{isPreview}                                 # not preview mode
 1653   and $ans->{prev_equals_current}                       # equivalent
 1654   and $ans->{prev_ans} ne $ans->{original_student_ans}) # but not identical
 1655       {$ans->{ans_message} = "This answer is equivalent to the one you just submitted."}
 1656   }
 1657   return $ans;
 1658 }
 1659 
 1660 
 1661 sub cmp_equal {
 1662   my $self = shift; my $ans = shift;
 1663   #
 1664   #  Get the problem's seed
 1665   #
 1666   $self->{context}->flags->set(
 1667     random_seed => $self->getPG('$PG_original_problemSeed')
 1668   );
 1669 
 1670   #
 1671   #  Use the list checker if the formula is a list or union
 1672   #    Otherwise use the normal checker
 1673   #
 1674   if ($self->type =~ m/^(List|Union|Set)$/) {
 1675     Value::List::cmp_equal($self,$ans);
 1676   } else {
 1677     $self->SUPER::cmp_equal($ans);
 1678   }
 1679 }
 1680 
 1681 sub cmp_postprocess {
 1682   my $self = shift; my $ans = shift;
 1683   return unless $ans->{score} == 0 && !$ans->{isPreview};
 1684   return if $ans->{ans_message};
 1685   if ($self->{domainMismatch} && $ans->{showDomainErrors}) {
 1686     $self->cmp_Error($ans,"The domain of your function doesn't match that of the correct answer");
 1687     return;
 1688   }
 1689   return if !$ans->{showDimensionHints};
 1690   my $other = $ans->{student_value};
 1691   return if $ans->{ignoreStrings} && (!Value::isValue($other) || $other->type eq 'String');
 1692   return unless $other->type =~ m/^(Point|Vector|Matrix)$/;
 1693   return unless $self->type  =~ m/^(Point|Vector|Matrix)$/;
 1694   return if Parser::Item::typeMatch($self->typeRef,$other->typeRef);
 1695   $self->cmp_Error($ans,"The dimension of your result is incorrect");
 1696 }
 1697 
 1698 #
 1699 #  Diagnostics for Formulas
 1700 #
 1701 sub cmp_diagnostics {
 1702   my $self = shift;  my $ans = shift;
 1703   my $isEvaluator = (ref($ans) =~ /Evaluator/)? 1: 0;
 1704   my $hash = $isEvaluator? $ans->rh_ans : $ans;
 1705   my $diagnostics = $self->{context}->diagnostics->merge("formulas",$self,$hash);
 1706   my $formulas = $diagnostics->{formulas};
 1707   return unless $formulas->{show};
 1708 
 1709   my $output = "";
 1710   if ($isEvaluator) {
 1711     #
 1712     #  The tests to be performed when the answer checker is created
 1713     #
 1714     $self->getPG('loadMacros("PGgraphmacros.pl")');
 1715     my ($inputs) = $self->getPG('$inputs_ref');
 1716     my $process = $inputs->{checkAnswers} || $inputs->{previewAnswers} || $inputs->{submitAnswers};
 1717     if ($formulas->{checkNumericStability} && !$process) {
 1718       ### still needs to be written
 1719     }
 1720   } else {
 1721     #
 1722     #  The checks to be performed when an answer is submitted
 1723     #
 1724     my $student = $ans->{student_formula};
 1725     #
 1726     #  Get the test points
 1727     #
 1728     my @names = $self->{context}->variables->names;
 1729     my $vx = (keys(%{$self->{variables}}))[0];
 1730     my $vi = 0; while ($names[$vi] ne $vx) {$vi++}
 1731     my $points = [map {$_->[$vi]} @{$self->{test_points}}];
 1732     my @params = $self->{context}->variables->parameters;
 1733        @names = $self->{context}->variables->variables;
 1734 
 1735     #
 1736     #  The graphs of the functions and errors
 1737     #
 1738     if ($formulas->{showGraphs}) {
 1739       my @G = ();
 1740       if ($formulas->{combineGraphs}) {
 1741   push(@G,$self->cmp_graph($diagnostics,[$student,$self],
 1742          title=>'Student Answer (red)<BR>Correct Answer (green)<BR>',
 1743          points=>$points,showDomain=>1));
 1744       } else {
 1745   push(@G,$self->cmp_graph($diagnostics,$self,title=>'Correct Answer'));
 1746   push(@G,$self->cmp_graph($diagnostics,$student,title=>'Student Answer'));
 1747       }
 1748       my $cutoff = $self->Package("Formula")->new($self->getFlag('tolerance'));
 1749       if ($formulas->{graphAbsoluteErrors}) {
 1750   push(@G,$self->cmp_graph($diagnostics,[abs($self-$student),$cutoff],
 1751          clip=>$formulas->{clipAbsoluteError},
 1752          title=>'Absolute Error',points=>$points));
 1753       }
 1754       if ($formulas->{graphRelativeErrors}) {
 1755   push(@G,$self->cmp_graph($diagnostics,[abs(($self-$student)/$self),$cutoff],
 1756          clip=>$formulas->{clipRelativeError},
 1757          title=>'Relative Error',points=>$points));
 1758       }
 1759       $output .= '<TABLE BORDER="0" CELLSPACING="0" CELLPADDING="0">'
 1760   . '<TR VALIGN="TOP">'.join('<TD WIDTH="20"></TD>',@G).'</TR></TABLE>';
 1761     }
 1762 
 1763     #
 1764     #  The adaptive parameters
 1765     #
 1766     if ($formulas->{showParameters} && scalar(@params) > 0) {
 1767       $output .= '<HR><TABLE BORDER="0" CELLSPACING="0" CELLPADDING="0"><TR><TD>Adaptive Parameters:<BR>';
 1768       $output .= join("<BR>",map {"&nbsp;&nbsp;$params[$_]: ".$self->{parameters}[$_]} (0..$#params));
 1769       $output .= '</TD></TR></TABLE>';
 1770     }
 1771 
 1772     #
 1773     #  The test points and values
 1774     #
 1775     my @rows = (); my $colsep = '</TD><TD WIDTH="20"></TD><TD ALIGN="RIGHT">';
 1776     my @P = (map {(scalar(@{$_}) == 1)? $_->[0]: $self->Package("Point")->make(@{$_})} @{$self->{test_points}});
 1777     my @i = sort {$P[$a] <=> $P[$b]} (0..$#P);
 1778     foreach $p (@P) {if (Value::isValue($p) && $p->length > 2) {$p = $p->string; $p =~ s|,|,<br />|g}}
 1779     my $zeroLevelTol = $self->getFlag('zeroLevelTol');
 1780     $self->{context}{flags}{zeroLevelTol} = 0; # always show full resolution in the tables below
 1781     my $names = join(',',@names); $names = '('.$names.')' if scalar(@names) > 1;
 1782 
 1783     $student->createPointValues($self->{test_points},0,1,1) unless $student->{test_values};
 1784 
 1785     my $cv = $self->{test_values};
 1786     my $sv = $student->{test_values};
 1787     my $av = $self->{test_adapt} || $cv;
 1788 
 1789     if ($formulas->{showTestPoints}) {
 1790       my @p = ("$names:", (map {$P[$i[$_]]} (0..$#P)));
 1791       push(@rows,'<TR><TD ALIGN="RIGHT">'.join($colsep,@p).'</TD></TR>');
 1792       push(@rows,'<TR><TD ALIGN="RIGHT">'.join($colsep,("<HR>")x scalar(@p)).'</TD></TR>');
 1793       push(@rows,'<TR><TD ALIGN="RIGHT">'
 1794      .join($colsep,($av == $cv)? "Correct Answer:" : "Adapted Answer:",
 1795      map {Value::isNumber($av->[$i[$_]])? $av->[$i[$_]]: "undefined"} (0..$#P))
 1796      .'</TD></TR>');
 1797       push(@rows,'<TR><TD ALIGN="RIGHT">'
 1798      .join($colsep,"Student Answer:",
 1799      map {Value::isNumber($sv->[$i[$_]])? $sv->[$i[$_]]: "undefined"} (0..$#P))
 1800      .'</TD></TR>');
 1801     }
 1802     #
 1803     #  The absolute errors (colored by whether they are ok or too big)
 1804     #
 1805     if ($formulas->{showAbsoluteErrors}) {
 1806       my @p = ("Absolute Error:");
 1807       my $tolerance = $self->getFlag('tolerance');
 1808       my $tolType = $self->getFlag('tolType'); my $error;
 1809       foreach my $j (0..$#P) {
 1810   if (Value::isNumber($sv->[$i[$j]])) {
 1811     $error = abs($av->[$i[$j]] - $sv->[$i[$j]]);
 1812     $error = '<SPAN STYLE="color:#'.($error->value<$tolerance ? '00AA00': 'AA0000').'">'.$error.'</SPAN>'
 1813       if $tolType eq 'absolute';
 1814   } else {$error = "---"}
 1815   push(@p,$error);
 1816       }
 1817       push(@rows,'<TR><TD ALIGN="RIGHT">'.join($colsep,@p).'</TD></TR>');
 1818     }
 1819     #
 1820     #  The relative errors (colored by whether they are OK or too big)
 1821     #
 1822     if ($formulas->{showRelativeErrors}) {
 1823       my @p = ("Relative Error:");
 1824       my $tolerance = $self->getFlag('tolerance'); my $tol;
 1825       my $tolType = $self->getFlag('tolType'); my $error;
 1826       my $zeroLevel = $self->getFlag('zeroLevel');
 1827       foreach my $j (0..$#P) {
 1828   if (Value::isNumber($sv->[$i[$j]])) {
 1829     my $c = $av->[$i[$j]]; my $s = $sv->[$i[$j]];
 1830     if (abs($cv->[$i[$j]]->value) < $zeroLevel || abs($s->value) < $zeroLevel)
 1831             {$error = abs($c-$s); $tol = $zeroLevelTol} else
 1832             {$error = abs(($c-$s)/($c||1E-10)); $tol = $tolerance}
 1833     $error = '<SPAN STYLE="color:#'.($error < $tol ? '00AA00': 'AA0000').'">'.$error.'</SPAN>'
 1834       if $tolType eq 'relative';
 1835   } else {$error = "---"}
 1836   push(@p,$error);
 1837       }
 1838       push(@rows,'<TR><TD ALIGN="RIGHT">'.join($colsep,@p).'</TD></TR>');
 1839     }
 1840     $self->{context}{flags}{zeroLevelTol} = $zeroLevelTol;
 1841     #
 1842     #  Put the data into a table
 1843     #
 1844     if (scalar(@rows)) {
 1845       $output .= '<p><HR><p><TABLE BORDER="0" CELLSPACING="0" CELLPADDING="0">'
 1846   . join('<TR><TD HEIGHT="3"></TD>',@rows)
 1847   . '</TABLE>';
 1848     }
 1849   }
 1850   #
 1851   #  Put all the diagnostic output into a frame
 1852   #
 1853   return unless $output;
 1854   $output
 1855     = '<TABLE BORDER="1" CELLSPACING="2" CELLPADDING="20" BGCOLOR="#F0F0F0">'
 1856     . '<TR><TD ALIGN="LEFT"><B>Diagnostics for '.$self->string .':</B>'
 1857     . '<P><CENTER>' . $output . '</CENTER></TD></TR></TABLE><P>';
 1858   warn $output;
 1859 }
 1860 
 1861 #
 1862 #  Draw a graph from a given Formula object
 1863 #
 1864 sub cmp_graph {
 1865   my $self = shift; my $diagnostics = shift;
 1866   my $F1 = shift; my $F2; ($F1,$F2) = @{$F1} if (ref($F1) eq 'ARRAY');
 1867   #
 1868   #  Get the various options
 1869   #
 1870   my %options = (title=>'',points=>[],@_);
 1871   my $graphs = $diagnostics->{graphs};
 1872   my $limits = $graphs->{limits}; $limits = $self->getFlag('limits',[-2,2]) unless $limits;
 1873   $limits = $limits->[0] while ref($limits) eq 'ARRAY' && ref($limits->[0]) eq 'ARRAY';
 1874   my $size = $graphs->{size}; $size = [$size,$size] unless ref($size) eq 'ARRAY';
 1875   my $steps = $graphs->{divisions};
 1876   my $points = $options{points}; my $clip = $options{clip};
 1877   my ($my,$My) = (0,0); my ($mx,$Mx) = @{$limits};
 1878   my $dx = ($Mx-$mx)/$steps; my $f; my $y;
 1879 
 1880   my @pnames = $self->{context}->variables->parameters;
 1881   my @pvalues = ($self->{parameters} ? @{$self->{parameters}} : (0) x scalar(@pnames));
 1882   my $x = "";
 1883 
 1884   #
 1885   #  Find the max and min values of the function
 1886   #
 1887   foreach $f ($F1,$F2) {
 1888     next unless defined($f);
 1889     foreach my $v (keys(%{$f->{variables}})) {
 1890       if ($v ne $x && !$f->{context}->variables->get($v)->{parameter}) {
 1891   if ($x) {
 1892     warn "Only formulas with one variable can be graphed" unless $self->{graphWarning};
 1893     $self->{graphWarning} = 1;
 1894     return "";
 1895   }
 1896   $x = $v;
 1897       }
 1898     }
 1899     unless ($f->typeRef->{length} == 1) {
 1900       warn "Only real-valued functions can be graphed" unless $self->{graphWarning};
 1901       $self->{graphWarning} = 1;
 1902       return "";
 1903     }
 1904     unless ($f->typeRef->{length} == 1) {
 1905       warn "Only real-valued functions can be graphed";
 1906       return "";
 1907     }
 1908     if ($f->isConstant) {
 1909       $y = $f->eval;
 1910       $my = $y if $y < $my; $My = $y if $y > $My;
 1911     } else {
 1912       my $F = $f->perlFunction(undef,[$x,@pnames]);
 1913       foreach my $i (0..$steps-1) {
 1914         $y = eval {&{$F}($mx+$i*$dx,@pvalues)};
 1915   next unless defined($y) && Value::isNumber($y);
 1916         $my = $y if $y < $my; $My = $y if $y > $My;
 1917       }
 1918     }
 1919   }
 1920   $My = 1 if abs($My - $my) < 1E-5;
 1921   $my *= 1.1; $My *= 1.1;
 1922   if ($clip) {
 1923     $my = -$clip if $my < -$clip;
 1924     $My = $clip if $My > $clip;
 1925   }
 1926   $my = -$My/10 if $my > -$My/10; $My = -$my/10 if $My < -$my/10;
 1927   my $a = $self->Package("Real")->new(($My-$my)/($Mx-$mx));
 1928 
 1929   #
 1930   #  Create the graph itself, with suitable title
 1931   #
 1932   my $grf = $self->getPG('$_grf_ = {n => 0}');
 1933   $grf->{Goptions} = [
 1934      $mx,$my,$Mx,$My,
 1935      axes => $graphs->{axes},
 1936      grid => $graphs->{grid},
 1937      size => $size,
 1938   ];
 1939   $grf->{params} = {
 1940     names => [$x,@pnames],
 1941     values => {map {$pnames[$_] => $pvalues[$_]} (0..scalar(@pnames)-1)},
 1942   };
 1943   $grf->{G} = $self->getPG('init_graph(@{$_grf_->{Goptions}})');
 1944   $grf->{G}->imageName($grf->{G}->imageName.'-'.time()); # avoid browser cache
 1945   $self->cmp_graph_function($grf,$F2,"green",$steps,$points) if defined($F2);
 1946   $self->cmp_graph_function($grf,$F1,"red",$steps,$points);
 1947   my $image = $self->getPG('alias(insertGraph($_grf_->{G}))');
 1948   $image = '<IMG SRC="'.$image.'" WIDTH="'.$size->[0].'" HEIGHT="'.$size->[1].'" BORDER="0" STYLE="margin-bottom:5px">';
 1949   my $title = $options{title}; $title .= '<DIV STYLE="margin-top:5px"></DIV>' if $title;
 1950   $title .= "<SMALL>Domain: [$mx,$Mx]</SMALL><BR>" if $options{showDomain};
 1951   $title .= "<SMALL>Range: [$my,$My]<BR>Aspect ratio: $a:1</SMALL>";
 1952   return '<TD ALIGN="CENTER" VALIGN="TOP" NOWRAP>'.$image.'<BR>'.$title.'</TD>';
 1953 }
 1954 
 1955 #
 1956 #  Add a function to a graph object, and plot the points
 1957 #  that are used to test the function
 1958 #
 1959 sub cmp_graph_function {
 1960   my $self = shift; my $grf = shift; my $F = shift;
 1961   my $color = shift; my $steps = shift; my $points = shift;
 1962   $grf->{n}++; my $Fn = "F".$grf->{n}; $grf->{$Fn} = $F; my $f;
 1963   if ($F->isConstant) {
 1964     my $y = $F->eval;
 1965     $f = $self->getPG('new Fun(sub {'.$y.'},$_grf_->{G})');
 1966   } else {
 1967     my $X = $grf->{params}{names}[0];
 1968     $f = $self->getPG('new Fun(sub {Parser::Evaluate($_grf_->{'.$Fn.'},'
 1969            .$X.'=>shift,%{$_grf_->{params}{values}})},$_grf_->{G})');
 1970     foreach my $x (@{$points}) {
 1971       my $y = Parser::Evaluate($F,($X)=>$x,%{$grf->{params}{values}});
 1972       next unless defined($y) && Value::isNumber($y);
 1973       $grf->{x} = $x; $grf->{'y'} = $y;
 1974       my $C = $self->getPG('new Circle($_grf_->{x},$_grf_->{y},4,"'.$color.'","'.$color.'")');
 1975       $grf->{G}->stamps($C);
 1976     }
 1977   }
 1978   $f->color($color); $f->weight(2); $f->steps($steps);
 1979 }
 1980 
 1981 #
 1982 #  If an answer array was used, get the data from the
 1983 #  Matrix, Vector or Point, and format the array of
 1984 #  data using the original parameter
 1985 #
 1986 sub correct_ans {
 1987   my $self = shift;
 1988   return $self->SUPER::correct_ans unless $self->{ans_name};
 1989   my @array = ();
 1990   if ($self->{tree}->type eq 'Matrix') {
 1991     foreach my $row (@{$self->{tree}{coords}}) {
 1992       my @row = ();
 1993       foreach my $x (@{$row->coords}) {push(@row,$x->string)}
 1994       push(@array,[@row]);
 1995     }
 1996   } else {
 1997     foreach my $x (@{$self->{tree}{coords}}) {push(@array,$x->string)}
 1998     if ($self->{tree}{ColumnVector}) {foreach my $x (@array) {$x = [$x]}}
 1999       else {@array = [@array]}
 2000   }
 2001   Value::VERBATIM($self->format_matrix([@array],@{$self->{format_options}},tth_delims=>1));
 2002 }
 2003 
 2004 #
 2005 #  Get the size of the array and create the appropriate answer array
 2006 #
 2007 sub ANS_MATRIX {
 2008   my $self = shift;
 2009   my $extend = shift; my $name = shift;
 2010   my $size = shift || 5; my $type = $self->type;
 2011   my $cols = $self->length; my $rows = 1; my $sep = ',';
 2012   if ($type eq 'Matrix') {
 2013     $sep = ''; $rows = $cols; $cols = $self->{tree}->typeRef->{entryType}{length};
 2014   }
 2015   if ($self->{tree}{ColumnVector}) {
 2016     $sep = ""; $type = "Matrix";
 2017     my $tmp = $rows; $rows = $cols; $cols = $tmp;
 2018     $self->{ColumnVector} = 1;
 2019   }
 2020   my $def = $self->context->lists->get($type);
 2021   my $open = $self->{open} || $self->{tree}{open} || $def->{open};
 2022   my $close = $self->{close} || $self->{tree}{close} || $def->{close};
 2023   $self->ans_matrix($extend,$name,$rows,$cols,$size,$open,$close,$sep);
 2024 }
 2025 
 2026 sub ans_array {
 2027   my $self = shift;
 2028   return $self->SUPER::ans_array(@_) unless $self->array_OK;
 2029   $self->ANS_MATRIX(0,'',@_);
 2030 }
 2031 sub named_ans_array {
 2032   my $self = shift;
 2033   return $self->SUPER::named_ans_array(@_) unless $self->array_OK;
 2034   $self->ANS_MATRIX(0,@_);
 2035 }
 2036 sub named_ans_array_extension {
 2037   my $self = shift;
 2038   return $self->SUPER::named_ans_array_extension(@_) unless $self->array_OK;
 2039   $self->ANS_MATRIX(1,@_);
 2040 }
 2041 
 2042 sub array_OK {
 2043   my $self = shift; my $tree = $self->{tree};
 2044   return $tree->type =~ m/^(Point|Vector|Matrix)$/ && $tree->class eq 'List';
 2045 }
 2046 
 2047 #
 2048 #  Get an array of values from a Matrix, Vector or Point
 2049 #  (this needs to be made more general)
 2050 #
 2051 sub value {
 2052   my $self = shift;
 2053   return $self unless defined $self->{tree}{coords};
 2054   my $context = $self->context;
 2055   my @array = ();
 2056   if ($self->{tree}->type eq 'Matrix') {
 2057     foreach my $row (@{$self->{tree}->coords}) {
 2058       my @row = ();
 2059       foreach my $x (@{$row->coords}) {push(@row,$context->Package("Formula")->new($context,$x))}
 2060       push(@array,[@row]);
 2061     }
 2062   } else {
 2063     foreach my $x (@{$self->{tree}->coords}) {
 2064       push(@array,$context->Package("Formula")->new($context,$x));
 2065     }
 2066   }
 2067   return @array;
 2068 }
 2069 
 2070 #############################################################
 2071 
 2072 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9