[system] / trunk / webwork / system / courseScripts / PGanswermacros.pl Repository:
ViewVC logotype

Diff of /trunk/webwork/system/courseScripts/PGanswermacros.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

Revision 118 Revision 119
… …
1110 $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('NUMBER'); } ); 1110 $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('NUMBER'); } );
1111 $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('STRING'); } ); 1111 $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('STRING'); } );
1112 $answer_evaluator; 1112 $answer_evaluator;
1113} 1113}
1114 1114
1115sub fix_answers_for_display {
1116 my ($rh_ans, %options) = @_;
1117 if ( $rh_ans->{answerIsString} ==1) {
1118 $rh_ans = evaluatesToNumber ($rh_ans, %options);
1119 }
1120 if (defined ($rh_ans->{student_units})) {
1121 $rh_ans->{student_ans} = $rh_ans->{student_ans}. ' '. $rh_ans->{student_units};
1122 }
1123 $rh_ans->{correct_ans} = $rh_ans->{original_correct_ans};
1124
1125 $rh_ans;
1126}
1127 1115
1128sub evaluatesToNumber {
1129 my ($rh_ans, %options) = @_;
1130 if (is_a_numeric_expression($rh_ans->{student_ans})) {
1131 my ($inVal,$PG_eval_errors,$PG_full_error_report) = PG_answer_eval($rh_ans->{student_ans});
1132 if ($PG_eval_errors) { # this if statement should never be run
1133 # change nothing
1134 } else {
1135 # change this
1136 $rh_ans->{student_ans} = prfmt($inVal,$options{format});
1137 }
1138 }
1139 $rh_ans;
1140}
1141
1142sub is_a_numeric_expression {
1143 my $testString = shift;
1144 my $is_a_numeric_expression = 0;
1145 my ($inVal,$PG_eval_errors,$PG_full_error_report) = PG_answer_eval($testString);
1146 if ($PG_eval_errors) {
1147 $is_a_numeric_expression = 0;
1148 } else {
1149 $is_a_numeric_expression = 1;
1150 }
1151 $is_a_numeric_expression;
1152}
1153 1116
1154########################################################################## 1117##########################################################################
1155########################################################################## 1118##########################################################################
1156## Function answer evaluators 1119## Function answer evaluators
1157 1120
… …
3449 return @out; 3412 return @out;
3450 } 3413 }
3451 } 3414 }
3452} 3415}
3453 3416
3454sub check_option_list { 3417#sub check_option_list {
3455 my $size = scalar(@_); 3418# my $size = scalar(@_);
3456 if( ( $size % 2 ) != 0 ) { 3419# if( ( $size % 2 ) != 0 ) {
3457 warn "ERROR in answer evaluator generator:\n" . 3420# warn "ERROR in answer evaluator generator:\n" .
3458 "Usage: <CODE>str_cmp([\$ans1, \$ans2],%options)</CODE> 3421# "Usage: <CODE>str_cmp([\$ans1, \$ans2],%options)</CODE>
3459 or <CODE> num_cmp([\$num1, \$num2], %options)</CODE><BR> 3422# or <CODE> num_cmp([\$num1, \$num2], %options)</CODE><BR>
3460 A list of inputs must be inclosed in square brackets <CODE>[\$ans1, \$ans2]</CODE>"; 3423# A list of inputs must be inclosed in square brackets <CODE>[\$ans1, \$ans2]</CODE>";
3461 } 3424# }
3462} 3425#}
3463 3426
3464# simple subroutine to display an error message when 3427# simple subroutine to display an error message when
3465# function compares are called with invalid parameters 3428# function compares are called with invalid parameters
3466sub function_invalid_params { 3429sub function_invalid_params {
3467 my $correctEqn = shift @_; 3430 my $correctEqn = shift @_;
… …
3471 return ( 0, $correctEqn, "", $PGanswerMessage ); 3434 return ( 0, $correctEqn, "", $PGanswerMessage );
3472 }; 3435 };
3473 return $error_response; 3436 return $error_response;
3474} 3437}
3475 3438
3439sub clean_up_error_msg {
3440 my $msg = $_[0];
3441 $msg =~ s/^\[[^\]]*\][^:]*://;
3442 $msg =~ s/Unquoted string//g;
3443 $msg =~ s/may\s+clash.*/does not make sense here/;
3444 $msg =~ s/\sat.*line [\d]*//g;
3445 $msg = 'error: '. $msg;
3446
3447 return $msg;
3448}
3449
3450#formats the student and correct answer as specified
3451#format must be of a form suitable for sprintf (e.g. '%0.5g'),
3452#with the exception that a '#' at the end of the string
3453#will cause trailing zeros in the decimal part to be removed
3454sub prfmt {
3455 my($number,$format) = @_; # attention, the order of format and number are reversed
3456 my $out;
3457 if ($format) {
3458 warn "Incorrect format used: $format. <BR> Format should look something like %4.5g<BR>"
3459 unless $format =~ /^\s*%\d*\.?\d*\w#?\s*$/;
3460
3461 if( $format =~ s/#\s*$// ) { # remove trailing zeros in the decimal
3462 $out = sprintf( $format, $number );
3463 $out =~ s/(\.\d*?)0+$/$1/;
3464 $out =~ s/\.$//; # in case all decimal digits were zero, remove the decimal
3465 }
3466 else {
3467 $out = sprintf( $format, $number );
3468 }
3469 $out =~ s/e/E/g; # only use capital E's for exponents. Little e is for 2.71828...
3470 }
3471 else {
3472 $out = $number;
3473 $out =~ s/e/E/g; # only use capital E's for exponents. Little e is for 2.71828...
3474
3475 }
3476 return $out;
3477}
3476######################################################################### 3478#########################################################################
3477# Filters for answer evaluators 3479# Filters for answer evaluators
3478######################################################################### 3480#########################################################################
3481
3482=head2 Filters
3483
3484=pod
3485
3486A filter is a short subroutine with the following structure. It accepts an
3487AnswerHash, followed by a hash of options. It returns an AnswerHash
3488
3489 $ans_hash = filter($ans_hash, %options);
3490
3491See the AnswerHash.pm file for a list of entries which can be expected to be found
3492in an AnswerHash, such as 'studen_abs', 'score' and so forth. Other entries
3493may be present for specialized answer evaluators.
3494
3495The hope is that a well designed set of filters can easily be combined to form
3496a new answer_evaluator and that this method will produce answer evaluators which are
3497are more robust than the method of copying existing answer evaluators and modifying them.
3498
3499Here is an outline of how a filter is constructed:
3500
3501 sub filter{
3502 my $rh_ans = shift;
3503 my %options = @_;
3504 assign_option_aliases(\%options,
3505 'alias1' => 'option5'
3506 'alias2' => 'option7'
3507 );
3508 set_default_options(\%options,
3509 '_filter_name' => 'filter',
3510 'option5' => .0001,
3511 'option7' => 'ascii',
3512 'allow_unknown_options => 0,
3513 }
3514 .... body code of filter .......
3515 if ($error) {
3516 $rh_ans->throw_error("FILTER_ERROR", "Something went wrong");
3517 # see AnswerHash.pm for details on using the throw_error method.
3518
3519 $rh_ans; #reference to an AnswerHash object is returned.
3520 }
3521
3522=cut
3523
3524=head4 fix_answer_for_display
3525
3526=cut
3527
3528sub fix_answers_for_display {
3529 my ($rh_ans, %options) = @_;
3530 if ( $rh_ans->{answerIsString} ==1) {
3531 $rh_ans = evaluatesToNumber ($rh_ans, %options);
3532 }
3533 if (defined ($rh_ans->{student_units})) {
3534 $rh_ans->{student_ans} = $rh_ans->{student_ans}. ' '. $rh_ans->{student_units};
3535 }
3536 $rh_ans->{correct_ans} = $rh_ans->{original_correct_ans};
3537
3538 $rh_ans;
3539}
3540
3541=head4 evaluatesToNumber
3542
3543=cut
3544
3545sub evaluatesToNumber {
3546 my ($rh_ans, %options) = @_;
3547 if (is_a_numeric_expression($rh_ans->{student_ans})) {
3548 my ($inVal,$PG_eval_errors,$PG_full_error_report) = PG_answer_eval($rh_ans->{student_ans});
3549 if ($PG_eval_errors) { # this if statement should never be run
3550 # change nothing
3551 } else {
3552 # change this
3553 $rh_ans->{student_ans} = prfmt($inVal,$options{format});
3554 }
3555 }
3556 $rh_ans;
3557}
3558
3559=head4 is_numeric_expression
3560
3561=cut
3562
3563sub is_a_numeric_expression {
3564 my $testString = shift;
3565 my $is_a_numeric_expression = 0;
3566 my ($inVal,$PG_eval_errors,$PG_full_error_report) = PG_answer_eval($testString);
3567 if ($PG_eval_errors) {
3568 $is_a_numeric_expression = 0;
3569 } else {
3570 $is_a_numeric_expression = 1;
3571 }
3572 $is_a_numeric_expression;
3573}
3574
3575=head4 is_a_number
3576
3577=cut
3479 3578
3480sub is_a_number { 3579sub is_a_number {
3481 my ($num,%options) = @_; 3580 my ($num,%options) = @_;
3482 my $process_ans_hash = ( ref( $num ) eq 'AnswerHash' ) ? 1 : 0 ; 3581 my $process_ans_hash = ( ref( $num ) eq 'AnswerHash' ) ? 1 : 0 ;
3483 my ($rh_ans); 3582 my ($rh_ans);
… …
3507 } 3606 }
3508 } else { 3607 } else {
3509 return $is_a_number; 3608 return $is_a_number;
3510 } 3609 }
3511} 3610}
3611
3612=head4 is_a_fraction
3613
3614=cut
3512 3615
3513sub is_a_fraction { 3616sub is_a_fraction {
3514 my ($num,%options) = @_; 3617 my ($num,%options) = @_;
3515 my $process_ans_hash = ( ref( $num ) eq 'AnswerHash' ) ? 1 : 0 ; 3618 my $process_ans_hash = ( ref( $num ) eq 'AnswerHash' ) ? 1 : 0 ;
3516 my ($rh_ans); 3619 my ($rh_ans);
… …
3541 } else { 3644 } else {
3542 return $is_a_fraction; 3645 return $is_a_fraction;
3543 } 3646 }
3544} 3647}
3545 3648
3649=head4 is_an_arithemetic_expression
3650
3651=cut
3546 3652
3547sub is_an_arithmetic_expression { 3653sub is_an_arithmetic_expression {
3548 my ($num,%options) = @_; 3654 my ($num,%options) = @_;
3549 my $process_ans_hash = ( ref( $num ) eq 'AnswerHash' ) ? 1 : 0 ; 3655 my $process_ans_hash = ( ref( $num ) eq 'AnswerHash' ) ? 1 : 0 ;
3550 my ($rh_ans); 3656 my ($rh_ans);
… …
3576 } else { 3682 } else {
3577 return $is_an_arithmetic_expression; 3683 return $is_an_arithmetic_expression;
3578 } 3684 }
3579} 3685}
3580 3686
3687#
3688
3689=head4 math_constants
3690
3581#replaces pi, e, and ^ with their Perl equivalents 3691replaces pi, e, and ^ with their Perl equivalents
3692
3693=cut
3694
3582sub math_constants { 3695sub math_constants {
3583 my($in,%options) = @_; 3696 my($in,%options) = @_;
3584 my $rh_ans; 3697 my $rh_ans;
3585 my $process_ans_hash = ( ref( $in ) eq 'AnswerHash' ) ? 1 : 0 ; 3698 my $process_ans_hash = ( ref( $in ) eq 'AnswerHash' ) ? 1 : 0 ;
3586 if ($process_ans_hash) { 3699 if ($process_ans_hash) {
3587 $rh_ans = $in; 3700 $rh_ans = $in;
3588 $in = $rh_ans->{student_ans}; 3701 $in = $rh_ans->{student_ans};
3589 } 3702 }
3590 3703 # The code fragment above allows this filter to be used when the input is simply a string
3704 # as well as when the input is an AnswerHash, and options.
3591 $in =~s/\bpi\b/(4*atan2(1,1))/ge; 3705 $in =~s/\bpi\b/(4*atan2(1,1))/ge;
3592 $in =~s/\be\b/(exp(1))/ge; 3706 $in =~s/\be\b/(exp(1))/ge;
3593 $in =~s/\^/**/g; 3707 $in =~s/\^/**/g;
3594 3708
3595 if ($process_ans_hash) { 3709 if ($process_ans_hash) {
… …
3598 } else { 3712 } else {
3599 return $in; 3713 return $in;
3600 } 3714 }
3601} 3715}
3602 3716
3603sub clean_up_error_msg { 3717=head2 Utility subroutines
3604 my $msg = $_[0];
3605 $msg =~ s/^\[[^\]]*\][^:]*://;
3606 $msg =~ s/Unquoted string//g;
3607 $msg =~ s/may\s+clash.*/does not make sense here/;
3608 $msg =~ s/\sat.*line [\d]*//g;
3609 $msg = 'error: '. $msg;
3610
3611 return $msg;
3612}
3613
3614#formats the student and correct answer as specified
3615#format must be of a form suitable for sprintf (e.g. '%0.5g'),
3616#with the exception that a '#' at the end of the string
3617#will cause trailing zeros in the decimal part to be removed
3618sub prfmt {
3619 my($number,$format) = @_; # attention, the order of format and number are reversed
3620 my $out;
3621 if ($format) {
3622 warn "Incorrect format used: $format. <BR> Format should look something like %4.5g<BR>"
3623 unless $format =~ /^\s*%\d*\.?\d*\w#?\s*$/;
3624
3625 if( $format =~ s/#\s*$// ) { # remove trailing zeros in the decimal
3626 $out = sprintf( $format, $number );
3627 $out =~ s/(\.\d*?)0+$/$1/;
3628 $out =~ s/\.$//; # in case all decimal digits were zero, remove the decimal
3629 }
3630 else {
3631 $out = sprintf( $format, $number );
3632 }
3633 $out =~ s/e/E/g; # only use capital E's for exponents. Little e is for 2.71828...
3634 }
3635 else {
3636 $out = $number;
3637 $out =~ s/e/E/g; # only use capital E's for exponents. Little e is for 2.71828...
3638
3639 }
3640 return $out;
3641}
3642 3718
3643=head4 3719=head4
3644 3720
3645 pretty_print() 3721 warn pretty_print( $rh_hash_input)
3646 3722
3723This can be very useful for printing out messages about objects while debugging
3647 3724
3648=cut 3725=cut
3649 3726
3650sub pretty_print { 3727sub pretty_print {
3651 my $r_input = shift; 3728 my $r_input = shift;
… …
3672 $out = $r_input; 3749 $out = $r_input;
3673 } 3750 }
3674 $out; 3751 $out;
3675} 3752}
3676 3753
3677# Use this to set default options 3754=head2 Filter utilities
3678sub set_default_options { 3755
3679 my $rh_options = shift; 3756These two subroutines can be used in filters to set default options. They
3680 warn "The first entry to set_default_options must be a reference to the option hash" unless ref($rh_options) eq 'HASH'; 3757help make filters perform in uniform, predictable ways, and also make it
3681 my %default_options = @_; 3758easy to recognize from the code which options a given filter expects.
3682 unless ( defined($default_options{allow_unknown_options}) and $default_options{allow_unknown_options} == 1 ) { 3759
3683 foreach my $key1 (keys %$rh_options) { 3760
3684 warn "This option |$key1| is not recognized in this subroutine<br> ", pretty_print($rh_options) unless exists($default_options{$key1}); 3761=head4 assign_option_aliases
3762
3763Use this to assign aliases for the standard options. It must come before set_default_options
3764within the subroutine.
3765
3766 assign_option_aliases(\%options,
3767 'alias1' => 'option5'
3768 'alias2' => 'option7'
3769 );
3685 } 3770
3686 } 3771If the subroutine is called with an option " alias1 => 23 " it will behave as if it had been
3687 foreach my $key (keys %default_options) { 3772called with the option " option5 => 23 "
3688 if ( not defined($rh_options->{$key} ) and defined( $default_options{$key} ) ) { 3773
3689 $rh_options->{$key} = $default_options{$key}; #this allows tol => undef to allow the tol option, but doesn't define 3774=cut
3690 # this key unless tol is explicitly defined. 3775
3691 } 3776
3692 } 3777
3693}
3694# Use this to assign aliases for the standard options
3695sub assign_option_aliases { 3778sub assign_option_aliases {
3696 my $rh_options = shift; 3779 my $rh_options = shift;
3697 warn "The first entry to set_default_options must be a reference to the option hash" unless ref($rh_options) eq 'HASH'; 3780 warn "The first entry to set_default_options must be a reference to the option hash" unless ref($rh_options) eq 'HASH';
3698 my @option_aliases = @_; 3781 my @option_aliases = @_;
3699 while (@option_aliases) { 3782 while (@option_aliases) {
… …
3714 delete($rh_options->{$alias}); # remove the alias from the initial list 3797 delete($rh_options->{$alias}); # remove the alias from the initial list
3715 } 3798 }
3716 3799
3717} 3800}
3718 3801
3802=head4 set_default_options
3803
3804 set_default_options(\%options,
3805 '_filter_name' => 'filter',
3806 'option5' => .0001,
3807 'option7' => 'ascii',
3808 'allow_unknown_options => 0,
3809 }
3810
3811Note that the first entry is a reference to the options with which the filter was called.
3812
3813The option5 is set to .0001 unless the option is explicitly set when the subroutine is called.
3814
3815The b<'_filter_name'> option should always be set, although there is no error if it is missing.
3816It is used mainly for debugging answer evaluators and allows
3817you to keep track of which filter is currently processing the answer.
3818
3819If b<'allow_unknown_options'> is set to 0 then if the filter is called with options which do NOT appear in the
3820set_default_options list an error will be signaled and a warning message will be printed out. This provides
3821error checking against misspelling an option and is generally what is desired for most filters.
3822
3823Occasionally one wants to write a filter which accepts a long list of options, but only uses a subset of the options
3824provided. In this case, setting 'allow_unkown_options' prevents the error from being signaled.
3825
3826=cut
3827
3828sub set_default_options {
3829 my $rh_options = shift;
3830 warn "The first entry to set_default_options must be a reference to the option hash" unless ref($rh_options) eq 'HASH';
3831 my %default_options = @_;
3832 unless ( defined($default_options{allow_unknown_options}) and $default_options{allow_unknown_options} == 1 ) {
3833 foreach my $key1 (keys %$rh_options) {
3834 warn "This option |$key1| is not recognized in this subroutine<br> ", pretty_print($rh_options) unless exists($default_options{$key1});
3835 }
3836 }
3837 foreach my $key (keys %default_options) {
3838 if ( not defined($rh_options->{$key} ) and defined( $default_options{$key} ) ) {
3839 $rh_options->{$key} = $default_options{$key}; #this allows tol => undef to allow the tol option, but doesn't define
3840 # this key unless tol is explicitly defined.
3841 }
3842 }
3843}
3844
3845
3719 3846
37201; 38471;
Legend:
Removed from v.118  
changed lines
  Added in v.119
aubreyja at gmail dot com
 ViewVC Help
Powered by ViewVC 1.0.9