Forum archive 2000-2006

user Michael Gage - PGdiffeqmacros.pl blueArrow

user Michael Gage - PGdiffeqmacros.pl blueArrow

by Arnold Pizer -
Number of replies: 0
inactiveTopicPGdiffeqmacros.pl topic started 9/14/2004; 2:13:37 PM
last post 9/14/2004; 2:13:37 PM
userMichael Gage - PGdiffeqmacros.pl  blueArrow
9/14/2004; 2:13:37 PM (reads: 1245, responses: 0)

    rungeKutta4a

Answer checker filter for comparing to an integral curve of a vector field.


=cut


sub rungeKutta4a {
my $rh_ans = shift;
my %options = @_;
my $rf_fun = $rh_ans->{rf_diffeq};
set_default_options( \%options,
'initial_t' => 1,
'initial_y' => 1,
'dt' => .01,
'num_of_points' => 10, #number of reported points
'interior_points' => 5, # number of 'interior' steps
between reported points
'debug' => 1, # remind programmers to always
pass the debug parameter
);
my $t = $options{initial_t};
my $y = $options{initial_y};

my $num = $options{'num_of_points'}; # number of points
my $num2 = $options{'interior_points'}; # number of steps between points.
my $dt = $options{'dt'};
my $errors = undef;
my $rf_rhs = sub { my @in = @_;
my ( $out, $err) = &$rf_fun(@in);
$errors .= " $err at ( ".join(" , ", @in) . " )<br>\n" if defined($err);
$out = 'NaN' if defined($err) and not is_a_number($out);
$out;
};

my @output = ([$t, $y]);
my ($i, $j, $K1,$K2,$K3,$K4);

for ($j=0; $j<$num; $j++) {
for ($i=0; $i<$num2; $i++) {
$K1 = $dt*&$rf_rhs($t, $y);
$K2 = $dt*&$rf_rhs($t+$dt/2,$y+$K1/2);
$K3 = $dt*&$rf_rhs($t+$dt/2, $y+$K2/2);
$K4 = $dt*&$rf_rhs($t+$dt, $y+$K3);
$y = $y + ($K1 + 2*$K2 + 2*$K3 + $K4)/6;
$t = $t + $dt;
}
push(@output, [$t, $y]);
}
$rh_ans->{evaluation_points} = \@output;
$rh_ans->throw_error($errors) if defined($errors);
$rh_ans;
}

sub level_curve_check { my $diffEqRHS = shift; #required differential equation my $correctEqn = shift; # required answer in order to check the equation my %options = @_; my $saveUseOldAnswerMacros = main::PG_restricted_eval('$main::useOldAnswerMacros') || 0; main::PG_restricted_eval('$main::useOldAnswerMacros = 1'); assign_option_aliases( \%options, 'vars' => 'var', 'numPoints' => 'num_of_points', 'reltol' => 'relTol', ); set_default_options( \%options, 'initial_t' => 0, 'initial_y' => 1, 'var' => [qw( x y )], 'num_of_points' => 10, 'tolType' => (defined($options{tol}) ) ? 'absolute' : 'relative', 'relTol' => .01, 'tol' => .01, 'debug' => 0, ); my $initial_t = $options{initial_t}; my $initial_y = $options{initial_y}; my $var = $options{var}; my $numPoints = $options{num_of_points}; my @VARS = get_var_array( $var ); my ($tolType, $tol); if ($options{tolType} eq 'absolute') { $tolType = 'absolute'; $tol = $options{'tol'}; delete($options{'relTol'}) if exists( $options{'relTol'} ); } else { $tolType = 'relative'; $tol = $options{'relTol'}; delete($options{'tol'}) if exists( $options{'tol'} ); } #prepare the correct answer and check its syntax my $rh_correct_ans = new AnswerHash; $rh_correct_ans ->{correct_ans} = $correctEqn; # check and calculate the function defining the differential equation $rh_correct_ans->input( $diffEqRHS ); $rh_correct_ans = check_syntax($rh_correct_ans); warn $rh_correct_ans->{error_message},$rh_correct_ans->pretty_print() if $rh_correct_ans->{error_flag}; $rh_correct_ans->{error_flag} = undef; $rh_correct_ans = function_from_string2($rh_correct_ans, ra_vars => [@VARS], store_in =>'rf_diffeq', debug=>$options{debug} ); warn "Error in compiling instructor's answer: $diffEqRHbr $rh_correct_ans->{error_message}<br>\n$rh_correct_ans->pretty_print()" if $rh_correct_ans->{error_flag}; # create the test points that should lie on a solution curve of the differential equation $rh_correct_ans = rungeKutta4a( $rh_correct_ans, initial_t => $initial_t, initial_y => $initial_y, num_of_points => $numPoints, debug=>$options{debug} ); warn "Errors in calculating the solution curve $rh_correct_ans->{student_ans}<BR>\n $rh_correct_ans->{error_message}<br>\n",$rh_correct_ans->pretty_print() if $rh_correct_ans->catch_error(); $rh_correct_ans->clear_error(); # check and compile the correct answer submitted by the instructor. my ($check_eval) = fun_cmp('c', vars => [@VARS], params => ['c'], tolType => $options{tolType}, relTol => $options{relTol}, tol => $options{tol}, debug => $options{debug}, ); # an evaluator that tests for constants; $check_eval->ans_hash(evaluation_points => $rh_correct_ans->{evaluation_points}); $check_eval->evaluate($rh_correct_ans->{correct_ans}); if( $check_eval->ans_hash->{score} == 0 or (defined($options{debug}) and $options{debug})) { # write error message for professor my $out1 = $check_eval->ans_hash->{evaluation_points}; my $rf_corrEq = $check_eval->ans_hash->{rf_student_ans}; my $error_string = "This equation $correctEqn is not constant on solution curves of y'(t) = $diffEqRHS\r\n<br> starting at ( $initial_t , $initial_y )<br> $check_eval->ans_hash->pretty_print()". "options<br>\n".pretty_print({ vars => [@VARS], params => ['c'], tolType => $options{tolType}, relTol => $options{relTol}, tol => $options{tol}, debug => $options{debug}, }); for (my $i=0; $i<$numPoints;$i++) { my ($z, $err) = &$rf_corrEq( $out1->[$i][0], $out1->[$i][1] ); $z = $err if defined $err; $error_string .= "F( ". $out1->[$i][0] . " , ". $out1->[$i][1] . " ) = $z <br>\r\n"; } $error_string .= $rh_correct_ans->error_message(); warn $error_string, $check_eval->ans_hash->pretty_print; } my ($constant_eval) = fun_cmp('c', vars => [@VARS], params => ['c'], tolType => $options{tolType}, relTol => $options{relTol}, tol => $options{tol}, debug => $options{debug}, ); # an evaluator that tests for constants; $constant_eval->ans_hash(evaluation_points => $rh_correct_ans->{evaluation_points}); my $answer_evaluator = new AnswerEvaluator; $answer_evaluator->ans_hash( correct_ans => $rh_correct_ans->{correct_ans}, # used for answer only rf_correct_ans => sub { my @input = @_; pop(@input); }, # return the last input which is the constant parameter 'c'; evaluation_points => $rh_correct_ans->{evaluation_points}, ra_param_vars => ['c'], # compare with constant function ra_vars => [@VARS], type => 'level_curve', ); $answer_evaluator->install_evaluator(sub { my $ans_hash = shift; my %options = @_; $constant_eval->evaluate($ans_hash->{student_ans}); $constant_eval->ans_hash; }); $answer_evaluator->install_post_filter( sub { my $ans_hash = shift; $ans_hash->{correct_ans} = $correctEqn; $ans_hash; } ); $answer_evaluator->install_post_filter( sub { my $rh_ans= shift; my %options = @_; if ($rh_ans->catch_error('SYNTAX') ) { $rh_ans->{ans_message} = $rh_ans->{error_message}; $rh_ans->clear_error('SYNTAX'); } $rh_ans; }); main::PG_restricted_eval('$main::useOldAnswerMacros = '.$saveUseOldAnswerMacros); $answer_evaluator; }

1;

File path = /ww/webwork/pg/macros/PGdiffeqmacros.pl

<| Post or View Comments |>