Menu
▾
▴
openwebwork-cvs — WeBWorK CVS activity
You can subscribe to this list here.
| 2004 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
(58) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2005 |
Jan
(53) |
Feb
(56) |
Mar
|
Apr
|
May
(30) |
Jun
(78) |
Jul
(121) |
Aug
(155) |
Sep
(77) |
Oct
(61) |
Nov
(45) |
Dec
(94) |
| 2006 |
Jan
(116) |
Feb
(33) |
Mar
(11) |
Apr
(23) |
May
(60) |
Jun
(89) |
Jul
(130) |
Aug
(109) |
Sep
(124) |
Oct
(63) |
Nov
(82) |
Dec
(45) |
| 2007 |
Jan
(31) |
Feb
(35) |
Mar
(123) |
Apr
(36) |
May
(18) |
Jun
(134) |
Jul
(133) |
Aug
(241) |
Sep
(126) |
Oct
(31) |
Nov
(15) |
Dec
(5) |
| 2008 |
Jan
(11) |
Feb
(6) |
Mar
(16) |
Apr
(29) |
May
(43) |
Jun
(149) |
Jul
(27) |
Aug
(29) |
Sep
(37) |
Oct
(20) |
Nov
(4) |
Dec
(6) |
| 2009 |
Jan
(34) |
Feb
(30) |
Mar
(16) |
Apr
(6) |
May
(1) |
Jun
(32) |
Jul
(22) |
Aug
(7) |
Sep
(18) |
Oct
(50) |
Nov
(22) |
Dec
(8) |
| 2010 |
Jan
(17) |
Feb
(15) |
Mar
(10) |
Apr
(9) |
May
(67) |
Jun
(30) |
Jul
|
Aug
|
Sep
(2) |
Oct
|
Nov
(1) |
Dec
|
|
From: Mike G. v. a. <we...@ma...> - 2005-07-04 15:24:55
|
Log Message:
-----------
Restored str_filters -- removing it broke some of the other answer evaluators.
str_filters takes a string, filters it and then returns the filtered string.
The actual filters have been changed to work with answer hashes rather than with
strings, so str_filters warps the string in an answer hash before sending it through
the filters.
sorry for the breakage.
-- Mike
Modified Files:
--------------
pg/macros:
PGanswermacros.pl
Revision Data
-------------
Index: PGanswermacros.pl
===================================================================
RCS file: /webwork/cvs/system/pg/macros/PGanswermacros.pl,v
retrieving revision 1.31
retrieving revision 1.32
diff -Lmacros/PGanswermacros.pl -Lmacros/PGanswermacros.pl -u -r1.31 -r1.32
--- macros/PGanswermacros.pl
+++ macros/PGanswermacros.pl
@@ -2080,47 +2080,52 @@
## Use this subroutine instead of the
## individual filters below it
-# sub str_filters {
-# my $stringToFilter = shift @_;
-# my @filters_to_use = @_;
-# my %known_filters = (
-# 'remove_whitespace' => &remove_whitespace,
-# 'compress_whitespace' => &compress_whitespace,
-# 'trim_whitespace' => &trim_whitespace,
-# 'ignore_case' => &ignore_case,
-# 'ignore_order' => &ignore_order,
-# );
-#
-# #test for unknown filters
-# foreach my $filter ( @filters_to_use ) {
-# #check that filter is known
-# die "Unknown string filter $filter (try checking the parameters to str_cmp() )"
-# unless exists $known_filters{$filter};
-# $stringToFilter = $known_filters{$filter}($stringToFilter); # apply filter.
-# }
+sub str_filters {
+ my $stringToFilter = shift @_;
+ # filters now take an answer hash, so encapsulate the string
+ # in the answer hash.
+ my $rh_ans = new AnswerHash;
+ $rh_ans->{student_ans} = $stringToFilter;
+ $rh_ans->{correct_ans}='';
+ my @filters_to_use = @_;
+ my %known_filters = (
+ 'remove_whitespace' => \&remove_whitespace,
+ 'compress_whitespace' => \&compress_whitespace,
+ 'trim_whitespace' => \&trim_whitespace,
+ 'ignore_case' => \&ignore_case,
+ 'ignore_order' => \&ignore_order,
+ );
+
+ #test for unknown filters
+ foreach my $filter ( @filters_to_use ) {
+ #check that filter is known
+ die "Unknown string filter $filter (try checking the parameters to str_cmp() )"
+ unless exists $known_filters{$filter};
+ $rh_ans = $known_filters{$filter}($rh_ans); # apply filter.
+ }
# foreach $filter (@filters_to_use) {
# die "Unknown string filter $filter (try checking the parameters to str_cmp() )"
# unless exists $known_filters{$filter};
# }
#
# if( grep( /remove_whitespace/i, @filters_to_use ) ) {
-# $stringToFilter = remove_whitespace( $stringToFilter );
+# $rh_ans = remove_whitespace( $rh_ans );
# }
# if( grep( /compress_whitespace/i, @filters_to_use ) ) {
-# $stringToFilter = compress_whitespace( $stringToFilter );
+# $rh_ans = compress_whitespace( $rh_ans );
# }
# if( grep( /trim_whitespace/i, @filters_to_use ) ) {
-# $stringToFilter = trim_whitespace( $stringToFilter );
+# $rh_ans = trim_whitespace( $rh_ans );
# }
# if( grep( /ignore_case/i, @filters_to_use ) ) {
-# $stringToFilter = ignore_case( $stringToFilter );
+# $rh_ans = ignore_case( $rh_ans );
# }
# if( grep( /ignore_order/i, @filters_to_use ) ) {
-# $stringToFilter = ignore_order( $stringToFilter );
+# $rh_ans = ignore_order( $rh_ans );
# }
-# return $stringToFilter;
-# }
+ return $rh_ans->{student_ans};
+}
sub remove_whitespace {
my $rh_ans = shift;
die "expected an answer hash" unless ref($rh_ans)=~/HASH/i;
@@ -2632,14 +2637,14 @@
my $correctQ = ($in eq $correctAnswer) ? 1: 0;
my $ans_hash = new AnswerHash(
- 'score' => $correctQ,
- 'correct_ans' => "$correctAnswer",
- 'student_ans' => $in,
- 'ans_message' => "",
- 'type' => "checkbox_cmp",
- 'preview_text_string' => $in,
- 'preview_latex_string' => $in,
- 'original_student_ans' => $original_student_ans
+ 'score' => $correctQ,
+ 'correct_ans' => "$correctAnswer",
+ 'student_ans' => $in,
+ 'ans_message' => "",
+ 'type' => "checkbox_cmp",
+ 'preview_text_string' => $in,
+ 'preview_latex_string' => $in,
+ 'original_student_ans' => $original_student_ans
);
return $ans_hash;
|
|
From: dpvc v. a. <we...@ma...> - 2005-07-04 13:21:52
|
Log Message:
-----------
Better spacing of jsMath output in the answer preview area.
Modified Files:
--------------
webwork-modperl/lib/WeBWorK/ContentGenerator:
Problem.pm
Revision Data
-------------
Index: Problem.pm
===================================================================
RCS file: /webwork/cvs/system/webwork-modperl/lib/WeBWorK/ContentGenerator/Problem.pm,v
retrieving revision 1.171
retrieving revision 1.172
diff -Llib/WeBWorK/ContentGenerator/Problem.pm -Llib/WeBWorK/ContentGenerator/Problem.pm -u -r1.171 -r1.172
--- lib/WeBWorK/ContentGenerator/Problem.pm
+++ lib/WeBWorK/ContentGenerator/Problem.pm
@@ -311,7 +311,7 @@
} elsif ($displayMode eq "images") {
$imgGen->add($tex);
} elsif ($displayMode eq "jsMath") {
- return '<DIV CLASS="math">'.$tex.'</DIV>' ;
+ return '<SPAN CLASS="math">\\displaystyle{'.$tex.'}</SPAN>';
}
}
|
|
From: dpvc v. a. <we...@ma...> - 2005-07-04 13:19:01
|
Log Message:
-----------
Change so as not to use raw HTML in the error messages.
Modified Files:
--------------
pg/lib/Value:
AnswerChecker.pm
Revision Data
-------------
Index: AnswerChecker.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/AnswerChecker.pm,v
retrieving revision 1.47
retrieving revision 1.48
diff -Llib/Value/AnswerChecker.pm -Llib/Value/AnswerChecker.pm -u -r1.47 -r1.48
--- lib/Value/AnswerChecker.pm
+++ lib/Value/AnswerChecker.pm
@@ -144,7 +144,7 @@
} else {
return if $ans->{ignoreStrings} && (!Value::isValue($student) || $student->type eq 'String');
$ans->{ans_message} = $ans->{error_message} =
- "Your answer isn't ".lc($ans->{cmp_class}).'<BR>'.
+ "Your answer isn't ".lc($ans->{cmp_class})."\n".
"(it looks like ".lc($student->showClass).")"
if !$ans->{isPreview} && $ans->{showTypeWarnings} && !$ans->{error_message};
}
|
|
From: dpvc v. a. <we...@ma...> - 2005-07-04 03:31:12
|
Log Message:
-----------
Allow Parser::Number::NoDecimals() to accept a context to be modified
(rather than always changing the curent context).
Modified Files:
--------------
pg/lib/Parser:
Number.pm
Revision Data
-------------
Index: Number.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/Number.pm,v
retrieving revision 1.9
retrieving revision 1.10
diff -Llib/Parser/Number.pm -Llib/Parser/Number.pm -u -r1.9 -r1.10
--- lib/Parser/Number.pm
+++ lib/Parser/Number.pm
@@ -71,7 +71,10 @@
###########################################
-sub NoDecimals {$$Value::context->flags->set(NumberCheck=>\&_NoDecimals)}
+sub NoDecimals {
+ my $context = shift || $$Value::context;
+ $context->flags->set(NumberCheck=>\&_NoDecimals);
+}
sub _NoDecimals {
my $self = shift;
|
|
From: dpvc v. a. <we...@ma...> - 2005-07-03 20:13:38
|
Log Message:
-----------
Updates to allow string matches to be case-insensitive. This is now
the default, and can be overridden in the Context by setting the
string's "caseSensitive" attribute. e.g.:
Context()->strings->add("FooBar"=>{caseSensitive=>1});
would rewuire "FooBar" to be entered exactly as typed.
Modified Files:
--------------
pg/macros:
contextABCD.pl
contextTF.pl
pg/lib/Parser:
String.pm
pg/lib/Parser/Context:
Default.pm
Strings.pm
pg/lib/Value:
String.pm
Revision Data
-------------
Index: contextABCD.pl
===================================================================
RCS file: /webwork/cvs/system/pg/macros/contextABCD.pl,v
retrieving revision 1.2
retrieving revision 1.3
diff -Lmacros/contextABCD.pl -Lmacros/contextABCD.pl -u -r1.2 -r1.3
--- macros/contextABCD.pl
+++ macros/contextABCD.pl
@@ -32,10 +32,10 @@
$context{ABCD} = Context("String")->copy;
$context{ABCD}->strings->are(
- "A" => {}, "a" => {alias => "A"},
- "B" => {}, "b" => {alias => "B"},
- "C" => {}, "c" => {alias => "C"},
- "D" => {}, "d" => {alias => "D"},
+ "A" => {},
+ "B" => {},
+ "C" => {},
+ "D" => {},
);
$context{'ABCD-List'} = $context{ABCD}->copy;
Index: contextTF.pl
===================================================================
RCS file: /webwork/cvs/system/pg/macros/contextTF.pl,v
retrieving revision 1.3
retrieving revision 1.4
diff -Lmacros/contextTF.pl -Lmacros/contextTF.pl -u -r1.3 -r1.4
--- macros/contextTF.pl
+++ macros/contextTF.pl
@@ -11,7 +11,9 @@
#
# You can add new strings to the context as needed (or remove old ones)
# via the Context()->strings->add() and Context()-strings->remove()
-# methods
+# methods.
+#
+# Use
#
# ANS(string_cmp("T","F"));
#
@@ -20,11 +22,10 @@
$context{TF} = Context("String")->copy;
$context{TF}->strings->are(
- "T" => {value => 1}, "t" => {alias => "T"},
- "F" => {value => 0}, "f" => {alias => "F"},
- "True" => {alias => "T"}, "False" => {alias => "F"},
- "TRUE" => {alias => "T"}, "FALSE" => {alias => "F"},
- "true" => {alias => "T"}, "false" => {alias => "F"},
+ "T" => {value => 1},
+ "F" => {value => 0},
+ "True" => {alias => "T"},
+ "False" => {alias => "F"},
);
Context("TF");
Index: String.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/String.pm,v
retrieving revision 1.7
retrieving revision 1.8
diff -Llib/Parser/String.pm -Llib/Parser/String.pm -u -r1.7 -r1.8
--- lib/Parser/String.pm
+++ lib/Parser/String.pm
@@ -17,6 +17,10 @@
my $equation = shift;
my ($value, $ref) = @_;
my $def = $equation->{context}{strings}{$value};
+ unless ($def) {
+ $def = $equation->{context}{strings}{uc($value)};
+ $def = undef if $def->{caseSensitive} && $value ne uc($value);
+ }
$value = $def->{alias}, $def = $equation->{context}{strings}{$value}
if defined($def->{alias});
my $str = bless {
Index: Strings.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/Context/Strings.pm,v
retrieving revision 1.4
retrieving revision 1.5
diff -Llib/Parser/Context/Strings.pm -Llib/Parser/Context/Strings.pm -u -r1.4 -r1.5
--- lib/Parser/Context/Strings.pm
+++ lib/Parser/Context/Strings.pm
@@ -15,6 +15,72 @@
$self->{namePattern} = '[\S ]+';
}
+#
+# Allow for case-insensitive strings.
+# Case-insensitive is now the default.
+# You can use
+#
+# $context->strings->set(name=>{caseSensitive=>1});
+#
+# to get a case-sensitive string called "name".
+#
+sub update {
+ my $self = shift;
+ my $data = $self->{context}->{$self->{dataName}};
+ my $single = ''; my @multi = ();
+ foreach my $x (sort Value::Context::Data::byName (keys %{$data})) {
+ unless ($data->{$x}{hidden}) {
+ if ($data->{$x}{caseSensitive} || uc($x) eq lc($x)) {
+ if (length($x) == 1) {$single .= $x}
+ else {push(@multi,protectRegexp($x))}
+ } else {
+ if (length($x) == 1) {$single .= uc($x).lc($x)}
+ else {push(@multi,"(?:(?i)".protectRegexp($x).")")}
+ }
+ }
+ }
+ $self->{pattern} = $self->getPattern($single,@multi);
+ $self->{context}->update;
+}
+
+#
+# Same as Value::Context::Data::getPattern, but with
+# the protectRegexp already done on the @multi list.
+#
+sub getPattern {
+ shift; my $s = shift;
+# foreach my $x (@_) {$x = protectRegexp($x)}
+ my @pattern = ();
+ push(@pattern,join('|',@_)) if scalar(@_) > 0;
+ push(@pattern,protectRegexp($s)) if length($s) == 1;
+ push(@pattern,"[".protectChars($s)."]") if length($s) > 1;
+ my $pattern = join('|',@pattern);
+ $pattern = '^$' if $pattern eq '';
+ return $pattern;
+}
+
+#
+# Add lower-case alias for case-insensitive strings
+# (so we can always find their definitions)
+#
+sub add {
+ my $self = shift; return if scalar(@_) == 0;
+ my $data = $self->{context}{$self->{dataName}};
+ $self->SUPER::add(@_);
+ my %D = (@_);
+ foreach my $x (keys %D) {
+ $data->{uc($x)} = {alias => $x}
+ unless $data->{$x}{caseSensitive} || uc($x) eq $x;
+ }
+}
+
+#
+# Call the ones in Value::Context::Data
+#
+sub protectRegexp {Value::Context::Data::protectRegexp(@_)}
+sub protectChars {Value::Context::Data::protectChars(@_)}
+
+
#########################################################################
1;
Index: Default.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/Context/Default.pm,v
retrieving revision 1.25
retrieving revision 1.26
diff -Llib/Parser/Context/Default.pm -Llib/Parser/Context/Default.pm -u -r1.25 -r1.26
--- lib/Parser/Context/Default.pm
+++ lib/Parser/Context/Default.pm
@@ -182,16 +182,9 @@
$strings = {
'infinity' => {infinite => 1},
- 'INFINITY' => {alias => 'infinity'},
'inf' => {alias => 'infinity'},
- 'INF' => {alias => 'infinity'},
-
'NONE' => {},
- 'none' => {alias => 'NONE'},
-
'DNE' => {},
- 'dne' => {alias => 'DNE'},
-
# 'T' => {true => 1},
# 'F' => {false => 1},
};
Index: String.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/String.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -Llib/Value/String.pm -Llib/Value/String.pm -u -r1.5 -r1.6
--- lib/Value/String.pm
+++ lib/Value/String.pm
@@ -20,11 +20,18 @@
sub new {
my $self = shift; my $class = ref($self) || $self;
my $x = join('',@_);
+ my $s = bless {data => [$x]}, $class;
if ($Parser::installed) {
- Value::Error("String constant '$x' is not defined in this context")
- unless $$Value::context->{strings}{$x};
+ my $strings = $$Value::context->{strings};
+ if (!$strings->{$x}) {
+ my $X = $strings->{uc($x)};
+ Value::Error("String constant '$x' is not defined in this context")
+ unless $X && !$X->{caseSensitive};
+ $x = uc($x); while ($strings->{$x}{alias}) {$x = $strings->{$x}{alias}}
+ }
+ $s->{caseSensitive} = 1 if $strings->{$x}{caseSensitive};
}
- bless {data => [$x]}, $class;
+ return $s;
}
#
@@ -53,12 +60,12 @@
#
# Operations on strings
#
-
sub compare {
my ($l,$r,$flag) = @_;
if ($l->promotePrecedence($r)) {return $r->compare($l,!$flag)}
$r = promote($r); if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
- return $l->value cmp $r->value;
+ return $l->value cmp $r->value if $l->{caseSensitive} || $r->{caseSensitive};
+ return uc($l->value) cmp uc($r->value);
}
############################################
|
|
From: dpvc v. a. <we...@ma...> - 2005-07-03 20:09:37
|
Log Message:
-----------
Adjusted some spacing
Modified Files:
--------------
pg/lib/Value/Context:
Data.pm
pg/macros:
PGcommonFunctions.pl
Revision Data
-------------
Index: Data.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Context/Data.pm,v
retrieving revision 1.4
retrieving revision 1.5
diff -Llib/Value/Context/Data.pm -Llib/Value/Context/Data.pm -u -r1.4 -r1.5
--- lib/Value/Context/Data.pm
+++ lib/Value/Context/Data.pm
@@ -61,7 +61,7 @@
foreach my $x (@_) {$x = protectRegexp($x)}
my @pattern = ();
push(@pattern,join('|',@_)) if scalar(@_) > 0;
- push(@pattern,protectRegexp($s)) if length($s) ==1;
+ push(@pattern,protectRegexp($s)) if length($s) == 1;
push(@pattern,"[".protectChars($s)."]") if length($s) > 1;
my $pattern = join('|',@pattern);
$pattern = '^$' if $pattern eq '';
Index: PGcommonFunctions.pl
===================================================================
RCS file: /webwork/cvs/system/pg/macros/PGcommonFunctions.pl,v
retrieving revision 1.5
retrieving revision 1.6
diff -Lmacros/PGcommonFunctions.pl -Lmacros/PGcommonFunctions.pl -u -r1.5 -r1.6
--- macros/PGcommonFunctions.pl
+++ macros/PGcommonFunctions.pl
@@ -62,20 +62,19 @@
sub sgn {$_[1] <=> 0}
-#our @ISA = qw(Parser::Function::numeric2);
sub C {
shift; my ($n,$r) = @_; my $C = 1;
- return (0) if($r>$n);
+ return(0) if ($r>$n);
$r = $n-$r if ($r > $n-$r); # find the smaller of the two
for (1..$r) {$C = ($C*($n-$_+1))/$_}
- return $C
+ return $C;
}
sub P {
shift; my ($n,$r) = @_; my $P = 1;
- return (0) if($r>$n);
+ return(0) if ($r>$n);
for (1..$r) {$P *= ($n-$_+1)}
- return $P
+ return $P;
}
|
|
From: dpvc v. a. <we...@ma...> - 2005-07-03 20:08:30
|
Log Message:
-----------
Fixed a bug in the enable/disable routines that would cause them to
always work on the current context rather than the one whose
enable/disable method was being called.
Modified Files:
--------------
pg/lib/Parser/Context:
Functions.pm
Revision Data
-------------
Index: Functions.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/Context/Functions.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -Llib/Parser/Context/Functions.pm -Llib/Parser/Context/Functions.pm -u -r1.5 -r1.6
--- lib/Parser/Context/Functions.pm
+++ lib/Parser/Context/Functions.pm
@@ -55,9 +55,9 @@
sub disable {Disable(@_)}
sub Disable {
- shift if ref($_[0]) ne ""; # pop off the $self reference
- my @names = @_; my ($list,$name);
my $context = Parser::Context->current;
+ if (ref($_[0]) ne "") {$context = (shift)->{context}}
+ my @names = @_; my ($list,$name);
while ($name = shift(@names)) {
$list = $Category{$name};
$list = [$name] if !$list && $context->{functions}{$name};
@@ -70,9 +70,9 @@
sub enable {Enable(@_)}
sub Enable {
- shift if ref($_[0]) ne ""; # pop off the $self reference
- my @names = @_; my ($list,$name);
my $context = Parser::Context->current;
+ if (ref($_[0]) ne "") {$context = (shift)->{context}}
+ my @names = @_; my ($list,$name);
while ($name = shift(@names)) {
$list = $Category{$name};
$list = [$name] if !$list && $context->{functions}{$name};
|
|
From: dpvc v. a. <we...@ma...> - 2005-07-02 17:07:34
|
Log Message:
-----------
Fixed an error in creating the tarred archives (I had messed it up
when adding the report of how many files were archived).
Modified Files:
--------------
webwork-modperl/lib/WeBWorK/ContentGenerator/Instructor:
FileManager.pm
Revision Data
-------------
Index: FileManager.pm
===================================================================
RCS file: /webwork/cvs/system/webwork-modperl/lib/WeBWorK/ContentGenerator/Instructor/FileManager.pm,v
retrieving revision 1.9
retrieving revision 1.10
diff -Llib/WeBWorK/ContentGenerator/Instructor/FileManager.pm -Llib/WeBWorK/ContentGenerator/Instructor/FileManager.pm -u -r1.9 -r1.10
--- lib/WeBWorK/ContentGenerator/Instructor/FileManager.pm
+++ lib/WeBWorK/ContentGenerator/Instructor/FileManager.pm
@@ -650,7 +650,8 @@
my $dir = $self->{courseRoot}.'/'.$self->{pwd};
my $archive = uniqueName($dir,(scalar(@files) == 1)?
$files[0].".tgz": $self->{courseName}.".tgz");
- my $tar = "cd '$dir' && $self->{ce}{externalPrograms}{tar} -czf $archive ";
+ my $tar = "cd '$dir' && $self->{ce}{externalPrograms}{tar} -cvzf $archive ";
+ $tar .= join(" ",@files);
my $files = `$tar`; chomp($files);
if ($? == 0) {
my @files = split(/\n/,$files);
|
|
From: dpvc v. a. <we...@ma...> - 2005-07-02 16:55:38
|
Log Message:
-----------
Major updates to the file manager to allow it to:
1. Show dates and sizes of files (optionally, since some browsers
don't handle the CSS to change to a monospaced font).
2. Provide better control over renaming of uploaded files whose
names already exist (there is a checkbox for overwriting them
automatically; if unchecked, the user is prompted for a new name).
3. Allow the creation or gzipped tar archives from files in the
course directory. Multiple files and directories can be selected
to be included in the archive. If only one file is selected, the
archive will have it's name with ".tgz" appended; if mulitple
files are selected, the archive will get a unique name starting
with the course ID.
4. Provide a checkbox that controls whether uploaded .tgz archives
are unpacked automatically, and a second that controls whether the
unpacked archive file is deleted afterward. Files from the
archive will be unpacked into the current directory, and will
overwrite existing files silently.
5. Follow symbolic links that are to files or directories within the
course hierarchy. In addition, there is a new variable in
global.conf that provides a list of "valid links"; these are
directories to which the FileManager is allowed to follow symbolic
links. The system administator can add directories to this list
in order to allow professors to access limited areas outside their
course directory (but they still need to have a symblic link
within their course to those areas in order to view them).
I think this covers all the current FileManager requests, and this
closes bug#791.
Modified Files:
--------------
webwork-modperl/conf:
global.conf.dist
webwork-modperl/lib/WeBWorK/ContentGenerator/Instructor:
FileManager.pm
Revision Data
-------------
Index: global.conf.dist
===================================================================
RCS file: /webwork/cvs/system/webwork-modperl/conf/global.conf.dist,v
retrieving revision 1.119
retrieving revision 1.120
diff -Lconf/global.conf.dist -Lconf/global.conf.dist -u -r1.119 -r1.120
--- conf/global.conf.dist
+++ conf/global.conf.dist
@@ -57,6 +57,8 @@
$externalPrograms{dvipng} = "/usr/local/bin/dvipng";
$externalPrograms{tth} = "/usr/local/bin/tth";
+$externalPrograms{tar} = "/usr/bin/tar";
+
################################################################################
# Mail settings
################################################################################
@@ -130,6 +132,12 @@
# Contains non-web-accessible temporary files, such as TeX working directories.
$webworkDirs{tmp} = "$webworkDirs{root}/tmp";
+# The (absolute) destinations of symbolic links that are OK for the FileManager to follow.
+# (any subdirectory of these is a valid target for a symbolic link.)
+# For example:
+# $webworkDirs{valid_symlinks} = ["$webworkDirs{courses}/modelCourse/templates","/ww2/common/sets"];
+$webworkDirs{valid_symlinks} = [];
+
##### The following locations are web-accessible.
# The root URL (usually /webwork2), set by <Location> in Apache configuration.
Index: FileManager.pm
===================================================================
RCS file: /webwork/cvs/system/webwork-modperl/lib/WeBWorK/ContentGenerator/Instructor/FileManager.pm,v
retrieving revision 1.8
retrieving revision 1.9
diff -Llib/WeBWorK/ContentGenerator/Instructor/FileManager.pm -Llib/WeBWorK/ContentGenerator/Instructor/FileManager.pm -u -r1.8 -r1.9
--- lib/WeBWorK/ContentGenerator/Instructor/FileManager.pm
+++ lib/WeBWorK/ContentGenerator/Instructor/FileManager.pm
@@ -21,6 +21,7 @@
use WeBWorK::Upload;
use File::Path;
use File::Copy;
+use File::Spec;
=head1 NAME
@@ -73,7 +74,7 @@
sub downloadFile {
my $self = shift;
my $file = checkName(shift);
- my $pwd = checkPWD(shift || $self->r->param('pwd') || '.');
+ my $pwd = $self->checkPWD(shift || $self->r->param('pwd') || '.');
return unless $pwd;
$pwd = $self->{ce}{courseDirs}{root} . '/' . $pwd;
unless (-e "$pwd/$file") {
@@ -111,7 +112,7 @@
return CGI::em("You are not authorized to access the instructor tools")
unless $authz->hasPermissions($user, "access_instructor_tools");
- $self->{pwd} = checkPWD($r->param('pwd') || '.');
+ $self->{pwd} = $self->checkPWD($r->param('pwd') || '.');
return CGI::em("You have specified an illegal working directory!") unless defined $self->{pwd};
my $fileManagerPage = $urlpath->newFromModule($urlpath->module, courseID => $courseName);
@@ -128,7 +129,7 @@
$self->{courseRoot} = $courseRoot;
$self->{courseName} = $courseName;
- my $action = $r->param('action') || $r->param('formAction') || 'Refresh';
+ my $action = $r->param('action') || $r->param('formAction') || 'Init';
for ($action) {
/^Refresh/i and do {$self->Refresh; last};
@@ -142,12 +143,15 @@
/^Copy/i and do {$self->Copy; last};
/^Rename/i and do {$self->Rename; last};
/^Delete/i and do {$self->Delete; last};
+ /^GZIP/i and do {$self->GZIP; last};
+ /^UNGZIP/i and do {$self->UNGZIP; last};
/^New Folder/i and do {$self->NewFolder; last};
/^New File/i and do {$self->NewFile; last};
/^Upload/i and do {$self->Upload; last};
/^Revert/i and do {$self->Edit; last};
/^Save As/i and do {$self->SaveAs; last};
/^Save/i and do {$self->Save; last};
+ /^Init/i and do {$self->Init; last};
$self->addbadmessage("Unknown action.");
$self->Refresh;
}
@@ -162,15 +166,36 @@
##################################################
#
+# First time through
+#
+sub Init {
+ my $self = shift;
+ $self->r->param('unpack',1);
+ $self->r->param('autodelete',1);
+ $self->r->param('format','Automatic');
+ $self->Refresh;
+}
+
+sub HiddenFlags {
+ my $self = shift;
+ print CGI::hidden({name=>"dates", value=>$self->getFlag('dates')});
+ print CGI::hidden({name=>"overwrite", value=>$self->getFlag('overwrite')});
+ print CGI::hidden({name=>"unpack", value=>$self->getFlag('unpack')});
+ print CGI::hidden({name=>"autodelete",value=>$self->getFlag('autodelete')});
+ print CGI::hidden({name=>"format", value=>$self->getFlag('format','Automatic')});
+}
+
+##################################################
+#
# Display the directory listing and associated buttons
#
sub Refresh {
- my $self = shift;
+ my $self = shift;
my $pwd = shift || $self->{pwd};
my $isTop = $pwd eq '.' || $pwd eq '';
my ($dirs,$dirlabels) = directoryMenu($self->{courseName},$pwd);
- my ($files,$filelabels) = directoryListing($self->{courseRoot},$pwd);
+ my ($files,$filelabels) = directoryListing($self->{courseRoot},$pwd,$self->getFlag('dates'));
unless ($files) {
$self->addbadmessage("The directory you specified doesn't exist");
@@ -199,24 +224,35 @@
disableButton('Rename',state);
disableButton('Copy',state);
disableButton('Delete',state);
+ disableButton('GZIP',state);
+ checkGZIP(files,state);
}
function checkFile() {
var file = window.document.getElementById('file');
var state = (file.value == "");
disableButton('Upload',state);
}
+ function checkGZIP(files,disabled) {
+ var gzip = document.getElementById('GZIP');
+ gzip.value = 'GZIP';
+ if (disabled) return;
+ if (!files.childNodes[files.selectedIndex].value.match(/\\.tgz\$/)) return;
+ for (var i = files.selectedIndex+1; i < files.length; i++)
+ {if (files.childNodes[i].selected) return}
+ gzip.value = 'UNGZIP';
+ }
EOF
#
# Start the table
#
- print CGI::start_table({border=>0,cellpadding=>0,cellspacing=>10, style=>"margin:1em 0 0 3em"});
+ print CGI::start_table({border=>0,cellpadding=>0,cellspacing=>3, style=>"margin:1em 0 0 3em"});
#
- # Directory menu
+ # Directory menu and date/size checkbox
#
print CGI::Tr(
- CGI::td({colspan=>3},
+ CGI::td({colspan=>2},
CGI::input({type=>"submit", name=>"action", value => "^", ($isTop? (disabled=>1): ())}),
CGI::popup_menu(
-name => "directory",
@@ -226,25 +262,33 @@
-onChange => "doForm('Go')"
),
CGI::noscript(CGI::input({type=>"submit",name=>"action",value=>"Go"}))
- )
+ ),
+ CGI::td(CGI::small(CGI::checkbox(
+ -name => 'dates',
+ -checked => $self->getFlag('dates'),
+ -value => 1,
+ -label => 'Show Date & Size',
+ -onClick => 'doForm("Refresh")',
+ ))),
);
#
- # Directory Listing
+ # Directory Listing and column of buttons
#
my %button = (type=>"submit",name=>"action",style=>"width:10em");
+ my $width = ($self->getFlag('dates') && scalar(@{$files}) > 0) ? "": " width:30em";
print CGI::Tr({valign=>"middle"},
- CGI::td(CGI::scrolling_list(
+ fixSpaces(CGI::td(CGI::scrolling_list(
-name => "files", id => "files",
- -style => "font-family:monospace; width:30em",
- -size => 15,
+ -style => "font-family:monospace; $width",
+ -size => 17,
-multiple => 1,
-values => $files,
-labels => $filelabels,
-onDblClick => "doForm('View')",
-onChange => "checkFiles()"
- )),
- CGI::td({width=>3}),
+ ))),
+ CGI::td({width=>15}),
CGI::td(
CGI::start_table({border=>0,cellpadding=>0,cellspacing=>3}),
CGI::Tr([
@@ -254,6 +298,7 @@
CGI::td(CGI::input({%button,value=>"Rename",id=>"Rename"})),
CGI::td(CGI::input({%button,value=>"Copy",id=>"Copy"})),
CGI::td(CGI::input({%button,value=>"Delete",id=>"Delete"})),
+ CGI::td(CGI::input({%button,value=>"GZIP",id=>"GZIP"})),
CGI::td({height=>10}),
CGI::td(CGI::input({%button,value=>"New File"})),
CGI::td(CGI::input({%button,value=>"New Folder"})),
@@ -264,7 +309,7 @@
);
#
- # Upload button
+ # Upload button and checkboxes
#
print CGI::Tr([
CGI::td(),
@@ -273,7 +318,20 @@
CGI::input({type=>"file",name=>"file",id=>"file",size=>40,onChange=>"checkFile()"}),
CGI::br(),
CGI::small(join(' ',"Format:",
- CGI::radio_group('format',['Text','Binary','Automatic'],'Automatic'))),
+ CGI::radio_group('format',['Text','Binary','Automatic'],
+ $self->getFlag('format','Automatic')))),
+ ),
+ ]);
+ print CGI::Tr([
+ CGI::td(),
+ CGI::td({colspan=>3},
+ CGI::small(CGI::checkbox('overwrite',$self->getFlag('overwrite'),1,
+ 'Overwrite existing files silently')),
+ CGI::br(),
+ CGI::small(CGI::checkbox('unpack',$self->getFlag('unpack'),1,
+ 'Unpack archives automatically')),
+ CGI::small(CGI::checkbox('autodelete',$self->getFlag('autodelete'),1,
+ 'then delete them')),
),
]);
@@ -312,11 +370,19 @@
my $self = shift; my $pwd = $self->{pwd};
my $filename = $self->getFile("view"); return unless $filename;
my $name = "$pwd/$filename"; $name =~ s!^\./?!!;
+ my $file = "$self->{courseRoot}/$pwd/$filename";
+
+ #
+ # Don't follow symbolic links
+ #
+ if ($self->isSymLink($file)) {
+ $self->addbadmessage("That symbolic link takes you outside your course directory");
+ $self->Refresh; return;
+ }
#
# Handle directories by making them the working directory
#
- my $file = "$self->{courseRoot}/$pwd/$filename";
if (-d $file) {
$self->{pwd} .= '/'.$filename;
$self->Refresh; return;
@@ -447,7 +513,8 @@
),
]);
print CGI::end_table();
- print CGI::hidden({name=>"files",value=>$file});
+ print CGI::hidden({name=>"files", value=>$file});
+ $self->SaveHiddenFlags;
}
##################################################
@@ -456,9 +523,9 @@
#
sub Copy {
my $self = shift;
- my $oldfile = $self->getFile('copy'); return unless $oldfile;
- my $original = $oldfile;
- $oldfile = "$self->{courseRoot}/$self->{pwd}/$oldfile";
+ my $dir = "$self->{courseRoot}/$self->{pwd}";
+ my $original = $self->getFile('copy'); return unless $original;
+ my $oldfile = "$dir/$original";
if (-d $oldfile) {
# FIXME: need to do recursive directory copy
@@ -477,7 +544,7 @@
}
}
- Confirm("Copy file as:","Copy");
+ $self->Confirm("Copy file as:",$original,"Copy");
print CGI::hidden({name=>"files",value=>$original});
}
@@ -487,21 +554,21 @@
#
sub Rename {
my $self = shift;
- my $oldfile = $self->getFile('rename'); return unless $oldfile;
- my $original = $oldfile;
- $oldfile = "$self->{courseRoot}/$self->{pwd}/$oldfile";
+ my $dir = "$self->{courseRoot}/$self->{pwd}";
+ my $original = $self->getFile('rename'); return unless $original;
+ my $oldfile = "$dir/$original";
if ($self->r->param('confirmed')) {
my $newfile = $self->r->param('name');
if ($newfile = $self->verifyPath($newfile,$original)) {
if (rename $oldfile, $newfile) {
- $self->addgoodmessage("File successfully renamed");
- $self->Refresh; return;
+ $self->addgoodmessage("File successfully renamed");
+ $self->Refresh; return;
} else {$self->addbadmessage("Can't rename file: $!")}
}
}
- Confirm("Rename file as:","Rename");
+ $self->Confirm("Rename file as:",uniqueName($dir,$original),"Rename");
print CGI::hidden({name=>"files",value=>$original});
}
@@ -525,7 +592,7 @@
# If confirmed, go ahead and delete the files
#
foreach my $file (@files) {
- if (defined checkPWD("$pwd/$file",1)) {
+ if (defined $self->checkPWD("$pwd/$file",1)) {
if (-d "$dir/$file") {
my $removed = eval {rmtree("$dir/$file",0,1)};
if ($removed) {$self->addgoodmessage("Directory '$file' removed (items deleted: $removed)")}
@@ -564,6 +631,66 @@
print CGI::hidden({name=>"confirmed",value=>1});
foreach my $file (@files) {print CGI::hidden({name=>"files",value=>$file})}
+ $self->HiddenFlags;
+ }
+}
+
+##################################################
+#
+# Make a gzipped tar archive
+#
+sub GZIP {
+ my $self = shift;
+ my @files = $self->r->param('files');
+ if (scalar(@files) == 0) {
+ $self->addbadmessage("You must select at least one file to GZIP");
+ $self->Refresh; return;
+ }
+
+ my $dir = $self->{courseRoot}.'/'.$self->{pwd};
+ my $archive = uniqueName($dir,(scalar(@files) == 1)?
+ $files[0].".tgz": $self->{courseName}.".tgz");
+ my $tar = "cd '$dir' && $self->{ce}{externalPrograms}{tar} -czf $archive ";
+ my $files = `$tar`; chomp($files);
+ if ($? == 0) {
+ my @files = split(/\n/,$files);
+ my $n = scalar(@files); my $s = ($n == 1? "": "s");
+ $self->addgoodmessage("Archive '$archive' created successfully ($n file$s)");
+ } else {
+ $self->addbadmessage("Can't create archive '$archive': comand returned ".systemError($?));
+ }
+ $self->Refresh;
+}
+
+##################################################
+#
+# Unpack a gzipped tar archive
+#
+sub UNGZIP {
+ my $self = shift;
+ my $archive = $self->getFile("UNGZIP"); return unless $archive;
+ if ($archive !~ m/\.tgz$/) {
+ $self->addbadmessage("You can only unpack files ending in '.tgz'");
+ } else {
+ $self->ungzip($archive);
+ }
+ $self->Refresh;
+}
+
+sub ungzip {
+ my $self = shift;
+ my $archive = shift;
+ my $dir = $self->{courseRoot}.'/'.$self->{pwd};
+ my $tar = "cd '$dir' && $self->{ce}{externalPrograms}{tar} -vxzf $archive";
+ my $files = `$tar`; chomp($files);
+ if ($? == 0) {
+ my @files = split(/\n/,$files);
+ my $n = scalar(@files); my $s = ($n == 1? "": "s");
+ $self->addgoodmessage("$n file$s unpacked successfully");
+ return 1;
+ } else {
+ $self->addbadmessage("Can't unpack '$archive': command returned ".systemError($?));
+ return 0;
}
}
@@ -585,7 +712,7 @@
}
}
- Confirm("New file name:","New File");
+ $self->Confirm("New file name:","","New File");
}
##################################################
@@ -605,7 +732,7 @@
}
}
- Confirm("New folder name:","New Folder");
+ $self->Confirm("New folder name:","","New Folder");
}
##################################################
@@ -614,9 +741,9 @@
#
sub Download {
my $self = shift;
- my $filename = $self->getFile("download"); return unless $filename;
- my $pwd = checkPWD($self->r->param('pwd') || '.');
+ my $pwd = $self->checkPWD($self->r->param('pwd') || '.');
return unless $pwd;
+ my $filename = $self->getFile("download"); return unless $filename;
my $file = $self->{ce}{courseDirs}{root}.'/'.$pwd.'/'.$filename;
if (-d $file) {$self->addbadmessage("You can't download directories"); return}
@@ -642,16 +769,30 @@
my ($id,$hash) = split(/\s+/,$fileIDhash);
my $upload = WeBWorK::Upload->retrieve($id,$hash,dir=>$self->{ce}{webworkDirs}{uploadCache});
- my $name = uniqueName($dir,checkName($upload->filename));
+ my $name = checkName($upload->filename);
+ my $action = $self->r->param("formAction") || "Cancel";
+ if ($self->r->param("confirmed")) {
+ if ($action eq "Cancel") {
+ $upload->dispose;
+ $self->Refresh;
+ return;
+ }
+ $name = checkName($self->r->param('name')) if ($action eq "Rename");
+ }
+
if (-e "$dir/$name") {
- $self->addbadmessage("A file with that name already exists");
- $self->Refresh;
- $upload->dispose;
- return;
+ unless ($self->r->param('overwrite') || $action eq "Overwrite") {
+ $self->Confirm("File ".CGI::b($name)." already exists. Overwrite it, or rename it as:".
+ CGI::p(),uniqueName($dir,$name),"Rename","Overwrite");
+ print CGI::hidden({name=>"action",value=>"Upload"});
+ print CGI::hidden({name=>"file",value=>$fileIDhash});
+ return;
+ }
}
$self->checkFileLocation($name,$self->{pwd});
- my $type = $self->r->param('format') || 'automatic';
+ my $file = "$dir/$name";
+ my $type = $self->getFlag('format','Automatic');
my $data;
#
@@ -663,15 +804,24 @@
if ($type eq 'Automatic') {$type = isText($data) ? 'Text' : 'Binary'}
}
if ($type eq 'Text') {
+ $upload->dispose;
$data =~ s/\r\n?/\n/g;
- open(UPLOAD,">$dir/$name") || $self->addbadmessage("Can't create file '$name'");
+ open(UPLOAD,">$file") || $self->addbadmessage("Can't create file '$name'");
print UPLOAD $data; close(UPLOAD);
- $upload->dispose();
} else {
- $upload->disposeTo("$dir/$name");
+ $upload->disposeTo($file);
+ }
+
+ if (-e $file) {
+ $self->addgoodmessage("$type file '$name' uploaded successfully");
+ if ($name =~ m/\.tgz$/ && $self->getFlag('unpack')) {
+ if ($self->ungzip($name) && $self->getFlag('autodelete')) {
+ if (unlink($file)) {$self->addgoodmessage("Archive '$name' deleted")}
+ else {$self->addbadmessage("Can't delete archive '$name': $!")}
+ }
+ }
}
- $self->addgoodmessage("$type file '$name' uploaded successfully");
$self->Refresh;
}
@@ -681,30 +831,35 @@
# Print a confirmation dialog box
#
sub Confirm {
- my $message = shift;
- my $button = shift;
+ my $self = shift;
+ my $message = shift; my $value = shift;
+ my $button = shift; my $button2 = shift;
print CGI::p();
print CGI::start_table({border=>1,cellspacing=>2,cellpadding=>20, style=>"margin: 1em 0 0 3em"});
print CGI::Tr(
- CGI::td(
+ CGI::td({align=>"CENTER"},
$message,
- CGI::input({type=>"text",name=>"name",size=>50}),
- CGI::p(),
- CGI::div({style=>"float:right; padding-right:3ex"},
- CGI::input({type=>"submit",name=>"action",value=>$button})), # this will be the default
- CGI::div({style=>"float:left; padding-left:3ex"},
- CGI::input({type=>"submit",name=>"action",value=>"Cancel"})),
- ),
- );
+ CGI::input({type=>"text",name=>"name",size=>50,value=>$value}),
+ CGI::p(), CGI::center(
+ CGI::div({style=>"float:right; padding-right:3ex"},
+ CGI::input({type=>"submit",name=>"formAction",value=>$button})), # this will be the default
+ CGI::div({style=>"float:left; padding-left:3ex"},
+ CGI::input({type=>"submit",name=>"formAction",value=>"Cancel"})),
+ ($button2 ? CGI::input({type=>"submit",name=>"formAction",value=>$button2}): ()),
+ ),
+ ),
+ );
print CGI::end_table();
- print CGI::hidden({name=>"confirmed",value=>1});
+ print CGI::hidden({name=>"confirmed", value=>1});
+ $self->HiddenFlags;
print CGI::script("window.document.FileManager.name.focus()");
}
##################################################
+##################################################
#
-# Check that there is exactly one vailid file
+# Check that there is exactly one valid file
#
sub getFile {
my $self = shift; my $action = shift;
@@ -719,9 +874,17 @@
$self->Refresh unless $action eq 'download';
return;
}
- my $pwd = checkPWD($self->{pwd} || $self->r->param('pwd') || '.') || '.';
- $self->addbadmessage("You have specified an illegal file")
- unless checkPWD($pwd.'/'.$files[0],1);
+ my $pwd = $self->checkPWD($self->{pwd} || $self->r->param('pwd') || '.') || '.';
+ if ($self->isSymLink($pwd.'/'.$files[0])) {
+ $self->addbadmessage("That symbolic link takes you outside your course directory");
+ $self->Refresh unless $action eq 'download';
+ return;
+ }
+ unless ($self->checkPWD($pwd.'/'.$files[0],1)) {
+ $self->addbadmessage("You have specified an illegal file");
+ $self->Refresh unless $action eq 'download';
+ return;
+ }
return $files[0];
}
@@ -750,32 +913,98 @@
# Get the directory listing
#
sub directoryListing {
- my $root = shift; my $pwd = shift;
+ my $root = shift; my $pwd = shift; my $showdates = shift;
my $dir = $root.'/'.$pwd;
my (@values,%labels,$size,$data);
- return unless -d $dir and not -l $dir; #FIXME -- don't follow links
+ return unless -d $dir;
+ my $len = 24;
my @names = sortByName(undef,grep(/^[^.]/,readDirectory($dir)));
- foreach my $name(@names) {
- unless ( $name eq 'DATA') { #FIXME don't view the DATA directory
+ foreach my $name (@names) {
+ unless ($name eq 'DATA') { #FIXME don't view the DATA directory
+ my $file = "$dir/$name";
push(@values,$name); $labels{$name} = $name;
- $labels{$name} .= '/' if (-d $dir.'/'.$name);
+ $labels{$name} .= '@' if (-l $file);
+ $labels{$name} .= '/' if (-d $file && !-l $file);
+ $len = length($labels{$name}) if length($labels{$name}) > $len;
+ }
+ }
+ if ($showdates) {
+ $len += 3;
+ foreach my $name (@values) {
+ my $file = "$dir/$name";
+ my ($size,$date) = (lstat($file))[7,9];
+ $labels{$name} = sprintf("%-${len}s%-16s%10s",$labels{$name},
+ ((-d $file)? ("",""):
+ (getDate($date),getSize($size))));
}
}
return (\@values,\%labels);
}
+sub getDate {
+ my ($sec,$min,$hour,$day,$month,$year) = localtime(shift);
+ sprintf("%02d-%02d-%04d %02d:%02d",$month+1,$day,$year+1900,$hour,$min);
+}
+
+sub getSize {
+ my $size = shift;
+ return $size." B " if $size < 1024;
+ return sprintf("%.1f KB",$size/1024) if $size < 1024*100;
+ return sprintf("%d KB",int($size/1024)) if $size < 1024*1024;
+ return sprintf("%.1f MB",$size/1024/1024) if $size < 1024*1024*100;
+ return sprintf("%d MB",$size/1024/1024);
+}
+
+##################################################
+#
+# Check if a file is a symbolic link that we
+# are not allowed to follow.
+#
+sub isSymLink {
+ my $self = shift; my $file = shift;
+ return 0 unless -l $file;
+
+ my $courseRoot = $self->{ce}{courseDirs}{root};
+ $courseRoot = readlink($courseRoot) if -l $courseRoot;
+ my $pwd = $self->{pwd} || $self->r->param('pwd') || '.';
+ my $link = File::Spec->rel2abs(readlink($file),"$courseRoot/$pwd");
+ #
+ # Remove /./ and dir/../ constructs
+ #
+ $link =~ s!(^|/)(\.(/|$))+!$1!g;
+ while ($link =~ s!((\.[^./]+|\.\.[^/]+|[^./][^/]*)/\.\.(/|$))!!) {};
+
+ #
+ # Link is OK if it is in the course directory
+ #
+ return 0 if substr($link,0,length($courseRoot)) eq $courseRoot;
+
+ #
+ # Look through the list of valid paths to see if this link is OK
+ #
+ my $valid = $self->{ce}{webworkDirs}{valid_symlinks};
+ if (defined $valid && $valid) {
+ foreach my $path (@{$valid}) {
+ return 0 if substr($link,0,length($path)) eq $path;
+ }
+ }
+
+ return 1;
+}
+
##################################################
#
# Normalize the working directory and check if it is OK.
#
sub checkPWD {
+ my $self = shift;
my $pwd = shift;
my $renameError = shift;
- $pwd =~ s!//+!/!g; # remove duplicate slashes
- $pwd =~ s!(^|/)~!$1_!g; # remove ~user references
- $pwd =~ s!(^|/)(\.(/|$))+!$1!g; # remove dot directories
+ $pwd =~ s!//+!/!g; # remove duplicate slashes
+ $pwd =~ s!(^|/)~!$1_!g; # remove ~user references
+ $pwd =~ s!(^|/)(\.(/|$))+!$1!g; # remove dot directories
# remove dir/.. constructions
while ($pwd =~ s!((\.[^./]+|\.\.[^/]+|[^./][^/]*)/\.\.(/|$))!!) {};
@@ -783,6 +1012,15 @@
$pwd =~ s!/$!!; # remove trailing /
return if ($pwd =~ m!(^|/)\.\.(/|$)!); # Error if outside the root
+ # check for bad symbolic links
+ my @dirs = split('/',$pwd);
+ pop(@dirs) if $renameError; # don't check file iteself in this case
+ my @path = ($self->{ce}{courseDirs}{root});
+ foreach my $dir (@dirs) {
+ push @path,$dir;
+ return if ($self->isSymLink(join('/',@path)));
+ }
+
my $original = $pwd;
$pwd =~ s!(^|/)\.!$1_!g; # don't enter hidden directories
$pwd =~ s!^/!!; # remove leading /
@@ -795,19 +1033,6 @@
##################################################
#
-# Check a name for bad characters, etc.
-#
-sub checkName {
- my $file = shift;
- $file =~ s!.*[/\\]!!; # remove directory
- $file =~ s/[^-_.a-zA-Z0-9 ]/_/g; # no illegal characters
- $file = "newfile.txt" unless $file; # no blank names
- $file =~ s/^\./_/; # no initial dot
- return $file;
-}
-
-##################################################
-#
# Check that a file is uploaded to the correct directory
#
sub checkFileLocation {
@@ -816,22 +1041,35 @@
my $dir = shift;
return unless defined($uploadDir{$extension});
return if $dir =~ m/^$uploadDir{$extension}$/;
- $dir = $uploadDir{$extension}; $dir =~ s!/.*!!;
+ $dir = $uploadDir{$extension}; $dir =~ s!/\.\*!!;
$self->addbadmessage("Files with extension '.$extension' usually belong in '$dir'");
}
##################################################
#
+# Check a name for bad characters, etc.
+#
+sub checkName {
+ my $file = shift;
+ $file =~ s!.*[/\\]!!; # remove directory
+ $file =~ s/[^-_.a-zA-Z0-9 ]/_/g; # no illegal characters
+ $file =~ s/^\./_/; # no initial dot
+ $file = "newfile.txt" unless $file; # no blank names
+ return $file;
+}
+
+##################################################
+#
# Get a unique name (in case it already exists)
#
sub uniqueName {
my $dir = shift; my $name = shift;
return $name unless (-e "$dir/$name");
- my $type = ""; my $n = -1;
+ my $type = ""; my $n = 1;
$type = $1 if ($name =~ s/(\.[^.]*)$//);
- $n = $1 if ($name =~ s/(\d+)$//);
- while (-e "$dir/$name$n$type") {if ($n < 0) {$n--} else {$n++}}
- return "$name$n$type";
+ $n = $1 if ($name =~ s/_(\d+)$/_/);
+ while (-e "$dir/${name}_$n$type") {$n++}
+ return "${name}_$n$type";
}
##################################################
@@ -865,7 +1103,7 @@
if ($path) {
unless ($path =~ m![^-_.a-zA-Z0-9 /]!) {
unless ($path =~ m!^/!) {
- $path = checkPWD($self->{pwd}.'/'.$path,1);
+ $path = $self->checkPWD($self->{pwd}.'/'.$path,1);
if ($path) {
$path = $self->{courseRoot}.'/'.$path;
$path .= '/'.$name if -d $path && $name;
@@ -880,6 +1118,18 @@
##################################################
#
+# Get the value of a parameter flag
+#
+sub getFlag {
+ my $self = shift; my $flag = shift;
+ my $default = shift; $default = 0 unless defined $default;
+ my $value = $self->r->param($flag);
+ $value = $default unless defined $value;
+ return $value;
+}
+
+##################################################
+#
# Make HTML symbols printable
#
sub showHTML {
@@ -903,5 +1153,42 @@
}
##################################################
+#
+# Convert spaces to , but only REAL spaces
+#
+sub sp2nbsp {
+ my $s = shift;
+ $s =~ s/ /\ /g;
+ return $s;
+}
+
+##################################################
+#
+# Hack to convert multiple spaces in the file
+# selection box into so that the columns
+# will allign properly in fixed-width fonts.
+# We have to do it agter the fact, since CGI::
+# is being "helpful" by turning & in the labels
+# into & for us. So we have to convert
+# after the <SELECT> is created (ugh).
+#
+sub fixSpaces {
+ my $s = shift;
+ $s =~ s!(<option[^>]*>)(.*?)(</option>)!$1.sp2nbsp($2).$3!gei;
+ return $s;
+}
+
+##################################################
+#
+# Interpret command return errors
+#
+sub systemError {
+ my $status = shift;
+ return "error: $!" if $status == 0xFF00;
+ return "exit status ".($status >> 8) if ($status & 0xFF) == 0;
+ return "signal ".($status &= ~0x80);
+}
+
+##################################################
1;
|
|
From: Mike G. v. a. <we...@ma...> - 2005-07-01 23:55:08
|
Log Message:
-----------
Moved the task of sending the emails to the students to a post_processing portion of the
request handling.
When you email a class, an HTML message is returned informing you that the messages will
be sent. Once the process is completed an email notification is sent to the user (instructor)
sending the email.
This has been lightly tested.
Modified Files:
--------------
webwork-modperl/lib/WeBWorK/ContentGenerator/Instructor:
SendMail.pm
Revision Data
-------------
Index: SendMail.pm
===================================================================
RCS file: /webwork/cvs/system/webwork-modperl/lib/WeBWorK/ContentGenerator/Instructor/SendMail.pm,v
retrieving revision 1.39
retrieving revision 1.40
diff -Llib/WeBWorK/ContentGenerator/Instructor/SendMail.pm -Llib/WeBWorK/ContentGenerator/Instructor/SendMail.pm -u -r1.39 -r1.40
--- lib/WeBWorK/ContentGenerator/Instructor/SendMail.pm
+++ lib/WeBWorK/ContentGenerator/Instructor/SendMail.pm
@@ -28,6 +28,7 @@
use CGI qw();
#use HTML::Entities;
use Mail::Sender;
+use Text::Wrap qw(wrap);
use WeBWorK::HTML::ScrollingRecordList qw/scrollingRecordList/;
use WeBWorK::Utils::FilterRecords qw/filterRecords/;
@@ -262,7 +263,7 @@
$from = $r->param('from');
$replyTo = $r->param('replyTo');
$subject = $r->param('subject');
- my $body = $r->param('body');
+ my $body = $r->param('body');
# Sanity check: body must contain non-white space
$self->addbadmessage(CGI::p('You didn\'t enter any message.')) unless ($r->param('body') =~ /\S/);
$r_text = \$body;
@@ -367,10 +368,11 @@
} elsif ($action eq 'Send Email') {
$self->{response} = 'send_email';
-
+
+ # check that recipients have been selected.
my @recipients = @{$self->{ra_send_to}};
$self->addbadmessage(CGI::p("No recipients selected ")) unless @recipients;
- # get merge file
+ # check merge file
my $merge_file = ( defined($self->{merge_file}) ) ? $self->{merge_file} : 'None';
my $delimiter = ',';
my $rh_merge_data = $self->read_scoring_file("$merge_file", "$delimiter");
@@ -379,40 +381,48 @@
$self->addbadmessage(CGI::p("Can't read merge file $merge_file. No message sent"));
return;
} ;
-
-
- foreach my $recipient (@recipients) {
- #warn "FIXME sending email to $recipient";
- my $ur = $self->{db}->getUser($recipient); #checked
- die "record for user $recipient not found" unless $ur;
- unless ($ur->email_address) {
- $self->addbadmessage(CGI::p("user $recipient does not have an email address -- skipping"));
- next;
- }
- my ($msg, $preview_header);
- eval{ ($msg,$preview_header) = $self->process_message($ur,$rh_merge_data); };
- $self->addbadmessage(CGI::p("There were errors in processing user $ur, merge file $merge_file. $@")) if $@;
- my $mailer = Mail::Sender->new({
- from => $from,
- to => $ur->email_address,
- smtp => $ce->{mail}->{smtpServer},
- subject => $subject,
- headers => "X-Remote-Host: ".$r->get_remote_host(),
- });
- unless (ref $mailer) {
- $self->addbadmessage(CGI::p("Failed to create a mailer for user $recipient: $Mail::Sender::Error"));
- next;
- }
- unless (ref $mailer->Open()) {
- $self->addbadmessage(CGI::p("Failed to open the mailer for user $recipient: $Mail::Sender::Error"));
- next;
- }
- my $MAIL = $mailer->GetHandle() or $self->addbadmessage(CGI::p("Couldn't get handle"));
- print $MAIL $msg || $self->addbadmessage(CGI::p("Couldn't print to $MAIL"));
- close $MAIL || $self->addbadmessage(CGI::p("Couldn't close $MAIL"));
- #warn "FIXME mailed to ", $ur->email_address, "from $from subject $subject";
-
- }
+ if (@recipients) {
+ $self->{rh_merge_data} = $rh_merge_data;
+ $self->{smtpServer} = $ce->{mail}->{smtpServer};
+ my $post_connection_action = sub {
+ my $r = shift;
+ my $result_message = $self->mail_message_to_recipients();
+ $self->email_notification($result_message);
+ };
+ $r->post_connection($post_connection_action) ;
+ }
+# foreach my $recipient (@recipients) {
+# #warn "FIXME sending email to $recipient";
+# my $ur = $self->{db}->getUser($recipient); #checked
+# die "record for user $recipient not found" unless $ur;
+# unless ($ur->email_address) {
+# $self->addbadmessage(CGI::p("user $recipient does not have an email address -- skipping"));
+# next;
+# }
+# my ($msg, $preview_header);
+# eval{ ($msg,$preview_header) = $self->process_message($ur,$rh_merge_data); };
+# $self->addbadmessage(CGI::p("There were errors in processing user $ur, merge file $merge_file. $@")) if $@;
+# my $mailer = Mail::Sender->new({
+# from => $from,
+# to => $ur->email_address,
+# smtp => $ce->{mail}->{smtpServer},
+# subject => $subject,
+# headers => "X-Remote-Host: ".$r->get_remote_host(),
+# });
+# unless (ref $mailer) {
+# $self->addbadmessage(CGI::p("Failed to create a mailer for user $recipient: $Mail::Sender::Error"));
+# next;
+# }
+# unless (ref $mailer->Open()) {
+# $self->addbadmessage(CGI::p("Failed to open the mailer for user $recipient: $Mail::Sender::Error"));
+# next;
+# }
+# my $MAIL = $mailer->GetHandle() or $self->addbadmessage(CGI::p("Couldn't get handle"));
+# print $MAIL $msg || $self->addbadmessage(CGI::p("Couldn't print to $MAIL"));
+# close $MAIL || $self->addbadmessage(CGI::p("Couldn't close $MAIL"));
+# #warn "FIXME mailed to ", $ur->email_address, "from $from subject $subject";
+#
+# }
} else {
$self->addbadmessage(CGI::p("Didn't recognize button $action"));
@@ -445,8 +455,12 @@
if ($response eq 'preview') {
$self->print_preview($setID);
} elsif (($response eq 'send_email')){
- $self->addgoodmessage(CGI::p("Email sent to ". scalar(@{$self->{ra_send_to}})." students."));
- $self->{message} .= CGI::i("Email sent to ". scalar(@{$self->{ra_send_to}})." students.");
+ my $message = CGI::i("Email is being sent to ". scalar(@{$self->{ra_send_to}})." recipients. You will be notified"
+ ." when the task is completed. This may take several minutes if the class is large."
+ );
+ $self->addgoodmessage($message);
+ $self->{message} .= $message;
+
$self->print_form($setID);
} else {
$self->print_form($setID);
@@ -803,7 +817,100 @@
return 'None', $self->read_dir($self->{ce}->{courseDirs}->{scoring}, '\\.csv$'); #FIXME ? check that only readable files are listed.
}
+sub mail_message_to_recipients {
+ my $self = shift;
+ my $subject = $self->{subject};
+ my $from = $self->{from};
+ my @recipients = @{$self->{ra_send_to}};
+ my $rh_merge_data = $self->{rh_merge_data};
+ my $merge_file = $self->{merge_file};
+ my $result_message = '';
+ my $failed_messages = 0;
+ foreach my $recipient (@recipients) {
+ # warn "FIXME sending email to $recipient";
+ my $error_messages = '';
+ my $ur = $self->{db}->getUser($recipient); #checked
+ unless ($ur) {
+ $error_messages .= "Record for user $recipient not found\n";
+ next;
+ }
+ unless ($ur->email_address) {
+ $error_messages .="User $recipient does not have an email address -- skipping\n";
+ next;
+ }
+ my ($msg, $preview_header);
+ eval{ ($msg,$preview_header) = $self->process_message($ur,$rh_merge_data); };
+ $error_messages .= "There were errors in processing user $ur, merge file $merge_file. \n$@\n" if $@;
+ my $mailer = Mail::Sender->new({
+ from => $from,
+ to => $ur->email_address,
+ smtp => $self->{smtpServer},
+ subject => $subject,
+ headers => "X-Remote-Host: ".$self->r->get_remote_host(),
+ });
+ unless (ref $mailer) {
+ $error_messages .= "Failed to create a mailer for user $recipient: $Mail::Sender::Error\n";
+ next;
+ }
+ unless (ref $mailer->Open()) {
+ $error_messages .= "Failed to open the mailer for user $recipient: $Mail::Sender::Error\n";
+ next;
+ }
+ my $MAIL = $mailer->GetHandle() || ($error_messages .= "Couldn't get mailer handle \n");
+ print $MAIL $msg || ($error_messages .= "Couldn't print to $MAIL");
+ close $MAIL || ($error_messages .= "Couldn't close $MAIL");
+ #warn "FIXME mailed to $recipient: ", $ur->email_address, " from $from subject $subject Errors: $error_messages";
+ $failed_messages++ if $error_messages;
+ $result_message .= $error_messages;
+ }
+ my $courseName = $self->r->urlpath->arg("courseID");
+ my $number_of_recipients = scalar(@recipients) - $failed_messages;
+ $result_message = <<EndText.$result_message;
+
+ A message with the subject line
+ $subject
+ has been sent to
+ $number_of_recipients recipient(s) in the class $courseName.
+ There were $failed_messages message(s) that could not be delivered.
+
+EndText
+
+}
+sub email_notification {
+ my $self = shift;
+ my $result_message = shift;
+ # find info on mailer and sender
+ # use the defaultFrom address.
+
+ # find info on instructor recipient and message
+ my $subject="WeBWorK email sent";
+
+ my $mailing_errors = "";
+ # open MAIL handle
+ my $mailer = Mail::Sender->new({
+ from => $self->{defaultFrom},
+ to => $self->{defaultFrom},
+ smtp => $self->{smtpServer},
+ subject => $subject,
+ headers => "X-Remote-Host: ".$self->r->get_remote_host(),
+ });
+ unless (ref $mailer) {
+ $mailing_errors .= "Failed to create a mailer: $Mail::Sender::Error";
+ return "";
+ }
+ unless (ref $mailer->Open()) {
+ $mailing_errors .= "Failed to open the mailer: $Mail::Sender::Error";
+ return "";
+ }
+ my $MAIL = $mailer->GetHandle();
+ # print message
+ print $MAIL $result_message;
+ # clean up
+ close $MAIL;
+
+ warn "instructor message sent to ", $self->{defaultFrom};
+}
sub getRecord {
my $self = shift;
my $line = shift;
|
|
From: Mike G. v. a. <we...@ma...> - 2005-07-01 15:55:36
|
Log Message:
-----------
Added commment
Modified Files:
--------------
pg/lib:
AnswerHash.pm
Revision Data
-------------
Index: AnswerHash.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/AnswerHash.pm,v
retrieving revision 1.6
retrieving revision 1.7
diff -Llib/AnswerHash.pm -Llib/AnswerHash.pm -u -r1.6 -r1.7
--- lib/AnswerHash.pm
+++ lib/AnswerHash.pm
@@ -504,7 +504,7 @@
} elsif (ref($input) eq 'ARRAY' ) { # sometimes the answer may already be decoded into an array.
my @input = @$input;
$self-> {rh_ans} -> {original_student_ans} = " ( " .join(", ",@input) . " ) ";
- $input = \@input;
+ $input = \@input; #make a local copy
$self-> {rh_ans} -> {student_ans} = $input;
} else {
|
|
From: Mike G. v. a. <we...@ma...> - 2005-07-01 12:21:16
|
Log Message:
-----------
Backporting a fix to the encodeAnswer and decodeAnswer routines
Tags:
----
rel-2-1-patches
Modified Files:
--------------
webwork-modperl/lib/WeBWorK:
Utils.pm
Revision Data
-------------
Index: Utils.pm
===================================================================
RCS file: /webwork/cvs/system/webwork-modperl/lib/WeBWorK/Utils.pm,v
retrieving revision 1.59.2.1
retrieving revision 1.59.2.2
diff -Llib/WeBWorK/Utils.pm -Llib/WeBWorK/Utils.pm -u -r1.59.2.1 -r1.59.2.2
--- lib/WeBWorK/Utils.pm
+++ lib/WeBWorK/Utils.pm
@@ -648,12 +648,16 @@
$result .= defined $ref ? $ref : '<font color="red">undef</font>';
}
}
-use constant BASE64_ENCODED => 'base64_encoded:';
+our $BASE64_ENCODED = 'base64_encoded:';
+# use constant BASE64_ENCODED = 'base64_encoded;
+# was not evaluated in the matching and substitution
+# statements
sub decodeAnswers($) {
my $string = shift;
return unless defined $string and $string;
- if ($string =~/^BASE64_ENCODED/) {
- $string =~ s/^BASE64_ENCODED//;
+
+ if ($string =~/^$BASE64_ENCODED/o) {
+ $string =~ s/^$BASE64_ENCODED//o;
$string = decode_base64($string);
}
@@ -684,7 +688,7 @@
}
$string =~ s/##$//; # remove last pair of hashs
- $string = BASE64_ENCODED.encode_base64($string);
+ $string = $BASE64_ENCODED.encode_base64($string);
return $string;
}
|
|
From: Mike G. v. a. <we...@ma...> - 2005-07-01 12:17:40
|
Log Message:
-----------
Fixed a bug in which the constant 'function' BASE64_ENCODED was not being
evaluated inside the matching and substitution statements. Replaced
the constant by using the construction
our $BASE64_ENCODED = 'base64_encoded:';
instead. The variable is properly interpolated inside the matching
and substitution statements.
Modified Files:
--------------
webwork-modperl/lib/WeBWorK:
Utils.pm
Revision Data
-------------
Index: Utils.pm
===================================================================
RCS file: /webwork/cvs/system/webwork-modperl/lib/WeBWorK/Utils.pm,v
retrieving revision 1.64
retrieving revision 1.65
diff -Llib/WeBWorK/Utils.pm -Llib/WeBWorK/Utils.pm -u -r1.64 -r1.65
--- lib/WeBWorK/Utils.pm
+++ lib/WeBWorK/Utils.pm
@@ -651,12 +651,16 @@
$result .= defined $ref ? $ref : '<font color="red">undef</font>';
}
}
-use constant BASE64_ENCODED => 'base64_encoded:';
+our $BASE64_ENCODED = 'base64_encoded:';
+# use constant BASE64_ENCODED = 'base64_encoded;
+# was not evaluated in the matching and substitution
+# statements
sub decodeAnswers($) {
my $string = shift;
return unless defined $string and $string;
- if ($string =~/^BASE64_ENCODED/) {
- $string =~ s/^BASE64_ENCODED//;
+
+ if ($string =~/^$BASE64_ENCODED/o) {
+ $string =~ s/^$BASE64_ENCODED//o;
$string = decode_base64($string);
}
@@ -687,7 +691,7 @@
}
$string =~ s/##$//; # remove last pair of hashs
- $string = BASE64_ENCODED.encode_base64($string);
+ $string = $BASE64_ENCODED.encode_base64($string);
return $string;
}
|
|
From: Mike G. v. a. <we...@ma...> - 2005-06-29 17:13:06
|
Log Message:
-----------
Added comments.
Modified Files:
--------------
pg/macros:
PGanswermacros.pl
Revision Data
-------------
Index: PGanswermacros.pl
===================================================================
RCS file: /webwork/cvs/system/pg/macros/PGanswermacros.pl,v
retrieving revision 1.30
retrieving revision 1.31
diff -Lmacros/PGanswermacros.pl -Lmacros/PGanswermacros.pl -u -r1.30 -r1.31
--- macros/PGanswermacros.pl
+++ macros/PGanswermacros.pl
@@ -2657,7 +2657,7 @@
#strict_str_cmp( @_ );
my $response = shift; # there should be only one item.
warn "Multiple choices -- this should not happen with radio buttons. Have
- you used checkboxes perhaps?" if ref($response);
+ you used checkboxes perhaps?" if ref($response); #triggered if an ARRAY is passed
str_cmp($response);
}
|
|
From: Mike G. v. a. <we...@ma...> - 2005-06-29 16:22:33
|
Log Message:
-----------
Fixed bug in radio_cmp closing bug #258. We now check to make
sure that only a single string is being passed and not an array.
(The latter occurs if checkboxes are used instead of radio buttons.)
The presence of two checked checkboxes triggers a warning.
Modified Files:
--------------
pg/macros:
PGanswermacros.pl
Revision Data
-------------
Index: PGanswermacros.pl
===================================================================
RCS file: /webwork/cvs/system/pg/macros/PGanswermacros.pl,v
retrieving revision 1.29
retrieving revision 1.30
diff -Lmacros/PGanswermacros.pl -Lmacros/PGanswermacros.pl -u -r1.29 -r1.30
--- macros/PGanswermacros.pl
+++ macros/PGanswermacros.pl
@@ -2650,8 +2650,15 @@
#added 6/28/2000 by David Etlinger
#exactly the same as strict_str_cmp,
#but more intuitive to the user
+
+# check that answer is really a string and not an array
+# also use ordinary string compare
sub radio_cmp {
- strict_str_cmp( @_ );
+ #strict_str_cmp( @_ );
+ my $response = shift; # there should be only one item.
+ warn "Multiple choices -- this should not happen with radio buttons. Have
+ you used checkboxes perhaps?" if ref($response);
+ str_cmp($response);
}
##########################################################################
|
|
From: Mike G. v. a. <we...@ma...> - 2005-06-29 02:51:47
|
Log Message:
-----------
MASSIVE changes to str_cmp and related subroutines (mostly in STR_CMP).
This answer evaluator now produces an AnswerEvaluator type rather than
a subroutine.
Modified Files:
--------------
pg/macros:
PGanswermacros.pl
Revision Data
-------------
Index: PGanswermacros.pl
===================================================================
RCS file: /webwork/cvs/system/pg/macros/PGanswermacros.pl,v
retrieving revision 1.28
retrieving revision 1.29
diff -Lmacros/PGanswermacros.pl -Lmacros/PGanswermacros.pl -u -r1.28 -r1.29
--- macros/PGanswermacros.pl
+++ macros/PGanswermacros.pl
@@ -2080,85 +2080,142 @@
## Use this subroutine instead of the
## individual filters below it
-sub str_filters {
- my $stringToFilter = shift @_;
- my @filters_to_use = @_;
- my %known_filters = ( 'remove_whitespace' => undef,
- 'compress_whitespace' => undef,
- 'trim_whitespace' => undef,
- 'ignore_case' => undef,
- 'ignore_order' => undef
- );
-
- #test for unknown filters
- my $filter;
- foreach $filter (@filters_to_use) {
- die "Unknown string filter $filter (try checking the parameters to str_cmp() )"
- unless exists $known_filters{$filter};
- }
-
- if( grep( /remove_whitespace/i, @filters_to_use ) ) {
- $stringToFilter = remove_whitespace( $stringToFilter );
- }
- if( grep( /compress_whitespace/i, @filters_to_use ) ) {
- $stringToFilter = compress_whitespace( $stringToFilter );
- }
- if( grep( /trim_whitespace/i, @filters_to_use ) ) {
- $stringToFilter = trim_whitespace( $stringToFilter );
- }
- if( grep( /ignore_case/i, @filters_to_use ) ) {
- $stringToFilter = ignore_case( $stringToFilter );
- }
- if( grep( /ignore_order/i, @filters_to_use ) ) {
- $stringToFilter = ignore_order( $stringToFilter );
- }
-
- return $stringToFilter;
-}
+# sub str_filters {
+# my $stringToFilter = shift @_;
+# my @filters_to_use = @_;
+# my %known_filters = (
+# 'remove_whitespace' => &remove_whitespace,
+# 'compress_whitespace' => &compress_whitespace,
+# 'trim_whitespace' => &trim_whitespace,
+# 'ignore_case' => &ignore_case,
+# 'ignore_order' => &ignore_order,
+# );
+#
+# #test for unknown filters
+# foreach my $filter ( @filters_to_use ) {
+# #check that filter is known
+# die "Unknown string filter $filter (try checking the parameters to str_cmp() )"
+# unless exists $known_filters{$filter};
+# $stringToFilter = $known_filters{$filter}($stringToFilter); # apply filter.
+# }
+# foreach $filter (@filters_to_use) {
+# die "Unknown string filter $filter (try checking the parameters to str_cmp() )"
+# unless exists $known_filters{$filter};
+# }
+#
+# if( grep( /remove_whitespace/i, @filters_to_use ) ) {
+# $stringToFilter = remove_whitespace( $stringToFilter );
+# }
+# if( grep( /compress_whitespace/i, @filters_to_use ) ) {
+# $stringToFilter = compress_whitespace( $stringToFilter );
+# }
+# if( grep( /trim_whitespace/i, @filters_to_use ) ) {
+# $stringToFilter = trim_whitespace( $stringToFilter );
+# }
+# if( grep( /ignore_case/i, @filters_to_use ) ) {
+# $stringToFilter = ignore_case( $stringToFilter );
+# }
+# if( grep( /ignore_order/i, @filters_to_use ) ) {
+# $stringToFilter = ignore_order( $stringToFilter );
+# }
+# return $stringToFilter;
+# }
sub remove_whitespace {
- my $filteredAnswer = shift;
-
- $filteredAnswer =~ s/\s+//g; # remove all whitespace
-
- return $filteredAnswer;
+ my $rh_ans = shift;
+ die "expected an answer hash" unless ref($rh_ans)=~/HASH/i;
+ $rh_ans->{_filter_name} = 'remove_whitespace';
+ $rh_ans->{student_ans} =~ s/\s+//g; # remove all whitespace
+ $rh_ans->{correct_ans} =~ s/\s+//g; # remove all whitespace
+ return $rh_ans;
}
sub compress_whitespace {
- my $filteredAnswer = shift;
-
- $filteredAnswer =~ s/^\s*//; # remove initial whitespace
- $filteredAnswer =~ s/\s*$//; # remove trailing whitespace
- $filteredAnswer =~ s/\s+/ /g; # replace spaces by single space
+ my $rh_ans = shift;
+ die "expected an answer hash" unless ref($rh_ans)=~/HASH/i;
+ $rh_ans->{_filter_name} = 'compress_whitespace';
+ $rh_ans->{student_ans} =~ s/^\s*//; # remove initial whitespace
+ $rh_ans->{student_ans} =~ s/\s*$//; # remove trailing whitespace
+ $rh_ans->{student_ans} =~ s/\s+/ /g; # replace spaces by single space
+ $rh_ans->{correct_ans} =~ s/^\s*//; # remove initial whitespace
+ $rh_ans->{correct_ans} =~ s/\s*$//; # remove trailing whitespace
+ $rh_ans->{correct_ans} =~ s/\s+/ /g; # replace spaces by single space
- return $filteredAnswer;
+ return $rh_ans;
}
sub trim_whitespace {
- my $filteredAnswer = shift;
-
- $filteredAnswer =~ s/^\s*//; # remove initial whitespace
- $filteredAnswer =~ s/\s*$//; # remove trailing whitespace
+ my $rh_ans = shift;
+ die "expected an answer hash" unless ref($rh_ans)=~/HASH/i;
+ $rh_ans->{_filter_name} = 'trim_whitespace';
+ $rh_ans->{student_ans} =~ s/^\s*//; # remove initial whitespace
+ $rh_ans->{student_ans} =~ s/\s*$//; # remove trailing whitespace
+ $rh_ans->{correct_ans} =~ s/^\s*//; # remove initial whitespace
+ $rh_ans->{correct_ans} =~ s/\s*$//; # remove trailing whitespace
- return $filteredAnswer;
+ return $rh_ans;
}
sub ignore_case {
- my $filteredAnswer = shift;
- #warn "filtered answer is ", $filteredAnswer;
- #$filteredAnswer = uc $filteredAnswer; # this didn't work on webwork xmlrpc, but does elsewhere ????
- $filteredAnswer =~ tr/a-z/A-Z/;
-
- return $filteredAnswer;
+ my $rh_ans = shift;
+ die "expected an answer hash" unless ref($rh_ans)=~/HASH/i;
+ $rh_ans->{_filter_name} = 'ignore_case';
+ $rh_ans->{student_ans} =~ tr/a-z/A-Z/;
+ $rh_ans->{correct_ans} =~ tr/a-z/A-Z/;
+ return $rh_ans;
}
sub ignore_order {
- my $filteredAnswer = shift;
-
- $filteredAnswer = join( "", lex_sort( split( /\s*/, $filteredAnswer ) ) );
-
- return $filteredAnswer;
+ my $rh_ans = shift;
+ die "expected an answer hash" unless ref($rh_ans)=~/HASH/i;
+ $rh_ans->{student_ans} = join( "", lex_sort( split( /\s*/, $rh_ans->{student_ans} ) ) );
+ $rh_ans->{correct_ans} = join( "", lex_sort( split( /\s*/, $rh_ans->{correct_ans} ) ) );
+
+ return $rh_ans;
}
+# sub remove_whitespace {
+# my $filteredAnswer = shift;
+#
+# $filteredAnswer =~ s/\s+//g; # remove all whitespace
+#
+# return $filteredAnswer;
+# }
+#
+# sub compress_whitespace {
+# my $filteredAnswer = shift;
+#
+# $filteredAnswer =~ s/^\s*//; # remove initial whitespace
+# $filteredAnswer =~ s/\s*$//; # remove trailing whitespace
+# $filteredAnswer =~ s/\s+/ /g; # replace spaces by single space
+#
+# return $filteredAnswer;
+# }
+#
+# sub trim_whitespace {
+# my $filteredAnswer = shift;
+#
+# $filteredAnswer =~ s/^\s*//; # remove initial whitespace
+# $filteredAnswer =~ s/\s*$//; # remove trailing whitespace
+#
+# return $filteredAnswer;
+# }
+#
+# sub ignore_case {
+# my $filteredAnswer = shift;
+# #warn "filtered answer is ", $filteredAnswer;
+# #$filteredAnswer = uc $filteredAnswer; # this didn't work on webwork xmlrpc, but does elsewhere ????
+# $filteredAnswer =~ tr/a-z/A-Z/;
+#
+# return $filteredAnswer;
+# }
+#
+# sub ignore_order {
+# my $filteredAnswer = shift;
+#
+# $filteredAnswer = join( "", lex_sort( split( /\s*/, $filteredAnswer ) ) );
+#
+# return $filteredAnswer;
+# }
################################
## END STRING ANSWER FILTERS
@@ -2204,19 +2261,35 @@
my $correctAnswer = shift @_;
$correctAnswer = '' unless defined($correctAnswer);
my @options = @_;
+ my %options = ();
+ # backward compatibility
+ if (grep /filters|debug|filter/, @options) { # see whether we have hash keys in the input.
+ %options = @options;
+ } elsif (@options) { # all options are names of filters.
+ $options{filters} = [@options];
+ }
my $ra_filters;
-
+ assign_option_aliases( \%options,
+ 'filter' => 'filters',
+ );
+ set_default_options( \%options,
+ 'filters' => [qw(trim_whitespace compress_whitespace ignore_case)],
+ 'debug' => 0,
+ 'type' => 'str_cmp',
+ );
+ $options{filters} = (ref($options{filters}))?$options{filters}:[$options{filters}];
+ # make sure this is a reference to an array.
# error-checking for filters occurs in the filters() subroutine
- if( not defined( $options[0] ) ) { # used with no filters as alias for std_str_cmp()
- @options = ( 'compress_whitespace', 'ignore_case' );
- }
-
- if( $options[0] eq 'filters' ) { # using filters => [f1, f2, ...] notation
- $ra_filters = $options[1];
- }
- else { # using a list of filters
- $ra_filters = \@options;
- }
+# if( not defined( $options[0] ) ) { # used with no filters as alias for std_str_cmp()
+# @options = ( 'compress_whitespace', 'ignore_case' );
+# }
+#
+# if( $options[0] eq 'filters' ) { # using filters => [f1, f2, ...] notation
+# $ra_filters = $options[1];
+# }
+# else { # using a list of filters
+# $ra_filters = \@options;
+# }
# thread over lists
my @ans_list = ();
@@ -2232,9 +2305,11 @@
my @output_list = ();
foreach my $ans (@ans_list) {
- push(@output_list, STR_CMP( 'correctAnswer' => $ans,
- 'filters' => $ra_filters,
- 'type' => 'str_cmp'
+ push(@output_list, STR_CMP(
+ 'correct_ans' => $ans,
+ 'filters' => $options{filters},
+ 'type' => $options{type},
+ 'debug' => $options{debug},
)
);
}
@@ -2299,7 +2374,7 @@
my $correctAnswer = shift @_;
my @filters = ( 'compress_whitespace', 'ignore_case' );
my $type = 'std_str_cmp';
- STR_CMP( 'correctAnswer' => $correctAnswer,
+ STR_CMP('correct_ans' => $correctAnswer,
'filters' => \@filters,
'type' => $type
);
@@ -2318,7 +2393,7 @@
my $correctAnswer = shift @_;
my @filters = ( 'compress_whitespace' );
my $type = 'std_cs_str_cmp';
- STR_CMP( 'correctAnswer' => $correctAnswer,
+ STR_CMP( 'correct_ans' => $correctAnswer,
'filters' => \@filters,
'type' => $type
);
@@ -2337,7 +2412,7 @@
my $correctAnswer = shift @_;
my @filters = ( 'trim_whitespace' );
my $type = 'strict_str_cmp';
- STR_CMP( 'correctAnswer' => $correctAnswer,
+ STR_CMP( 'correct_ans' => $correctAnswer,
'filters' => \@filters,
'type' => $type
);
@@ -2356,7 +2431,7 @@
my $correctAnswer = shift @_;
my @filters = ( 'ignore_order', 'ignore_case' );
my $type = 'unordered_str_cmp';
- STR_CMP( 'correctAnswer' => $correctAnswer,
+ STR_CMP( 'correct_ans' => $correctAnswer,
'filters' => \@filters,
'type' => $type
);
@@ -2375,7 +2450,7 @@
my $correctAnswer = shift @_;
my @filters = ( 'ignore_order' );
my $type = 'unordered_cs_str_cmp';
- STR_CMP( 'correctAnswer' => $correctAnswer,
+ STR_CMP( 'correct_ans' => $correctAnswer,
'filters' => \@filters,
'type' => $type
);
@@ -2394,7 +2469,7 @@
my $correctAnswer = shift @_;
my @filters = ( 'remove_whitespace', 'ignore_case' );
my $type = 'ordered_str_cmp';
- STR_CMP( 'correctAnswer' => $correctAnswer,
+ STR_CMP( 'correct_ans' => $correctAnswer,
'filters' => \@filters,
'type' => $type
);
@@ -2413,7 +2488,7 @@
my $correctAnswer = shift @_;
my @filters = ( 'remove_whitespace' );
my $type = 'ordered_cs_str_cmp';
- STR_CMP( 'correctAnswer' => $correctAnswer,
+ STR_CMP( 'correct_ans' => $correctAnswer,
'filters' => \@filters,
'type' => $type
);
@@ -2436,30 +2511,73 @@
## filters -- reference to an array containing the filters to be applied
## type -- a string containing the type of answer evaluator in use
## OUT: a reference to an answer evaluator subroutine
-
sub STR_CMP {
my %str_params = @_;
- $str_params{'correctAnswer'} = str_filters( $str_params{'correctAnswer'}, @{$str_params{'filters'}} );
- my $answer_evaluator = sub {
- my $in = shift @_;
- $in = '' unless defined $in;
- my $original_student_ans = $in;
- $in = str_filters( $in, @{$str_params{'filters'}} );
- my $correctQ = ( $in eq $str_params{'correctAnswer'} ) ? 1: 0;
- my $ans_hash = new AnswerHash( 'score' => $correctQ,
- 'correct_ans' => $str_params{'correctAnswer'},
- 'student_ans' => $in,
- 'ans_message' => '',
- 'type' => $str_params{'type'},
- 'preview_text_string' => $in,
- 'preview_latex_string' => $in,
- 'original_student_ans' => $original_student_ans
- );
- return $ans_hash;
- };
+ #my $correctAnswer = str_filters( $str_params{'correct_ans'}, @{$str_params{'filters'}} );
+ my $answer_evaluator = new AnswerEvaluator;
+ $answer_evaluator->{debug} = $str_params{debug};
+ $answer_evaluator->ans_hash(
+ correct_ans => $str_params{correct_ans}||'',
+ type => $str_params{type}||'str_cmp',
+ score => 0,
+
+ );
+ my %known_filters = (
+ 'remove_whitespace' => \&remove_whitespace,
+ 'compress_whitespace' => \&compress_whitespace,
+ 'trim_whitespace' => \&trim_whitespace,
+ 'ignore_case' => \&ignore_case,
+ 'ignore_order' => \&ignore_order,
+ );
+
+ foreach my $filter ( @{$str_params{filters}} ) {
+ #check that filter is known
+ die "Unknown string filter |$filter|. Known filters are ".
+ join(" ", keys %known_filters) .
+ "(try checking the parameters to str_cmp() )"
+ unless exists $known_filters{$filter};
+ # install related pre_filter
+ $answer_evaluator->install_pre_filter( $known_filters{$filter} );
+ }
+ $answer_evaluator->install_evaluator(sub {
+ my $rh_ans = shift;
+ $rh_ans->{_filter_name} = "Evaluator: Compare string answers with eq";
+ $rh_ans->{score} = ($rh_ans->{student_ans} eq $rh_ans->{correct_ans})?1:0 ;
+ $rh_ans;
+ });
+ $answer_evaluator->install_post_filter(sub {
+ my $rh_hash = shift;
+ $rh_hash->{_filter_name} = "clean up preview strings";
+ $rh_hash->{'preview_text_string'} = $rh_hash->{student_ans};
+ $rh_hash->{'preview_latex_string'} = "\\text{ ".$rh_hash->{student_ans}." }";
+ $rh_hash;
+ });
return $answer_evaluator;
}
+# sub STR_CMP_old {
+# my %str_params = @_;
+# $str_params{'correct_ans'} = str_filters( $str_params{'correct_ans'}, @{$str_params{'filters'}} );
+# my $answer_evaluator = sub {
+# my $in = shift @_;
+# $in = '' unless defined $in;
+# my $original_student_ans = $in;
+# $in = str_filters( $in, @{$str_params{'filters'}} );
+# my $correctQ = ( $in eq $str_params{'correct_ans'} ) ? 1: 0;
+# my $ans_hash = new AnswerHash( 'score' => $correctQ,
+# 'correct_ans' => $str_params{'correctAnswer'},
+# 'student_ans' => $in,
+# 'ans_message' => '',
+# 'type' => $str_params{'type'},
+# 'preview_text_string' => $in,
+# 'preview_latex_string' => $in,
+# 'original_student_ans' => $original_student_ans
+# );
+# return $ans_hash;
+# };
+# return $answer_evaluator;
+# }
+
##########################################################################
##########################################################################
## Miscellaneous answer evaluators
|
|
From: Mike G. v. a. <we...@ma...> - 2005-06-29 02:50:30
|
Log Message:
-----------
Corrected how preview_latex_strings are handled when two
AnswerHashes are ANDed or ORed.
Modified Files:
--------------
pg/lib:
AnswerHash.pm
Revision Data
-------------
Index: AnswerHash.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/AnswerHash.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -Llib/AnswerHash.pm -Llib/AnswerHash.pm -u -r1.5 -r1.6
--- lib/AnswerHash.pm
+++ lib/AnswerHash.pm
@@ -423,7 +423,8 @@
$out_hash->{correct_ans} = join(" AND ", $self->{correct_ans}, $rh_ans2->{correct_ans} );
$out_hash->{student_ans} = $self->{student_ans};
$out_hash->{type} = join(" AND ", $self->{type}, $rh_ans2->{type} );
- $out_hash->{preview_text_string} = join(" ", $self->{preview_text_string}, $rh_ans2->{preview_text_string} );
+ $out_hash->{preview_text_string} = join(" ", $self->{preview_text_string}, $rh_ans2->{preview_text_string} );
+ $out_hash->{preview_latex_string} = join("\\quad", $self->{preview_latex_string}, $rh_ans2->{preview_latex_string} );
$out_hash->{original_student_ans} = $self->{original_student_ans};
$out_hash;
}
|
|
From: Mike G. v. a. <we...@ma...> - 2005-06-29 02:48:58
|
Log Message:
-----------
Fixed a problem with showing answers when printing hardcopy
(no idea why this wasn't reported earlier). The CGI::checkboxes
use "on" and nothing to denote whether a checkbox is checked.
We expect 1 or 0 (or undef).
Modified Files:
--------------
webwork-modperl/lib/WeBWorK/ContentGenerator:
Hardcopy.pm
Revision Data
-------------
Index: Hardcopy.pm
===================================================================
RCS file: /webwork/cvs/system/webwork-modperl/lib/WeBWorK/ContentGenerator/Hardcopy.pm,v
retrieving revision 1.53
retrieving revision 1.54
diff -Llib/WeBWorK/ContentGenerator/Hardcopy.pm -Llib/WeBWorK/ContentGenerator/Hardcopy.pm -u -r1.53 -r1.54
--- lib/WeBWorK/ContentGenerator/Hardcopy.pm
+++ lib/WeBWorK/ContentGenerator/Hardcopy.pm
@@ -780,14 +780,15 @@
return $msg;
}
# figure out if we're allowed to get solutions and call PG->new accordingly.
- my $showCorrectAnswers = $r->param("showCorrectAnswers") || 0;
- my $showHints = $r->param("showHints") || 0;
- my $showSolutions = $r->param("showSolutions") || 0;
+ my $showCorrectAnswers = $r->param("showCorrectAnswers") || 0;
+ my $showHints = $r->param("showHints") || 0;
+ my $showSolutions = $r->param("showSolutions") || 0;
unless ($authz->hasPermissions($userID, "view_answers") or time > $set->answer_date) {
$showCorrectAnswers = 0;
$showSolutions = 0;
}
-
+ ##FIXME -- there can be a problem if the $siteDefaults{timezone} is not defined? Why is this?
+ # why does it only occur with hardcopy?
my $pg = WeBWorK::PG->new(
$ce,
$effectiveUser,
@@ -798,9 +799,9 @@
{}, # no form fields!
{ # translation options
displayMode => "tex",
- showHints => $showHints,
- showSolutions => $showSolutions,
- processAnswers => $showCorrectAnswers,
+ showHints => ($showHints)? 1:0, # insure that this value is numeric
+ showSolutions => ($showSolutions)? 1:0,
+ processAnswers => ($showCorrectAnswers)? 1:0,
},
);
|
|
From: Mike G. v. a. <we...@ma...> - 2005-06-28 19:41:16
|
Log Message:
-----------
Format changes.
Modified Files:
--------------
pg/macros:
extraAnswerEvaluators.pl
Revision Data
-------------
Index: extraAnswerEvaluators.pl
===================================================================
RCS file: /webwork/cvs/system/pg/macros/extraAnswerEvaluators.pl,v
retrieving revision 1.3
retrieving revision 1.4
diff -Lmacros/extraAnswerEvaluators.pl -Lmacros/extraAnswerEvaluators.pl -u -r1.3 -r1.4
--- macros/extraAnswerEvaluators.pl
+++ macros/extraAnswerEvaluators.pl
@@ -373,15 +373,15 @@
my $student = shift;
my $ans_hash = new AnswerHash(
- 'score'=>0,
- 'correct_ans'=>$right_ans,
- 'student_ans'=>$student,
- 'original_student_ans' => $student,
- # 'type' => undef,
- 'ans_message'=>'',
- 'preview_text_string'=>'',
- 'preview_latex_string'=>'',
- );
+ 'score'=>0,
+ 'correct_ans'=>$right_ans,
+ 'student_ans'=>$student,
+ 'original_student_ans' => $student,
+ # 'type' => undef,
+ 'ans_message'=>'',
+ 'preview_text_string'=>'',
+ 'preview_latex_string'=>'',
+ );
# Handle string matches separately
my($studentisstring, $correctisstring, $tststr) = (0,0,"");
my($nicestud, $nicecorrect) = (nicify_string($student),
|
|
From: Mike G. v. a. <we...@ma...> - 2005-06-28 19:39:41
|
Log Message:
-----------
Many changes to this file. I've fixed multi_cmp which
will check a comma separated string of answers.
I have commented out many other routines which do not appear
to be in use.
Modified Files:
--------------
pg/macros:
PGcomplexmacros.pl
Revision Data
-------------
Index: PGcomplexmacros.pl
===================================================================
RCS file: /webwork/cvs/system/pg/macros/PGcomplexmacros.pl,v
retrieving revision 1.8
retrieving revision 1.9
diff -Lmacros/PGcomplexmacros.pl -Lmacros/PGcomplexmacros.pl -u -r1.8 -r1.9
--- macros/PGcomplexmacros.pl
+++ macros/PGcomplexmacros.pl
@@ -60,18 +60,7 @@
my $number = '([+-]?)(?=\d|\.\d)\d*(\.\d*)?(E([+-]?\d+))?';
-sub polar{
- my $z = shift;
- my %options = @_;
- my $r = rho($z);
- my $theta = $z->theta;
- my $r_format = ':%0.3f';
- my $theta_format = ':%0.3f';
- $r_format=":" . $options{r_format} if defined($options{r_format});
- $theta_format = ":" . $options{theta_format} if defined($options{theta_format});
- "{$r$r_format} e^{i {$theta$theta_format}}";
-}
=head4 cplx_cmp
@@ -103,23 +92,22 @@
my %cplx_params = @_;
assign_option_aliases( \%cplx_params,
- 'reltol' => 'relTol',
- );
- set_default_options(\%cplx_params,
- 'tolType' => (defined($cplx_params{tol}) ) ? 'absolute' : 'relative',
- # default mode should be relative, to obtain this tol must not be defined
- 'tolerance' => $main::numAbsTolDefault,
- 'relTol' => $main::numRelPercentTolDefault,
- 'zeroLevel' => $main::numZeroLevelDefault,
- 'zeroLevelTol' => $main::numZeroLevelTolDefault,
- 'format' => $main::numFormatDefault,
- 'debug' => 0,
- 'mode' => 'std',
- 'strings' => undef,
-
- );
- my $format = $cplx_params{'format'};
- my $mode = $cplx_params{'mode'};
+ 'reltol' => 'relTol',
+ );
+ set_default_options(\%cplx_params,
+ 'tolType' => (defined($cplx_params{tol}) ) ? 'absolute' : 'relative',
+ # default mode should be relative, to obtain this tol must not be defined
+ 'tolerance' => $main::numAbsTolDefault,
+ 'relTol' => $main::numRelPercentTolDefault,
+ 'zeroLevel' => $main::numZeroLevelDefault,
+ 'zeroLevelTol' => $main::numZeroLevelTolDefault,
+ 'format' => $main::numFormatDefault,
+ 'debug' => 0,
+ 'mode' => 'std',
+ 'strings' => undef,
+ );
+ my $format = $cplx_params{'format'};
+ my $mode = $cplx_params{'mode'};
if( $cplx_params{tolType} eq 'relative' ) {
$cplx_params{'tolerance'} = .01*$cplx_params{'relTol'};
@@ -159,28 +147,21 @@
$correctVal = $correctAnswer;
}
- #if ( ($PG_eval_errors && $corrAnswerIsString == 0) or (not (( ref($correctAnswer) =~ /^Complex?/) || is_a_number($correctVal)) && $corrAnswerIsString == 0)) {
- ##error message from eval or above
- #warn "Error in 'correct' answer: $PG_eval_errors<br>
- # The answer $correctAnswer evaluates to $correctVal,
- # which cannot be interpreted as a number. ";
-
- #}
########################################################################
$correctVal = $correct_num_answer;
$correctVal = cplx( $correctVal, 0 ) unless ref($correctVal) =~/^Complex?/ || $corrAnswerIsString == 1;
#construct the answer evaluator
- my $answer_evaluator = new AnswerEvaluator;
- $answer_evaluator->{debug} = $cplx_params{debug};
+ my $answer_evaluator = new AnswerEvaluator;
+ $answer_evaluator->{debug} = $cplx_params{debug};
$answer_evaluator->ans_hash(
correct_ans => $correctVal,
- type => "${mode}_number",
- tolerance => $cplx_params{tolerance},
- tolType => 'absolute', # $cplx_params{tolType},
- original_correct_ans => $formattedCorrectAnswer,
+ type => "cplx_cmp",
+ tolerance => $cplx_params{tolerance},
+ tolType => 'absolute', # $cplx_params{tolType},
+ original_correct_ans => $formattedCorrectAnswer,
answerIsString => $corrAnswerIsString,
- answer_form => 'cartesian',
+ answer_form => 'cartesian',
);
my ($in, $formattedSubmittedAnswer);
$answer_evaluator->install_pre_filter(sub {my $rh_ans = shift;
@@ -191,7 +172,6 @@
}
$answer_evaluator->install_pre_filter(\&check_syntax);
-
$answer_evaluator->install_pre_filter(\&math_constants);
$answer_evaluator->install_pre_filter(\&cplx_constants);
$answer_evaluator->install_pre_filter(\&check_for_polar);
@@ -274,241 +254,337 @@
$rh_ans;
}
-sub mult_cmp{
- my $answer = shift;
- my @answers = @{$answer} if ref($answer) eq 'ARRAY';
- my %mult_params = @_;
- my @keys = qw ( tolerance tolType format mode zeroLevel zeroLevelTol debug );
- my @correctVal;
- my $formattedCorrectAnswer;
- my @correct_num_answer;
- my ($PG_eval_errors,$PG_full_error_report);
- assign_option_aliases( \%mult_params,
- 'reltol' => 'relTol',
- );
- set_default_options(\%mult_params,
- 'tolType' => (defined($mult_params{tol}) ) ? 'absolute' : 'relative',
- # default mode should be relative, to obtain this tol must not be defined
- 'tolerance' => $main::numAbsTolDefault,
- 'relTol' => $main::numRelPercentTolDefault,
- 'zeroLevel' => $main::numZeroLevelDefault,
- 'zeroLevelTol' => $main::numZeroLevelTolDefault,
- 'format' => $main::numFormatDefault,
- 'debug' => 0,
- 'mode' => 'std',
- 'compare' => 'num',
- );
- my $format = $mult_params{'format'};
- my $mode = $mult_params{'mode'};
-
-
- if( $mult_params{tolType} eq 'relative' ) {
- $mult_params{'tolerance'} = .01*$mult_params{'relTol'};
- }
-
- if( $mult_params{ 'compare' } eq 'cplx' ){
- foreach( @answers )
- {
- $_ = cplx( $_, 0 ) unless ref($_) =~/Complex/;
- }
- }
-
- my $corrAnswerIsString = 0;
-
- for( my $k = 0; $k < @answers; $k++ ){
- if (defined($mult_params{strings}) && $mult_params{strings}) {
- my $legalString = '';
- my @legalStrings = @{$mult_params{strings}};
- $correct_num_answer[$k] = $answers[$k];
- $formattedCorrectAnswer .= $answers[$k] . ",";
- foreach $legalString (@legalStrings) {
- if ( uc($answers[$k]) eq uc($legalString) ) {
- $corrAnswerIsString = 1;
-
- last;
- }
- } ## at this point $corrAnswerIsString = 0 iff correct answer is numeric
- } else {
- $correct_num_answer[$k] = $answers[$k];
- $formattedCorrectAnswer .= prfmt( $answers[$k], $mult_params{'format'} ) . ", ";
- }
- $correct_num_answer[$k] = math_constants($correct_num_answer[$k]);
- my $PGanswerMessage = '';
-
-
- if (defined($correct_num_answer[$k]) && $correct_num_answer[$k] =~ /\S/ && $corrAnswerIsString == 0 ) {
- ($correctVal[$k], $PG_eval_errors,$PG_full_error_report) =
- PG_answer_eval($correct_num_answer[$k]);
- } else { # case of a string answer
- $PG_eval_errors = ' ';
- $correctVal[$k] = $answers[$k];
- }
-
- #if ( ($PG_eval_errors && $corrAnswerIsString == 0) or ((not is_a_number($correctVal[$k])) && $corrAnswerIsString == 0)) {
- ##error message from eval or above
- #warn "Error in 'correct' answer: $PG_eval_errors<br>
- #The answer $answers[$k] evaluates to $correctVal[$k],
- #which cannot be interpreted as a number. ";
-
- #}
- ########################################################################
- $correctVal[$k] = $correct_num_answer[$k];
- }
- $formattedCorrectAnswer =~ s/, \Z//;
-
- #construct the answer evaluator
-
- my $answer_evaluator = new AnswerEvaluator;
+=head4 multi_cmp
+
+ Checks a comma separated string of items against an array of evaluators.
+ For example this is useful for checking all of the complex roots of an equation.
+ Each student answer must be evaluated as correct by a DISTINCT answer evalutor.
- $answer_evaluator->{debug} = $mult_params{debug};
- $answer_evaluator->ans_hash(
- correct_ans => [@correctVal],
- type => "${mode}_number",
- tolerance => $mult_params{tolerance},
- tolType => 'absolute', # $mult_params{tolType},
- original_correct_ans => $formattedCorrectAnswer,
- answerIsString => $corrAnswerIsString,
- answer_form => 'cartesian',
- );
- my ($in, $formattedSubmittedAnswer);
- $answer_evaluator->install_pre_filter(sub {my $rh_ans = shift;
- $rh_ans->{original_student_ans} = $rh_ans->{student_ans}; $rh_ans;}
- );
- if (defined($mult_params{strings}) && $mult_params{strings}) {
- $answer_evaluator->install_pre_filter(\&check_strings, %mult_params);
- }
-
- $answer_evaluator -> install_pre_filter( \&mult_prefilters, %mult_params );
- $answer_evaluator->install_pre_filter( sub{my $rh_ans = shift; $rh_ans->{original_student_ans} = $rh_ans->{student_ans};$rh_ans;});
+ This answer checker will only work reliably if each answer checker corresponds
+ to a distinct correct answer. For example if one answer checker requires
+ any positive number, and the second requires the answer 1, then 1,2 might
+ be judged incorrect since 1, satisifes the first answer checker, but 2 doesn't
+ satisfy the second. 2,1 would work however. Avoid this type of use!!
- if ($corrAnswerIsString == 0 ){ # avoiding running compare_numbers when correct answer is a string.
- $answer_evaluator->install_evaluator(\&compare_mult, %mult_params);
- }
-
-
-###############################################################################
-# We'll leave these next lines out for now, so that the evaluated versions of the student's and professor's
-# can be displayed in the answer message. This may still cause a few anomolies when strings are used
-#
-###############################################################################
- $answer_evaluator->install_post_filter( sub{my $rh_ans = shift; $rh_ans->{student_ans} = $rh_ans->{original_student_ans};$rh_ans;});
- $answer_evaluator->install_post_filter(\&fix_answers_for_display);
- $answer_evaluator->install_post_filter(\&fix_for_polar_display);
-
- $answer_evaluator->install_post_filter(sub {my $rh_ans = shift;
- return $rh_ans unless $rh_ans->catch_error('EVAL');
- $rh_ans->{student_ans} = $rh_ans->{original_student_ans}. ' '. $rh_ans->{error_message};
- $rh_ans->clear_error('EVAL'); } );
- $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('SYNTAX'); } );
- $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('POLAR'); } );
- $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('CARTESIAN'); } );
- $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('COMPLEX'); } );
- $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('STRING'); } );
- $answer_evaluator;
-}
+ Including backtracking to fit the answers as best possible to each answer evaluator
+ in the best possible way, is beyond the ambitions of this evaluator.
-sub mult_prefilters{
- my ($rh_ans, %options) = @_;
- my @student_answers = split/,/,$rh_ans->{student_ans};
- foreach( @student_answers ){
- $rh_ans->{student_ans} = $_;
- $rh_ans = &check_syntax( $rh_ans );
- $rh_ans = &math_constants( $rh_ans );
- if( $options{compare} eq 'cplx' ){
- $rh_ans = &cplx_constants( $rh_ans );
- #$rh_ans = &check_for_polar( $rh_ans );
- }
- if ( $options{mode} eq 'std') {
- # do nothing
- } elsif ($options{mode} eq 'strict_polar') {
- $rh_ans = &is_a_polar( $rh_ans );
- } elsif ($options{mode} eq 'strict_num_cartesian') {
- $rh_ans = &is_a_numeric_cartesian( $rh_ans );
- } elsif ($options{mode} eq 'strict_num_polar') {
- $rh_ans = &is_a_numeric_polar( $rh_ans );
- } elsif ($options{mode} eq 'strict') {
- $rh_ans = &is_a_numeric_complex( $rh_ans );
- } elsif ($options{mode} eq 'arith') {
- $rh_ans = &is_an_arithmetic_expression( $rh_ans );
- } elsif ($options{mode} eq 'frac') {
- $rh_ans = &is_a_fraction( $rh_ans );
-
- } else {
- #$PGanswerMessage = 'Tell your professor that there is an error in his or her answer mechanism. No mode was specified.';
- #$formattedSubmittedAnswer = $in;
- }
- $_ = $rh_ans->{student_ans};
- }
- my $ans_string;
- foreach( @student_answers )
- {
- $ans_string .= ", $_";
- }
- $ans_string =~ s/\A,//;
- $rh_ans->{student_ans} = $ans_string;
- $rh_ans;
-}
-# compares two complex numbers by comparing their real and imaginary parts
-sub compare_mult {
- my ($rh_ans, %options) = @_;
- my @student_answers = split/,/,$rh_ans->{student_ans};
- my @correct_answers = @{$rh_ans->{correct_ans}};
- my $one_correct = 1/@correct_answers;
- my $temp_score = 0;
- foreach( @correct_answers ){
- $rh_ans->{correct_ans} = $_;
- foreach( @student_answers ){
- $rh_ans->{student_ans} = $_;
- if( $options{compare} eq 'cplx' ){
- $rh_ans = &compare_cplx( $rh_ans, %options);
- }else{
- $rh_ans = &compare_numbers( $rh_ans, %options);
- }
- if( $rh_ans->{score} == 1 )
- {
- $temp_score += $one_correct;
- $rh_ans->{score} = 0;
- last;
- }
- }
- }
- $rh_ans->{score} = $temp_score;
- $rh_ans;
-
-}
+=cut
-sub multi_cmp{
- my $pointer = shift;
+sub multi_cmp {
+ my $ra_answer_evaluators = shift; # array of evaluators
my %options = @_;
- my @evals = @{$pointer};
- my $answer_evaluator = new AnswerEvaluator;
- $answer_evaluator->install_evaluator( sub {
+ my @answer_evaluators = @{$ra_answer_evaluators};
+ my $backup_ans_eval = $answer_evaluators[0];
+ my $multi_ans_evaluator = new AnswerEvaluator;
+ $multi_ans_evaluator->install_evaluator( sub {
my $rh_ans = shift;
- $rh_ans->{score} = 1;#in order to use AND below, score must be 1
- $rh_ans->{preview_text_string} = "";#needs to be initialized to prevent warnings
- my @student_answers = split/,/,$rh_ans->{student_ans};
- foreach my $eval ( @evals ){
- my $temp_eval = new AnswerEvaluator;
- my $temp_hash = $temp_eval->ans_hash;
- $temp_hash->{preview_text_string} = "";#needs to be initialized to prevent warnings
- foreach my $temp ( @student_answers ){
- $eval->evaluate($temp);
- $temp = $eval->ans_hash->{student_ans} unless $eval->ans_hash->{student_ans}=~ /you/i;
- $temp_hash = $temp_hash->OR( $eval->ans_hash );
- if( $eval->ans_hash->{score} == 1){ last; }
+ my @student_answers = split/\s*,\s*/,$rh_ans->{student_ans};
+ my @evaluated_ans_hashes = ();
+ for ( my $j=0; $j<@student_answers; $j++ ) {
+ # find an answer evaluator which marks this answer correct.
+ my $student_ans = $student_answers[$j];
+ my $temp_hash;
+ for ( my $i=0; $i<@answer_evaluators; $i++ ) {
+ my $evaluator = $answer_evaluators[$i];
+ $temp_hash = new AnswerHash; # make a copy of the answer hash resulting from the evaluation
+ %$temp_hash = %{$evaluator->evaluate($student_ans)};
+ if (($temp_hash->{score} == 1)) {
+ # save evaluated answer
+ push @evaluated_ans_hashes, $temp_hash;
+ # remove answer evaluator and check the next answer
+ splice(@answer_evaluators,$i,1);
+ last;
+ }
+ }
+ # if we exit the loop without finding a correct evaluation:
+ # make sure every answer is evaluated, even extra answers for which
+ # there will be no answer evaluators left.
+ if (not defined($temp_hash) ) { # make sure every answer is evaluated, even extra answers.
+ my $evaluator = $backup_ans_eval;
+ $temp_hash = new AnswerHash; # make a copy of the answer hash resulting from the evaluation
+ %$temp_hash = %{$evaluator->evaluate($student_ans)};
+ $temp_hash->{score} =0; # this was an extra answer -- clearly incorrect
+ $temp_hash->{correct_ans} = "too many answers";
+ }
+ # now make sure that even answers which
+ # don't never evaluate correctly are still recorded in the list
+ if ( $temp_hash->{score} <1) {
+ push @evaluated_ans_hashes, $temp_hash;
}
- $rh_ans = $rh_ans->AND( $temp_hash );
+
+
+ }
+ # construct the final answer hash
+ my $rh_ans_out = shift @evaluated_ans_hashes;
+ while (@evaluated_ans_hashes) {
+ my $temp_hash = shift @evaluated_ans_hashes;
+ $rh_ans_out =$rh_ans_out->AND($temp_hash);
}
- $rh_ans->{correct_ans} =~ s/No correct answer specified (OR|AND) //g;
- $rh_ans->{student_ans} = "";
- foreach( @student_answers ){ $rh_ans->{student_ans} .= "$_, "; }
- $rh_ans->{student_ans} =~ s/, \Z//;
- if( scalar(@evals) != scalar(@student_answers) ){ $rh_ans->{score} = 0; }#wrong number of answers makes answer wrong
- $rh_ans; });
- $answer_evaluator;
+ $rh_ans_out->{student_ans} = $rh_ans->{student_ans};
+ $rh_ans_out->{score}=0 unless @{$ra_answer_evaluators} == @student_answers; # require the correct number of answers
+ $rh_ans_out;
+ });
+ $multi_ans_evaluator;
}
+# sub multi_cmp_old{
+# my $pointer = shift; # array of evaluators
+# my %options = @_;
+# my @evals = @{$pointer};
+# my $answer_evaluator = new AnswerEvaluator;
+# $answer_evaluator->install_evaluator( sub {
+# my $rh_ans = shift;
+# $rh_ans->{score} = 1;#in order to use AND below, score must be 1
+# $rh_ans->{preview_text_string} = "";#needs to be initialized to prevent warnings
+# my @student_answers = split/,/,$rh_ans->{student_ans};
+# foreach my $eval ( @evals ){
+# my $temp_eval = new AnswerEvaluator;
+# my $temp_hash = $temp_eval->ans_hash;
+# $temp_hash->{preview_text_string} = "";#needs to be initialized to prevent warnings
+# #FIXME I believe there is a logic problem here.
+# # If each answer entered is judged correct by ONE answer evaluator
+# # then the answer is correct, but for example if you enter a correct
+# # root to an equation twice each answer will be judged correct and
+# # and the whole question correct, even though the answer omits
+# # the second root.
+# foreach my $temp ( @student_answers ){
+# $eval->evaluate($temp);
+# $temp = $eval->ans_hash->{student_ans} unless $eval->ans_hash->{student_ans}=~ /you/i;
+# $temp_hash = $temp_hash->OR( $eval->ans_hash );
+# if( $eval->ans_hash->{score} == 1){ last; }
+# }
+# $rh_ans = $rh_ans->AND( $temp_hash );
+# }
+# #$rh_ans->{correct_ans} =~ s/No correct answer specified (OR|AND) //g;
+# $rh_ans->{student_ans} = "";
+# foreach( @student_answers ){ $rh_ans->{student_ans} .= "$_, "; }
+# $rh_ans->{student_ans} =~ s/, \Z//;
+# if( scalar(@evals) != scalar(@student_answers) ){ $rh_ans->{score} = 0; }#wrong number of answers makes answer wrong
+# $rh_ans; });
+# $answer_evaluator;
+# }
+# this does not seem to be in use, so I'm commenting it out. Mike Gage 6/27/05
+# sub mult_cmp{
+# my $answer = shift;
+# my @answers = @{$answer} if ref($answer) eq 'ARRAY';
+# my %mult_params = @_;
+# my @keys = qw ( tolerance tolType format mode zeroLevel zeroLevelTol debug );
+# my @correctVal;
+# my $formattedCorrectAnswer;
+# my @correct_num_answer;
+# my ($PG_eval_errors,$PG_full_error_report);
+# assign_option_aliases( \%mult_params,
+# 'reltol' => 'relTol',
+# );
+# set_default_options(\%mult_params,
+# 'tolType' => (defined($mult_params{tol}) ) ? 'absolute' : 'relative',
+# # default mode should be relative, to obtain this tol must not be defined
+# 'tolerance' => $main::numAbsTolDefault,
+# 'relTol' => $main::numRelPercentTolDefault,
+# 'zeroLevel' => $main::numZeroLevelDefault,
+# 'zeroLevelTol' => $main::numZeroLevelTolDefault,
+# 'format' => $main::numFormatDefault,
+# 'debug' => 0,
+# 'mode' => 'std',
+# 'compare' => 'num',
+# );
+# my $format = $mult_params{'format'};
+# my $mode = $mult_params{'mode'};
+#
+#
+# if( $mult_params{tolType} eq 'relative' ) {
+# $mult_params{'tolerance'} = .01*$mult_params{'relTol'};
+# }
+#
+# if( $mult_params{ 'compare' } eq 'cplx' ){
+# foreach( @answers )
+# {
+# $_ = cplx( $_, 0 ) unless ref($_) =~/Complex/;
+# }
+# }
+#
+# my $corrAnswerIsString = 0;
+#
+# for( my $k = 0; $k < @answers; $k++ ){
+# if (defined($mult_params{strings}) && $mult_params{strings}) {
+# my $legalString = '';
+# my @legalStrings = @{$mult_params{strings}};
+# $correct_num_answer[$k] = $answers[$k];
+# $formattedCorrectAnswer .= $answers[$k] . ",";
+# foreach $legalString (@legalStrings) {
+# if ( uc($answers[$k]) eq uc($legalString) ) {
+# $corrAnswerIsString = 1;
+#
+# last;
+# }
+# } ## at this point $corrAnswerIsString = 0 iff correct answer is numeric
+# } else {
+# $correct_num_answer[$k] = $answers[$k];
+# $formattedCorrectAnswer .= prfmt( $answers[$k], $mult_params{'format'} ) . ", ";
+# }
+# $correct_num_answer[$k] = math_constants($correct_num_answer[$k]);
+# my $PGanswerMessage = '';
+#
+#
+# if (defined($correct_num_answer[$k]) && $correct_num_answer[$k] =~ /\S/ && $corrAnswerIsString == 0 ) {
+# ($correctVal[$k], $PG_eval_errors,$PG_full_error_report) =
+# PG_answer_eval($correct_num_answer[$k]);
+# } else { # case of a string answer
+# $PG_eval_errors = ' ';
+# $correctVal[$k] = $answers[$k];
+# }
+#
+# #if ( ($PG_eval_errors && $corrAnswerIsString == 0) or ((not is_a_number($correctVal[$k])) && $corrAnswerIsString == 0)) {
+# ##error message from eval or above
+# #warn "Error in 'correct' answer: $PG_eval_errors<br>
+# #The answer $answers[$k] evaluates to $correctVal[$k],
+# #which cannot be interpreted as a number. ";
+#
+# #}
+# ########################################################################
+# $correctVal[$k] = $correct_num_answer[$k];
+# }
+# $formattedCorrectAnswer =~ s/, \Z//;
+#
+# #construct the answer evaluator
+#
+# my $answer_evaluator = new AnswerEvaluator;
+#
+#
+# $answer_evaluator->{debug} = $mult_params{debug};
+# $answer_evaluator->ans_hash(
+# correct_ans => [@correctVal],
+# type => "${mode}_number",
+# tolerance => $mult_params{tolerance},
+# tolType => 'absolute', # $mult_params{tolType},
+# original_correct_ans => $formattedCorrectAnswer,
+# answerIsString => $corrAnswerIsString,
+# answer_form => 'cartesian',
+# );
+# my ($in, $formattedSubmittedAnswer);
+# $answer_evaluator->install_pre_filter(sub {my $rh_ans = shift;
+# $rh_ans->{original_student_ans} = $rh_ans->{student_ans}; $rh_ans;}
+# );
+# if (defined($mult_params{strings}) && $mult_params{strings}) {
+# $answer_evaluator->install_pre_filter(\&check_strings, %mult_params);
+# }
+#
+# $answer_evaluator -> install_pre_filter( \&mult_prefilters, %mult_params );
+# $answer_evaluator->install_pre_filter( sub{my $rh_ans = shift; $rh_ans->{original_student_ans} = $rh_ans->{student_ans};$rh_ans;});
+#
+# if ($corrAnswerIsString == 0 ){ # avoiding running compare_numbers when correct answer is a string.
+# $answer_evaluator->install_evaluator(\&compare_mult, %mult_params);
+# }
+#
+#
+# ###############################################################################
+# # We'll leave these next lines out for now, so that the evaluated versions of the student's and professor's
+# # can be displayed in the answer message. This may still cause a few anomolies when strings are used
+# #
+# ###############################################################################
+# $answer_evaluator->install_post_filter( sub{my $rh_ans = shift; $rh_ans->{student_ans} = $rh_ans->{original_student_ans};$rh_ans;});
+# $answer_evaluator->install_post_filter(\&fix_answers_for_display);
+# $answer_evaluator->install_post_filter(\&fix_for_polar_display);
+#
+# $answer_evaluator->install_post_filter(sub {my $rh_ans = shift;
+# return $rh_ans unless $rh_ans->catch_error('EVAL');
+# $rh_ans->{student_ans} = $rh_ans->{original_student_ans}. ' '. $rh_ans->{error_message};
+# $rh_ans->clear_error('EVAL'); } );
+# $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('SYNTAX'); } );
+# $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('POLAR'); } );
+# $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('CARTESIAN'); } );
+# $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('COMPLEX'); } );
+# $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('STRING'); } );
+# $answer_evaluator;
+# }
+
+# sub mult_prefilters{
+# my ($rh_ans, %options) = @_;
+# my @student_answers = split/,/,$rh_ans->{student_ans};
+# foreach( @student_answers ){
+# $rh_ans->{student_ans} = $_;
+# $rh_ans = &check_syntax( $rh_ans );
+# $rh_ans = &math_constants( $rh_ans );
+# if( $options{compare} eq 'cplx' ){
+# $rh_ans = &cplx_constants( $rh_ans );
+# #$rh_ans = &check_for_polar( $rh_ans );
+# }
+# if ( $options{mode} eq 'std') {
+# # do nothing
+# } elsif ($options{mode} eq 'strict_polar') {
+# $rh_ans = &is_a_polar( $rh_ans );
+# } elsif ($options{mode} eq 'strict_num_cartesian') {
+# $rh_ans = &is_a_numeric_cartesian( $rh_ans );
+# } elsif ($options{mode} eq 'strict_num_polar') {
+# $rh_ans = &is_a_numeric_polar( $rh_ans );
+# } elsif ($options{mode} eq 'strict') {
+# $rh_ans = &is_a_numeric_complex( $rh_ans );
+# } elsif ($options{mode} eq 'arith') {
+# $rh_ans = &is_an_arithmetic_expression( $rh_ans );
+# } elsif ($options{mode} eq 'frac') {
+# $rh_ans = &is_a_fraction( $rh_ans );
+#
+# } else {
+# #$PGanswerMessage = 'Tell your professor that there is an error in his or her answer mechanism. No mode was specified.';
+# #$formattedSubmittedAnswer = $in;
+# }
+# $_ = $rh_ans->{student_ans};
+# }
+# my $ans_string;
+# foreach( @student_answers )
+# {
+# $ans_string .= ", $_";
+# }
+# $ans_string =~ s/\A,//;
+# $rh_ans->{student_ans} = $ans_string;
+# $rh_ans;
+# }
+
+# sub polar{
+# my $z = shift;
+# my %options = @_;
+# my $r = rho($z);
+# my $theta = $z->theta;
+# my $r_format = ':%0.3f';
+# my $theta_format = ':%0.3f';
+# $r_format=":" . $options{r_format} if defined($options{r_format});
+# $theta_format = ":" . $options{theta_format} if defined($options{theta_format});
+# "{$r$r_format} e^{i {$theta$theta_format}}";
+#
+# }
+
+# compares two complex numbers by comparing their real and imaginary parts
+# sub compare_mult {
+# my ($rh_ans, %options) = @_;
+# my @student_answers = split/,/,$rh_ans->{student_ans};
+# my @correct_answers = @{$rh_ans->{correct_ans}};
+# my $one_correct = 1/@correct_answers;
+# my $temp_score = 0;
+# foreach( @correct_answers ){
+# $rh_ans->{correct_ans} = $_;
+# foreach( @student_answers ){
+# $rh_ans->{student_ans} = $_;
+# if( $options{compare} eq 'cplx' ){
+# $rh_ans = &compare_cplx( $rh_ans, %options);
+# }else{
+# $rh_ans = &compare_numbers( $rh_ans, %options);
+# }
+# if( $rh_ans->{score} == 1 )
+# {
+# $temp_score += $one_correct;
+# $rh_ans->{score} = 0;
+# last;
+# }
+# }
+# }
+# $rh_ans->{score} = $temp_score;
+# $rh_ans;
+#
+# }
+
+
# Output is text displaying the complex numver in "e to the i theta" form. The
# formats for the argument theta is determined by the option C<theta_format> and the
@@ -742,366 +818,369 @@
$rh_ans;
}
-sub cplx_cmp2 {
- my $correctAnswer = shift;
- my %cplx_params = @_;
- my @keys = qw ( correctAnswer tolerance tolType format mode zeroLevel zeroLevelTol debug );
- assign_option_aliases( \%cplx_params,
- 'reltol' => 'relTol',
- );
- set_default_options(\%cplx_params,
- 'tolType' => (defined($cplx_params{tol}) ) ? 'absolute' : 'relative',
- # default mode should be relative, to obtain this tol must not be defined
- 'tolerance' => $main::numAbsTolDefault,
- 'relTol' => $main::numRelPercentTolDefault,
- 'zeroLevel' => $main::numZeroLevelDefault,
- 'zeroLevelTol' => $main::numZeroLevelTolDefault,
- 'format' => $main::numFormatDefault,
- 'debug' => 0,
- 'mode' => 'std',
-
- );
- $correctAnswer = cplx($correctAnswer,0) unless ref($correctAnswer) =~/Complex/;
- my $format = $cplx_params{'format'};
- my $mode = $cplx_params{'mode'};
-
- if( $cplx_params{tolType} eq 'relative' ) {
- $cplx_params{'tolerance'} = .01*$cplx_params{'relTol'};
- }
-
- my $formattedCorrectAnswer;
- my $correct_num_answer;
- my $corrAnswerIsString = 0;
-
-
- if (defined($cplx_params{strings}) && $cplx_params{strings}) {
- my $legalString = '';
- my @legalStrings = @{$cplx_params{strings}};
- $correct_num_answer = $correctAnswer;
- $formattedCorrectAnswer = $correctAnswer;
- foreach $legalString (@legalStrings) {
- if ( uc($correctAnswer) eq uc($legalString) ) {
- $corrAnswerIsString = 1;
-
- last;
- }
- } ## at this point $corrAnswerIsString = 0 iff correct answer is numeric
- } else {
- $correct_num_answer = $correctAnswer;
- $formattedCorrectAnswer = prfmt( $correctAnswer, $cplx_params{'format'} );
- }
- $correct_num_answer = math_constants($correct_num_answer);
- my $PGanswerMessage = '';
-
- my ($inVal,$correctVal,$PG_eval_errors,$PG_full_error_report);
-
- if (defined($correct_num_answer) && $correct_num_answer =~ /\S/ && $corrAnswerIsString == 0 ) {
- ($correctVal, $PG_eval_errors,$PG_full_error_report) = PG_answer_eval($correct_num_answer);
- } else { # case of a string answer
- $PG_eval_errors = ' ';
- $correctVal = $correctAnswer;
- }
-
- if ( ($PG_eval_errors && $corrAnswerIsString == 0) or ((not is_a_number($correctVal)) && $corrAnswerIsString == 0)) {
- ##error message from eval or above
- warn "Error in 'correct' answer: $PG_eval_errors<br>
- The answer $correctAnswer evaluates to $correctVal,
- which cannot be interpreted as a number. ";
-
- }
- ########################################################################
- $correctVal = $correct_num_answer;#it took me two and a half hours to figure out that correctVal wasn't
- #getting the number properly
- #construct the answer evaluator
- my $answer_evaluator = new AnswerEvaluator;
-
-
- $answer_evaluator->{debug} = $cplx_params{debug};
- $answer_evaluator->ans_hash(
- correct_ans => $correctVal,
- type => "${mode}_number",
- tolerance => $cplx_params{tolerance},
- tolType => 'absolute', # $cplx_params{tolType},
- original_correct_ans => $formattedCorrectAnswer,
- answerIsString => $corrAnswerIsString,
- answer_form => 'cartesian',
- );
- my ($in, $formattedSubmittedAnswer);
- $answer_evaluator->install_pre_filter(sub {my $rh_ans = shift;
- $rh_ans->{original_student_ans} = $rh_ans->{student_ans}; $rh_ans;}
- );
- if (defined($cplx_params{strings}) && $cplx_params{strings}) {
- $answer_evaluator->install_pre_filter(\&check_strings, %cplx_params);
- }
- #$answer_evaluator->install_pre_filter(\&check_syntax);
-
- $answer_evaluator->install_pre_filter(\&math_constants);
- $answer_evaluator->install_pre_filter(\&cplx_constants);
- $answer_evaluator->install_pre_filter(\&check_for_polar);
- if ($mode eq 'std') {
- # do nothing
- } elsif ($mode eq 'strict_polar') {
- $answer_evaluator->install_pre_filter(\&is_a_polar);
- } elsif ($mode eq 'strict_num_cartesian') {
- $answer_evaluator->install_pre_filter(\&is_a_numeric_cartesian);
- } elsif ($mode eq 'strict_num_polar') {
- $answer_evaluator->install_pre_filter(\&is_a_numeric_polar);
- } elsif ($mode eq 'strict') {
- $answer_evaluator->install_pre_filter(\&is_a_numeric_complex);
- } elsif ($mode eq 'arith') {
- $answer_evaluator->install_pre_filter(\&is_an_arithmetic_expression);
- } elsif ($mode eq 'frac') {
- $answer_evaluator->install_pre_filter(\&is_a_fraction);
-
- } else {
- $PGanswerMessage = 'Tell your professor that there is an error in his or her answer mechanism. No mode was specified.';
- $formattedSubmittedAnswer = $in;
- }
- if ($corrAnswerIsString == 0 ){ # avoiding running compare_numbers when correct answer is a string.
- $answer_evaluator->install_evaluator(\&compare_cplx2, %cplx_params);
- }
-
-
-###############################################################################
-# We'll leave these next lines out for now, so that the evaluated versions of the student's and professor's
-# can be displayed in the answer message. This may still cause a few anomolies when strings are used
-#
-###############################################################################
-
- $answer_evaluator->install_post_filter(\&fix_answers_for_display);
- $answer_evaluator->install_post_filter(\&fix_for_polar_display);
-
- $answer_evaluator->install_post_filter(sub {my $rh_ans = shift;
- return $rh_ans unless $rh_ans->catch_error('EVAL');
- $rh_ans->{student_ans} = $rh_ans->{original_student_ans}. ' '. $rh_ans->{error_message};
- $rh_ans->clear_error('EVAL'); } );
- $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('SYNTAX'); } );
- $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('POLAR'); } );
- $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('CARTESIAN'); } );
- $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('COMPLEX'); } );
- $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('STRING'); } );
- $answer_evaluator;
-}
+# this does not seem to be in use, so I'm commenting it out. Mike Gage 6/27/05
+# sub cplx_cmp2 {
+# my $correctAnswer = shift;
+# my %cplx_params = @_;
+# my @keys = qw ( correctAnswer tolerance tolType format mode zeroLevel zeroLevelTol debug );
+# assign_option_aliases( \%cplx_params,
+# 'reltol' => 'relTol',
+# );
+# set_default_options(\%cplx_params,
+# 'tolType' => (defined($cplx_params{tol}) ) ? 'absolute' : 'relative',
+# # default mode should be relative, to obtain this tol must not be defined
+# 'tolerance' => $main::numAbsTolDefault,
+# 'relTol' => $main::numRelPercentTolDefault,
+# 'zeroLevel' => $main::numZeroLevelDefault,
+# 'zeroLevelTol' => $main::numZeroLevelTolDefault,
+# 'format' => $main::numFormatDefault,
+# 'debug' => 0,
+# 'mode' => 'std',
+#
+# );
+# $correctAnswer = cplx($correctAnswer,0) unless ref($correctAnswer) =~/Complex/;
+# my $format = $cplx_params{'format'};
+# my $mode = $cplx_params{'mode'};
+#
+# if( $cplx_params{tolType} eq 'relative' ) {
+# $cplx_params{'tolerance'} = .01*$cplx_params{'relTol'};
+# }
+#
+# my $formattedCorrectAnswer;
+# my $correct_num_answer;
+# my $corrAnswerIsString = 0;
+#
+#
+# if (defined($cplx_params{strings}) && $cplx_params{strings}) {
+# my $legalString = '';
+# my @legalStrings = @{$cplx_params{strings}};
+# $correct_num_answer = $correctAnswer;
+# $formattedCorrectAnswer = $correctAnswer;
+# foreach $legalString (@legalStrings) {
+# if ( uc($correctAnswer) eq uc($legalString) ) {
+# $corrAnswerIsString = 1;
+#
+# last;
+# }
+# } ## at this point $corrAnswerIsString = 0 iff correct answer is numeric
+# } else {
+# $correct_num_answer = $correctAnswer;
+# $formattedCorrectAnswer = prfmt( $correctAnswer, $cplx_params{'format'} );
+# }
+# $correct_num_answer = math_constants($correct_num_answer);
+# my $PGanswerMessage = '';
+#
+# my ($inVal,$correctVal,$PG_eval_errors,$PG_full_error_report);
+#
+# if (defined($correct_num_answer) && $correct_num_answer =~ /\S/ && $corrAnswerIsString == 0 ) {
+# ($correctVal, $PG_eval_errors,$PG_full_error_report) = PG_answer_eval($correct_num_answer);
+# } else { # case of a string answer
+# $PG_eval_errors = ' ';
+# $correctVal = $correctAnswer;
+# }
+#
+# if ( ($PG_eval_errors && $corrAnswerIsString == 0) or ((not is_a_number($correctVal)) && $corrAnswerIsString == 0)) {
+# ##error message from eval or above
+# warn "Error in 'correct' answer: $PG_eval_errors<br>
+# The answer $correctAnswer evaluates to $correctVal,
+# which cannot be interpreted as a number. ";
+#
+# }
+# ########################################################################
+# $correctVal = $correct_num_answer;#it took me two and a half hours to figure out that correctVal wasn't
+# #getting the number properly
+# #construct the answer evaluator
+# my $answer_evaluator = new AnswerEvaluator;
+#
+#
+# $answer_evaluator->{debug} = $cplx_params{debug};
+# $answer_evaluator->ans_hash(
+# correct_ans => $correctVal,
+# type => "${mode}_number",
+# tolerance => $cplx_params{tolerance},
+# tolType => 'absolute', # $cplx_params{tolType},
+# original_correct_ans => $formattedCorrectAnswer,
+# answerIsString => $corrAnswerIsString,
+# answer_form => 'cartesian',
+# );
+# my ($in, $formattedSubmittedAnswer);
+# $answer_evaluator->install_pre_filter(sub {my $rh_ans = shift;
+# $rh_ans->{original_student_ans} = $rh_ans->{student_ans}; $rh_ans;}
+# );
+# if (defined($cplx_params{strings}) && $cplx_params{strings}) {
+# $answer_evaluator->install_pre_filter(\&check_strings, %cplx_params);
+# }
+# #$answer_evaluator->install_pre_filter(\&check_syntax);
+#
+# $answer_evaluator->install_pre_filter(\&math_constants);
+# $answer_evaluator->install_pre_filter(\&cplx_constants);
+# $answer_evaluator->install_pre_filter(\&check_for_polar);
+# if ($mode eq 'std') {
+# # do nothing
+# } elsif ($mode eq 'strict_polar') {
+# $answer_evaluator->install_pre_filter(\&is_a_polar);
+# } elsif ($mode eq 'strict_num_cartesian') {
+# $answer_evaluator->install_pre_filter(\&is_a_numeric_cartesian);
+# } elsif ($mode eq 'strict_num_polar') {
+# $answer_evaluator->install_pre_filter(\&is_a_numeric_polar);
+# } elsif ($mode eq 'strict') {
+# $answer_evaluator->install_pre_filter(\&is_a_numeric_complex);
+# } elsif ($mode eq 'arith') {
+# $answer_evaluator->install_pre_filter(\&is_an_arithmetic_expression);
+# } elsif ($mode eq 'frac') {
+# $answer_evaluator->install_pre_filter(\&is_a_fraction);
+#
+# } else {
+# $PGanswerMessage = 'Tell your professor that there is an error in his or her answer mechanism. No mode was specified.';
+# $formattedSubmittedAnswer = $in;
+# }
+# if ($corrAnswerIsString == 0 ){ # avoiding running compare_numbers when correct answer is a string.
+# $answer_evaluator->install_evaluator(\&compare_cplx2, %cplx_params);
+# }
+#
+#
+# ###############################################################################
+# # We'll leave these next lines out for now, so that the evaluated versions of the student's and professor's
+# # can be displayed in the answer message. This may still cause a few anomolies when strings are used
+# #
+# ###############################################################################
+#
+# $answer_evaluator->install_post_filter(\&fix_answers_for_display);
+# $answer_evaluator->install_post_filter(\&fix_for_polar_display);
+#
+# $answer_evaluator->install_post_filter(sub {my $rh_ans = shift;
+# return $rh_ans unless $rh_ans->catch_error('EVAL');
+# $rh_ans->{student_ans} = $rh_ans->{original_student_ans}. ' '. $rh_ans->{error_message};
+# $rh_ans->clear_error('EVAL'); } );
+# $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('SYNTAX'); } );
+# $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('POLAR'); } );
+# $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('CARTESIAN'); } );
+# $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('COMPLEX'); } );
+# $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('STRING'); } );
+# $answer_evaluator;
+# }
# compares two complex numbers by comparing their real and imaginary parts
-sub compare_cplx2 {
- my ($rh_ans, %options) = @_;
- my @answers = split/,/,$rh_ans->{student_ans};
- foreach( @answers )
- {
- $rh_ans->{student_ans} = $_;
- $rh_ans = &check_syntax( $rh_ans );
- my ($inVal,$PG_eval_errors,$PG_full_error_report) = PG_answer_eval($rh_ans->{student_ans});
-
- if ($PG_eval_errors) {
- $rh_ans->throw_error('EVAL','There is a syntax error in your answer');
- $rh_ans->{ans_message} = clean_up_error_msg($PG_eval_errors);
- # return $rh_ans;
- } else {
- $rh_ans->{student_ans} = prfmt($inVal,$options{format});
- }
-
- $inVal = cplx($inVal,0) unless ref($inVal) =~/Complex/;
- my $permitted_error_Re;
- my $permitted_error_Im;
- if ($rh_ans->{tolType} eq 'absolute') {
- $permitted_error_Re = $rh_ans->{tolerance};
- $permitted_error_Im = $rh_ans->{tolerance};
- }
- elsif ( abs($rh_ans->{correct_ans}) <= $options{zeroLevel}) {
- $permitted_error_Re = $options{zeroLevelTol}; ## want $tol to be non zero
- $permitted_error_Im = $options{zeroLevelTol}; ## want $tol to be non zero
- }
- else {
- $permitted_error_Re = abs($rh_ans->{tolerance}*$rh_ans->{correct_ans}->Complex::Re);
- $permitted_error_Im = abs($rh_ans->{tolerance}*$rh_ans->{correct_ans}->Complex::Im);
-
- }
-
- $rh_ans->{score} = 1 if ( abs( $rh_ans->{correct_ans}->Complex::Re - $inVal->Complex::Re) <=
- $permitted_error_Re && abs($rh_ans->{correct_ans}->Complex::Im - $inVal->Complex::Im )<= $permitted_error_Im );
- if( $rh_ans->{score} == 1 ){ return $rh_ans; }
-
-
- }
- $rh_ans;
-
-}
-
-
-sub cplx_cmp_mult {
- my $correctAnswer = shift;
- my %cplx_params = @_;
- my @keys = qw ( correctAnswer tolerance tolType format mode zeroLevel zeroLevelTol debug );
- assign_option_aliases( \%cplx_params,
- 'reltol' => 'relTol',
- );
- set_default_options(\%cplx_params,
- 'tolType' => (defined($cplx_params{tol}) ) ? 'absolute' : 'relative',
- # default mode should be relative, to obtain this tol must not be defined
- 'tolerance' => $main::numAbsTolDefault,
- 'relTol' => $main::numRelPercentTolDefault,
- 'zeroLevel' => $main::numZeroLevelDefault,
- 'zeroLevelTol' => $main::numZeroLevelTolDefault,
- 'format' => $main::numFormatDefault,
- 'debug' => 0,
- 'mode' => 'std',
-
- );
- $correctAnswer = cplx($correctAnswer,0) unless ref($correctAnswer) =~/Complex/;
- my $format = $cplx_params{'format'};
- my $mode = $cplx_params{'mode'};
-
- if( $cplx_params{tolType} eq 'relative' ) {
- $cplx_params{'tolerance'} = .01*$cplx_params{'relTol'};
- }
-
- my $formattedCorrectAnswer;
- my $correct_num_answer;
- my $corrAnswerIsString = 0;
-
-
- if (defined($cplx_params{strings}) && $cplx_params{strings}) {
- my $legalString = '';
- my @legalStrings = @{$cplx_params{strings}};
- $correct_num_answer = $correctAnswer;
- $formattedCorrectAnswer = $correctAnswer;
- foreach $legalString (@legalStrings) {
- if ( uc($correctAnswer) eq uc($legalString) ) {
- $corrAnswerIsString = 1;
-
- last;
- }
- } ## at this point $corrAnswerIsString = 0 iff correct answer is numeric
- } else {
- $correct_num_answer = $correctAnswer;
- $formattedCorrectAnswer = prfmt( $correctAnswer, $cplx_params{'format'} );
- }
- $correct_num_answer = math_constants($correct_num_answer);
- my $PGanswerMessage = '';
-
- my ($inVal,$correctVal,$PG_eval_errors,$PG_full_error_report);
-
- if (defined($correct_num_answer) && $correct_num_answer =~ /\S/ && $corrAnswerIsString == 0 ) {
- ($correctVal, $PG_eval_errors,$PG_full_error_report) = PG_answer_eval($correct_num_answer);
- } else { # case of a string answer
- $PG_eval_errors = ' ';
- $correctVal = $correctAnswer;
- }
-
- if ( ($PG_eval_errors && $corrAnswerIsString == 0) or ((not is_a_number($correctVal)) && $corrAnswerIsString == 0)) {
- ##error message from eval or above
- warn "Error in 'correct' answer: $PG_eval_errors<br>
- The answer $correctAnswer evaluates to $correctVal,
- which cannot be interpreted as a number. ";
-
- }
- ########################################################################
- $correctVal = $correct_num_answer;#it took me two and a half hours to figure out that correctVal wasn't
- #getting the number properly
- #construct the answer evaluator
- my $counter = 0;
- my $answer_evaluator = new AnswerEvaluator;
-
- my $number;
- $answer_evaluator->install_pre_filter( sub{ my $rh_ans = shift; my @temp =
- split/,/,$rh_ans->{student_ans}; $number = @temp; warn "this number ", $number; $rh_ans;});
- warn "number ", $number;
- while( $counter < 4 )
- {
- $answer_evaluator = &answer_mult( $correctVal, $mode, $formattedCorrectAnswer,
- $corrAnswerIsString, $counter, %cplx_params );
- warn "answer_evaluator ", $answer_evaluator;
- $answer_evaluator->install_evaluator( sub { my $rh_ans = shift; warn "score ", $rh_ans->{score};
- $rh_ans;});
- $counter += 1;
- }
-
- $answer_evaluator;
-
-}
-
-sub answer_mult{
- my $correctVal = shift;
- my $mode = shift;
- my $formattedCorrectAnswer = shift;
- my $corrAnswerIsString = shift;
- my $counter = shift;
- warn "counter ", $counter;
-
- my %cplx_params = @_;
- my $answer_evaluator = new AnswerEvaluator;
-
-
- $answer_evaluator->{debug} = $cplx_params{debug};
- $answer_evaluator->ans_hash(
- correct_ans => $correctVal,
- type => "${mode}_number",
- tolerance => $cplx_params{tolerance},
- tolType => 'absolute', # $cplx_params{tolType},
- original_correct_ans => $formattedCorrectAnswer,
- answerIsString => $corrAnswerIsString,
- answer_form => 'cartesian',
- );
- $answer_evaluator->install_pre_filter(sub {
- my $rh_ans = shift;
- $rh_ans->{original_student_ans} = $rh_ans->{student_ans};
- my @answers = split/,/,$rh_ans->{student_ans};
- $rh_ans -> {student_ans} = $answers[$counter];
- $rh_ans;
- }
- );
- if (defined($cplx_params{strings}) && $cplx_params{strings}) {
- $answer_evaluator->install_pre_filter(\&check_strings, %cplx_params);
- }
- $answer_evaluator->install_pre_filter(\&check_syntax);
- $answer_evaluator->install_pre_filter(\&math_constants);
- $answer_evaluator->install_pre_filter(\&cplx_constants);
- $answer_evaluator->install_pre_filter(\&check_for_polar);
- if ($mode eq 'std') {
- # do nothing
- } elsif ($mode eq 'strict_polar') {
- $answer_evaluator->install_pre_filter(\&is_a_polar);
- } elsif ($mode eq 'strict_num_cartesian') {
- $answer_evaluator->install_pre_filter(\&is_a_numeric_cartesian);
- } elsif ($mode eq 'strict_num_polar') {
- $answer_evaluator->install_pre_filter(\&is_a_numeric_polar);
- } elsif ($mode eq 'strict') {
- $answer_evaluator->install_pre_filter(\&is_a_numeric_complex);
- } elsif ($mode eq 'arith') {
- $answer_evaluator->install_pre_filter(\&is_an_arithmetic_expression);
- } elsif ($mode eq 'frac') {
- $answer_evaluator->install_pre_filter(\&is_a_fraction);
-
- } else {
- #$PGanswerMessage = 'Tell your professor that there is an error in his or her answer mechanism. No mode was specified.';
- }
- if ($corrAnswerIsString == 0 ){ # avoiding running compare_numbers when correct answer is a string.
- $answer_evaluator->install_evaluator(\&compare_cplx, %cplx_params);
- }
-
-
-###############################################################################
-# We'll leave these next lines out for now, so that the evaluated versions of the student's and professor's
-# can be displayed in the answer message. This may still cause a few anomolies when strings are used
-#
-###############################################################################
-
- $answer_evaluator->install_post_filter(\&fix_answers_for_display);
- $answer_evaluator->install_post_filter(\&fix_for_polar_display);
- $answer_evaluator->install_post_filter(sub {my $rh_ans = shift;
- return $rh_ans unless $rh_ans->catch_error('EVAL');
- $rh_ans->{student_ans} = $rh_ans->{original_student_ans}. ' '. $rh_ans->{error_message};
- $rh_ans->clear_error('EVAL'); } );
- $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('SYNTAX'); } );
- $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('POLAR'); } );
- $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('CARTESIAN'); } );
- $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('COMPLEX'); } );
- $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; warn "ans hash", $rh_ans->clear_error('STRING'); } );
- $answer_evaluator;
-}
-
+# this does not seem to be in use, so I'm commenting it out. Mike Gage 6/27/05
+# sub compare_cplx2 {
+# my ($rh_ans, %options) = @_;
+# my @answers = split/,/,$rh_ans->{student_ans};
+# foreach( @answers )
+# {
+# $rh_ans->{student_ans} = $_;
+# $rh_ans = &check_syntax( $rh_ans );
+# my ($inVal,$PG_eval_errors,$PG_full_error_report) = PG_answer_eval($rh_ans->{student_ans});
+#
+# if ($PG_eval_errors) {
+# $rh_ans->throw_error('EVAL','There is a syntax error in your answer');
+# $rh_ans->{ans_message} = clean_up_error_msg($PG_eval_errors);
+# # return $rh_ans;
+# } else {
+# $rh_ans->{student_ans} = prfmt($inVal,$options{format});
+# }
+#
+# $inVal = cplx($inVal,0) unless ref($inVal) =~/Complex/;
+# my $permitted_error_Re;
+# my $permitted_error_Im;
+# if ($rh_ans->{tolType} eq 'absolute') {
+# $permitted_error_Re = $rh_ans->{tolerance};
+# $permitted_error_Im = $rh_ans->{tolerance};
+# }
+# elsif ( abs($rh_ans->{correct_ans}) <= $options{zeroLevel}) {
+# $permitted_error_Re = $options{zeroLevelTol}; ## want $tol to be non zero
+# $permitted_error_Im = $options{zeroLevelTol}; ## want $tol to be non zero
+# }
+# else {
+# $permitted_error_Re = abs($rh_ans->{tolerance}*$rh_ans->{correct_ans}->Complex::Re);
+# $permitted_error_Im = abs($rh_ans->{tolerance}*$rh_ans->{correct_ans}->Complex::Im);
+#
+# }
+#
+# $rh_ans->{score} = 1 if ( abs( $rh_ans->{correct_ans}->Complex::Re - $inVal->Complex::Re) <=
+# $permitted_error_Re && abs($rh_ans->{correct_ans}->Complex::Im - $inVal->Complex::Im )<= $permitted_error_Im );
+# if( $rh_ans->{score} == 1 ){ return $rh_ans; }
+#
+#
+# }
+# $rh_ans;
+#
+# }
+
+# this does not seem to be in use, so I'm commenting it out. Mike Gage 6/27/05
+# sub cplx_cmp_mult {
+# my $correctAnswer = shift;
+# my %cplx_params = @_;
+# my @keys = qw ( correctAnswer tolerance tolType format mode zeroLevel zeroLevelTol debug );
+# assign_option_aliases( \%cplx_params,
+# 'reltol' => 'relTol',
+# );
+# set_default_options(\%cplx_params,
+# 'tolType' => (defined($cplx_params{tol}) ) ? 'absolute' : 'relative',
+# # default mode should be relative, to obtain this tol must not be defined
+# 'tolerance' => $main::numAbsTolDefault,
+# 'relTol' => $main::numRelPercentTolDefault,
+# 'zeroLevel' => $main::numZeroLevelDefault,
+# 'zeroLevelTol' => $main::numZeroLevelTolDefault,
+# 'format' => $main::numFormatDefault,
+# 'debug' => 0,
+# 'mode' => 'std',
+#
+# );
+# $correctAnswer = cplx($correctAnswer,0) unless ref($correctAnswer) =~/Complex/;
+# my $format = $cplx_params{'format'};
+# my $mode = $cplx_params{'mode'};
+#
+# if( $cplx_params{tolType} eq 'relative' ) {
+# $cplx_params{'tolerance'} = .01*$cplx_params{'relTol'};
+# }
+#
+# my $formattedCorrectAnswer;
+# my $correct_num_answer;
+# my $corrAnswerIsString = 0;
+#
+#
+# if (defined($cplx_params{strings}) && $cplx_params{strings}) {
+# my $legalString = '';
+# my @legalStrings = @{$cplx_params{strings}};
+# $correct_num_answer = $correctAnswer;
+# $formattedCorrectAnswer = $correctAnswer;
+# foreach $legalString (@legalStrings) {
+# if ( uc($correctAnswer) eq uc($legalString) ) {
+# $corrAnswerIsString = 1;
+#
+# last;
+# }
+# } ## at this point $corrAnswerIsString = 0 iff correct answer is numeric
+# } else {
+# $correct_num_answer = $correctAnswer;
+# $formattedCorrectAnswer = prfmt( $correctAnswer, $cplx_params{'format'} );
+# }
+# $correct_num_answer = math_constants($correct_num_answer);
+# my $PGanswerMessage = '';
+#
+# my ($inVal,$correctVal,$PG_eval_errors,$PG_full_error_report);
+#
+# if (defined($correct_num_answer) && $correct_num_answer =~ /\S/ && $corrAnswerIsString == 0 ) {
+# ($correctVal, $PG_eval_errors,$PG_full_error_report) = PG_answer_eval($correct_num_answer);
+# } else { # case of a string answer
+# $PG_eval_errors = ' ';
+# $correctVal = $correctAnswer;
+# }
+#
+# if ( ($PG_eval_errors && $corrAnswerIsString == 0) or ((not is_a_number($correctVal)) && $corrAnswerIsString == 0)) {
+# ##error message from eval or above
+# warn "Error in 'correct' answer: $PG_eval_errors<br>
+# The answer $correctAnswer evaluates to $correctVal,
+# which cannot be interpreted as a number. ";
+#
+# }
+# ########################################################################
+# $correctVal = $correct_num_answer;#it took me two and a half hours to figure out that correctVal wasn't
+# #getting the number properly
+# #construct the answer evaluator
+# my $counter = 0;
+# my $answer_evaluator = new AnswerEvaluator;
+#
+# my $number;
+# $answer_evaluator->install_pre_filter( sub{ my $rh_ans = shift; my @temp =
+# split/,/,$rh_ans->{student_ans}; $number = @temp; warn "this number ", $number; $rh_ans;});
+# warn "number ", $number;
+# while( $counter < 4 )
+# {
+# $answer_evaluator = &answer_mult( $correctVal, $mode, $formattedCorrectAnswer,
+# $corrAnswerIsString, $counter, %cplx_params );
+# warn "answer_evaluator ", $answer_evaluator;
+# $answer_evaluator->install_evaluator( sub { my $rh_ans = shift; warn "score ", $rh_ans->{score};
+# $rh_ans;});
+# $counter += 1;
+# }
+#
+# $answer_evaluator;
+#
+# }
+
+# this does not seem to be in use, so I'm commenting it out. Mike Gage 6/27/05
+# sub answer_mult{
+# my $correctVal = shift;
+# my $mode = shift;
+# my $formattedCorrectAnswer = shift;
+# my $corrAnswerIsString = shift;
+# my $counter = shift;
+# warn "counter ", $counter;
+#
+# my %cplx_params = @_;
+# my $answer_evaluator = new AnswerEvaluator;
+#
+#
+# $answer_evaluator->{debug} = $cplx_params{debug};
+# $answer_evaluator->ans_hash(
+# correct_ans => $correctVal,
+# type => "${mode}_number",
+# tolerance => $cplx_params{tolerance},
+# tolType => 'absolute', # $cplx_params{tolType},
+# original_correct_ans => $formattedCorrectAnswer,
+# answerIsString => $corrAnswerIsString,
+# answer_form => 'cartesian',
+# );
+# $answer_evaluator->install_pre_filter(sub {
+# my $rh_ans = shift;
+# $rh_ans->{original_student_ans} = $rh_ans->{student_ans};
+# my @answers = split/,/,$rh_ans->{student_ans};
+# $rh_ans -> {student_ans} = $answers[$counter];
+# $rh_ans;
+# }
+# );
+# if (defined($cplx_params{strings}) && $cplx_params{strings}) {
+# $answer_evaluator->install_pre_filter(\&check_strings, %cplx_params);
+# }
+# $answer_evaluator->install_pre_filter(\&check_syntax);
+# $answer_evaluator->install_pre_filter(\&math_constants);
+# $answer_evaluator->install_pre_filter(\&cplx_constants);
+# $answer_evaluator->install_pre_filter(\&check_for_polar);
+# if ($mode eq 'std') {
+# # do nothing
+# } elsif ($mode eq 'strict_polar') {
+# $answer_evaluator->install_pre_filter(\&is_a_polar);
+# } elsif ($mode eq 'strict_num_cartesian') {
+# $answer_evaluator->install_pre_filter(\&is_a_numeric_cartesian);
+# } elsif ($mode eq 'strict_num_polar') {
+# $answer_evaluator->install_pre_filter(\&is_a_numeric_polar);
+# } elsif ($mode eq 'strict') {
+# $answer_evaluator->install_pre_filter(\&is_a_numeric_complex);
+# } elsif ($mode eq 'arith') {
+# $answer_evaluator->install_pre_filter(\&is_an_arithmetic_expression);
+# } elsif ($mode eq 'frac') {
+# $answer_evaluator->install_pre_filter(\&is_a_fraction);
+#
+# } else {
+# #$PGanswerMessage = 'Tell your professor that there is an error in his or her answer mechanism. No mode was specified.';
+# }
+# if ($corrAnswerIsString == 0 ){ # avoiding running compare_numbers when correct answer is a string.
+# $answer_evaluator->install_evaluator(\&compare_cplx, %cplx_params);
+# }
+#
+#
+# ###############################################################################
+# # We'll leave these next lines out for now, so that the evaluated versions of the student's and professor's
+# # can be displayed in the answer message. This may still cause a few anomolies when strings are used
+# #
+# ###############################################################################
+#
+# $answer_evaluator->install_post_filter(\&fix_answers_for_display);
+# $answer_evaluator->install_post_filter(\&fix_for_polar_display);
+# $answer_evaluator->install_post_filter(sub {my $rh_ans = shift;
+# return $rh_ans unless $rh_ans->catch_error('EVAL');
+# $rh_ans->{student_ans} = $rh_ans->{original_student_ans}. ' '. $rh_ans->{error_message};
+# $rh_ans->clear_error('EVAL'); } );
+# $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('SYNTAX'); } );
+# $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('POLAR'); } );
+# $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('CARTESIAN'); } );
+# $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; $rh_ans->clear_error('COMPLEX'); } );
+# $answer_evaluator->install_post_filter(sub {my $rh_ans = shift; warn "ans hash", $rh_ans->clear_error('STRING'); } );
+# $answer_evaluator;
+# }
+#
1;
|
|
From: Sam H. v. a. <we...@ma...> - 2005-06-28 00:18:55
|
Log Message:
-----------
set closed message differentiates between sets that have not yet opened
and sets that used to be open. resolves bug #724.
Modified Files:
--------------
webwork2/lib/WeBWorK/ContentGenerator:
Problem.pm
Revision Data
-------------
Index: Problem.pm
===================================================================
RCS file: /webwork/cvs/system/webwork2/lib/WeBWorK/ContentGenerator/Problem.pm,v
retrieving revision 1.170
retrieving revision 1.171
diff -Llib/WeBWorK/ContentGenerator/Problem.pm -Llib/WeBWorK/ContentGenerator/Problem.pm -u -r1.170 -r1.171
--- lib/WeBWorK/ContentGenerator/Problem.pm
+++ lib/WeBWorK/ContentGenerator/Problem.pm
@@ -992,13 +992,21 @@
my $setClosedMessage;
if (before($set->open_date) or after($set->due_date)) {
$setClosed = 1;
- $setClosedMessage = "This problem set is closed.";
- if ($authz->hasPermissions($user, "view_answers")) {
- $setClosedMessage .= " However, since you are a privileged user, additional attempts will be recorded.";
- } else {
- $setClosedMessage .= " Additional attempts will not be recorded.";
+ if (before($set->open_date)) {
+ $setClosedMessage = "This problem set is not yet open.";
+ } elsif (after($set->due_date)) {
+ $setClosedMessage = "This problem set is closed.";
}
}
+ #if (before($set->open_date) or after($set->due_date)) {
+ # $setClosed = 1;
+ # $setClosedMessage = "This problem set is closed.";
+ # if ($authz->hasPermissions($user, "view_answers")) {
+ # $setClosedMessage .= " However, since you are a privileged user, additional attempts will be recorded.";
+ # } else {
+ # $setClosedMessage .= " Additional attempts will not be recorded.";
+ # }
+ #}
my $notCountedMessage = ($problem->value) ? "" : "(This problem will not count towards your grade.)";
print CGI::p(
|
|
From: Sam H. v. a. <we...@ma...> - 2005-06-28 00:17:12
|
Log Message:
-----------
fixed comment about port number to describe new >= 8000 numbering scheme
Modified Files:
--------------
webwork2/conf:
devel.apache-config.dist
Revision Data
-------------
Index: devel.apache-config.dist
===================================================================
RCS file: /webwork/cvs/system/webwork2/conf/devel.apache-config.dist,v
retrieving revision 1.6
retrieving revision 1.7
diff -Lconf/devel.apache-config.dist -Lconf/devel.apache-config.dist -u -r1.6 -r1.7
--- conf/devel.apache-config.dist
+++ conf/devel.apache-config.dist
@@ -58,8 +58,9 @@
$User = $user_name;
$Group = $group_name;
-# It will listen on a port equal to the UID of the user who starts it + 10000.
-$Port = $> + 7000; # effectively picks a port between 8000 and 8999 since uid's are 1000+
+# It will listen on a port equal to the UID of the user who starts it +7000.
+# This effectively picks a port between 8000 and 8999 since UID's are >=1000.
+$Port = $> + 7000;
# Email address of server administator.
$ServerAdmin = "$user_name\@$host_name";
|
|
From: Mike G. v. a. <we...@ma...> - 2005-06-27 00:09:20
|
Log Message:
-----------
Removed warning message about "users" . We closed the bug defining
multiple users awhile ago so we don't need this anymore. It's
causing trouble
with UserList.pm which now has fields
visible_users and prev_visible_users.
Modified Files:
--------------
webwork-modperl/lib/WeBWorK/ContentGenerator:
Login.pm
Revision Data
-------------
Index: Login.pm
===================================================================
RCS file: /webwork/cvs/system/webwork-modperl/lib/WeBWorK/ContentGenerator/Login.pm,v
retrieving revision 1.26
retrieving revision 1.27
diff -Llib/WeBWorK/ContentGenerator/Login.pm -Llib/WeBWorK/ContentGenerator/Login.pm -u -r1.26 -r1.27
--- lib/WeBWorK/ContentGenerator/Login.pm
+++ lib/WeBWorK/ContentGenerator/Login.pm
@@ -139,7 +139,11 @@
my @fields_to_print = grep { not m/^(user|passwd|key|force_passwd_authen)$/ } $r->param;
#FIXME: This next line can be removed in time. MEG 1/27/2005
- warn "Error in filtering fields : |", join("|",@fields_to_print),"|" if grep {m/user/} @fields_to_print;
+ # warn "Error in filtering fields : |", join("|",@fields_to_print),"|" if grep {m/user/} @fields_to_print;
+ # the above test was an attempt to discover why "user" was being multiply defined.
+ # We caught that error, but this warning causes trouble with UserList.pm which now has
+ # fields visible_users and prev_visible_users
+
# Important note. If hidden_fields is passed an empty array it prints ALL parameters as hidden fields.
# That is not what we want in this case, so we don't print at all if @fields_to_print is empty.
|
|
From: Mike G. v. a. <we...@ma...> - 2005-06-25 16:24:30
|
Log Message:
-----------
Fixed an incorrect error message when using the revert button.
Modified Files:
--------------
webwork-modperl/lib/WeBWorK/ContentGenerator/Instructor:
PGProblemEditor.pm
Revision Data
-------------
Index: PGProblemEditor.pm
===================================================================
RCS file: /webwork/cvs/system/webwork-modperl/lib/WeBWorK/ContentGenerator/Instructor/PGProblemEditor.pm,v
retrieving revision 1.53
retrieving revision 1.54
diff -Llib/WeBWorK/ContentGenerator/Instructor/PGProblemEditor.pm -Llib/WeBWorK/ContentGenerator/Instructor/PGProblemEditor.pm -u -r1.53 -r1.54
--- lib/WeBWorK/ContentGenerator/Instructor/PGProblemEditor.pm
+++ lib/WeBWorK/ContentGenerator/Instructor/PGProblemEditor.pm
@@ -296,7 +296,7 @@
# FIXME: even with an error we still open a new page because of the target specified in the form
- # Some cases do not need a redirect: revert, fresh_edit
+ # Some cases do not need a redirect: save, refresh, save_as, add_problem_to_set, add_header_to_set
my $action = $self->{action};
return unless $action eq 'save'
@@ -673,13 +673,6 @@
################################################################################
# Utilities
################################################################################
-
-# saveFileChanges does most of the work. it is a separate method so that it can
-# be called from either pre_header_initialize() or initilize(), depending on
-# whether a redirect is needed or not.
-#
-# it actually does a lot more than save changes to the file being edited, and
-# sometimes less.
sub getFilePaths {
my ($self, $setName, $problemNumber, $file_type, $TEMPFILESUFFIX) = @_;
my $r = $self->r;
@@ -823,6 +816,15 @@
$self->{inputFilePath} = (-r "$editFilePath.$TEMPFILESUFFIX") ? $tempFilePath : $editFilePath;
}
+
+################################################################################
+# saveFileChanges does most of the work. it is a separate method so that it can
+# be called from either pre_header_initialize() or initilize(), depending on
+# whether a redirect is needed or not.
+#
+# it actually does a lot more than save changes to the file being edited, and
+# sometimes less.
+################################################################################
sub saveFileChanges {
my ($self, $setName, $problemNumber, $file_type, $TEMPFILESUFFIX) = @_;
my $r = $self->r;
@@ -881,6 +883,7 @@
$outputFilePath = undef;
$self->addgoodmessage("Reverting to original file $editFilePath");
$self->{problemPath} = $editFilePath;
+ $self->{inputFilePath}=$editFilePath;
last ACTION_CASES;
};
|
|
From: Mike G. v. a. <we...@ma...> - 2005-06-24 20:14:04
|
Log Message:
-----------
Fixed conceptual error in compare_vec_solution. This should fix bug
#670. In my opinion the entire concept of vec_solution_cmp should be
reconsidered. In solving an underdetermined linear equation of the form
Ax-b=0 it seems to me that the solutions answer in the form:
x= a +bt+cu+ds where a,b,c,d are vectors should simply be evaluated
to see if it satisfies Ax-b=0 for 5 or six values of a,b,c,d --
checking the solution should use a
vector valued version of fun_cmp.
As it is, the student's coefficients for a,b,c,d are compared with the
instructors to see if they span the same space. This is quite a bit more
complicated -- and indeed the method came up with the wrong answer.
I believe I have the method corrected, but I would suggest that this
answer evaluator be replaced with one which operates more
directly and is therefore easier to maintain. Am I missing something in
this analysis? Has someone else created answer evaluators for this type
of problem?
-- Mike
Modified Files:
--------------
pg/macros:
PGmorematrixmacros.pl
Revision Data
-------------
Index: PGmorematrixmacros.pl
===================================================================
RCS file: /webwork/cvs/system/pg/macros/PGmorematrixmacros.pl,v
retrieving revision 1.17
retrieving revision 1.18
diff -Lmacros/PGmorematrixmacros.pl -Lmacros/PGmorematrixmacros.pl -u -r1.17 -r1.18
--- macros/PGmorematrixmacros.pl
+++ macros/PGmorematrixmacros.pl
@@ -1,5 +1,5 @@
BEGIN{
- be_strict();
+ be_strict();
}
sub _PGmorematrixmacros_init{}
@@ -31,24 +31,24 @@
=cut
sub random_diag_matrix{ ## Builds and returns a random diagonal \$n by \$n matrix
-
- warn "Usage: \$new_matrix = random_diag_matrix(\$n)" if (@_ != 1);
-
- my $D = new Matrix($_[0],$_[0]);
- my $norm = 0;
- while( $norm == 0 ){
- foreach my $i (1..$_[0]){
- foreach my $j (1..$_[0]){
- if( $i != $j ){
- $D->assign($i,$j,0);
- }else{
- $D->assign($i,$j,random(-9,9,1));
- }
- }
- }
- $norm = abs($D);
- }
- return $D;
+
+ warn "Usage: \$new_matrix = random_diag_matrix(\$n)" if (@_ != 1);
+
+ my $D = new Matrix($_[0],$_[0]);
+ my $norm = 0;
+ while( $norm == 0 ){
+ foreach my $i (1..$_[0]){
+ foreach my $j (1..$_[0]){
+ if( $i != $j ){
+ $D->assign($i,$j,0);
+ }else{
+ $D->assign($i,$j,random(-9,9,1));
+ }
+ }
+ }
+ $norm = abs($D);
+ }
+ return $D;
}
sub swap_rows{
@@ -112,62 +112,62 @@
ANS( basis_cmp( vectors_as_array_ref_in_array_ref, options_hash ) );
- 1. a reference to an array of correct vectors
- 2. a hash with the following keys (all optional):
- mode -- 'basis' (default) (only a basis allowed)
- 'orthogonal' (only an orthogonal basis is allowed)
- 'unit' (only unit vectors in the basis allowed)
- 'orthonormal' (only orthogonal unit vectors in basis allowed)
- zeroLevelTol -- absolute tolerance to allow when answer is close
- to zero
-
- debug -- if set to 1, provides verbose listing of
- hash entries throughout fliters.
-
- help -- 'none' (default) (is quiet on all errors)
- 'dim' (Tells student if wrong number of vectors are entered)
- 'length' (Tells student if there is a vector of the wrong length)
- 'orthogonal' (Tells student if their vectors are not orthogonal)
- (This is only in orthogonal mode)
- 'unit' (Tells student if there is a vector not of unit length)
- (This is only in unit mode)
- 'orthonormal' (Gives errors from orthogonal and orthonormal)
- (This is only in orthonormal mode)
- 'verbose' (Gives all the above answer messages)
+ 1. a reference to an array of correct vectors
+ 2. a hash with the following keys (all optional):
+ mode -- 'basis' (default) (only a basis allowed)
+ 'orthogonal' (only an orthogonal basis is allowed)
+ 'unit' (only unit vectors in the basis allowed)
+ 'orthonormal' (only orthogonal unit vectors in basis allowed)
+ zeroLevelTol -- absolute tolerance to allow when answer is close
+ to zero
+
+ debug -- if set to 1, provides verbose listing of
+ hash entries throughout fliters.
+
+ help -- 'none' (default) (is quiet on all errors)
+ 'dim' (Tells student if wrong number of vectors are entered)
+ 'length' (Tells student if there is a vector of the wrong length)
+ 'orthogonal' (Tells student if their vectors are not orthogonal)
+ (This is only in orthogonal mode)
+ 'unit' (Tells student if there is a vector not of unit length)
+ (This is only in unit mode)
+ 'orthonormal' (Gives errors from orthogonal and orthonormal)
+ (This is only in orthonormal mode)
+ 'verbose' (Gives all the above answer messages)
- Returns an answer evaluator.
+ Returns an answer evaluator.
EXAMPLES:
- basis_cmp([[1,0,0],[0,1,0],[0,0,1]])
- -- correct answer is any basis for R^3.
- basis_cmp([1,0,2,0],[0,1,0,0], 'mode'=>orthonormal )
- -- correct answer is any orthonormal basis
- for this space such as:
- [1/sqrt(3),0,2/sqrt(3),0],[0,1,0,0]
+ basis_cmp([[1,0,0],[0,1,0],[0,0,1]])
+ -- correct answer is any basis for R^3.
+ basis_cmp([1,0,2,0],[0,1,0,0], 'mode'=>orthonormal )
+ -- correct answer is any orthonormal basis
+ for this space such as:
+ [1/sqrt(3),0,2/sqrt(3),0],[0,1,0,0]
=cut
sub basis_cmp {
- my $correctAnswer = shift;
- my %opt = @_;
+ my $correctAnswer = shift;
+ my %opt = @_;
- set_default_options( \%opt,
- 'zeroLevelTol' => $main::functZeroLevelTolDefault,
- 'debug' => 0,
- 'mode' => 'basis',
- 'help' => 'none',
- );
-
- # produce answer evaluator
- BASIS_CMP(
- 'correct_ans' => $correctAnswer,
- 'zeroLevelTol' => $opt{'zeroLevelTol'},
- 'debug' => $opt{'debug'},
- 'mode' => $opt{'mode'},
- 'help' => $opt{'help'},
- );
+ set_default_options( \%opt,
+ 'zeroLevelTol' => $main::functZeroLevelTolDefault,
+ 'debug' => 0,
+ 'mode' => 'basis',
+ 'help' => 'none',
+ );
+
+ # produce answer evaluator
+ BASIS_CMP(
+ 'correct_ans' => $correctAnswer,
+ 'zeroLevelTol' => $opt{'zeroLevelTol'},
+ 'debug' => $opt{'debug'},
+ 'mode' => $opt{'mode'},
+ 'help' => $opt{'help'},
+ );
}
=head BASIS_CMP
@@ -177,193 +177,199 @@
=cut
sub BASIS_CMP {
- my %mat_params = @_;
- my $zeroLevelTol = $mat_params{'zeroLevelTol'};
-
- # Check that everything is defined:
- $mat_params{debug} = 0 unless defined($mat_params{debug});
- $zeroLevelTol = $main::functZeroLevelTolDefault unless defined $zeroLevelTol;
- $mat_params{'zeroLevelTol'} = $zeroLevelTol;
+ my %mat_params = @_;
+ my $zeroLevelTol = $mat_params{'zeroLevelTol'};
+
+ # Check that everything is defined:
+ $mat_params{debug} = 0 unless defined($mat_params{debug});
+ $zeroLevelTol = $main::functZeroLevelTolDefault unless defined $zeroLevelTol;
+ $mat_params{'zeroLevelTol'} = $zeroLevelTol;
## This is where the correct answer should be checked someday.
- my $matrix = Matrix->new_from_col_vecs($mat_params{'correct_ans'});
+ my $matrix = Matrix->new_from_col_vecs($mat_params{'correct_ans'});
#construct the answer evaluator
- my $answer_evaluator = new AnswerEvaluator;
+ my $answer_evaluator = new AnswerEvaluator;
$answer_evaluator->{debug} = $mat_params{debug};
- $answer_evaluator->ans_hash(
- correct_ans => display_correct_vecs($mat_params{correct_ans}),
- rm_correct_ans => $matrix,
- zeroLevelTol => $mat_params{zeroLevelTol},
- debug => $mat_params{debug},
- mode => $mat_params{mode},
- help => $mat_params{help},
+ $answer_evaluator->ans_hash(
+ correct_ans => display_correct_vecs($mat_params{correct_ans}),
+ rm_correct_ans => $matrix,
+ zeroLevelTol => $mat_params{zeroLevelTol},
+ debug => $mat_params{debug},
+ mode => $mat_params{mode},
+ help => $mat_params{help},
);
- $answer_evaluator->install_pre_filter(
- sub {my $rh_ans = shift;
- $rh_ans->{_filter_name} = 'remove_white_space';
- $rh_ans->{student_ans} =~ s/\s+//g; # remove all whitespace
- $rh_ans;
- }
- );
- $answer_evaluator->install_pre_filter(
- sub{my $rh_ans = shift;
- my @options = @_;
- $rh_ans->{_filter_name} = 'mung_student_answer';
- if( $rh_ans->{ans_label} =~ /ArRaY/ ){
- $rh_ans = ans_array_filter($rh_ans,@options);
- my @student_array = @{$rh_ans->{ra_student_ans}};
- my @array = ();
- for( my $i = 0; $i < scalar(@student_array) ; $i ++ )
- {
- push( @array, Matrix->new_from_array_ref($student_array[$i]));
- }
- $rh_ans->{ra_student_ans} = \@array;
- $rh_ans;
- }else{
- $rh_ans->{student_ans} = math_constants($rh_ans->{student_ans});
- vec_list_string($rh_ans, '_filter_name' => 'vec_list_string', @options);
- }
- }
- );#ra_student_ans is now the students answer as an array of vectors
- # anonymous subroutine to check dimension and length of the student vectors
- # if either is wrong, the answer is wrong.
- $answer_evaluator->install_pre_filter(
- sub{
- my $rh_ans = shift;
- $rh_ans->{_filter_name} = 'check_vector_size';
- my $length = $rh_ans->{rm_correct_ans}->[1];
- my $dim = $rh_ans->{rm_correct_ans}->[2];
- if( $dim != scalar(@{$rh_ans->{ra_student_ans}}))
- {
-
- $rh_ans->{score} = 0;
- if( $rh_ans->{help} =~ /dim|verbose/ )
- {
- $rh_ans->throw_error('EVAL','You have entered the wrong number of vectors.');
- }else{
- $rh_ans->throw_error('EVAL');
- }
- }
- for( my $i = 0; $i < scalar( @{$rh_ans->{ra_student_ans} }) ; $i++ )
- {
- if( $length != $rh_ans->{ra_student_ans}->[$i]->[1])
- {
- $rh_ans->{score} = 0;
- if( $rh_ans->{help} =~ /length|verbose/ )
- {
- $rh_ans->throw_error('EVAL','You have entered vector(s) of the wrong length.');
- }else{
- $rh_ans->throw_error('EVAL');
- }
- }
- }
- $rh_ans;
- }
- );
- # Install prefilter for various modes
- if( $mat_params{mode} ne 'basis' )
- {
- if( $mat_params{mode} =~ /orthogonal|orthonormal/ )
- {
- $answer_evaluator->install_pre_filter(\&are_orthogonal_vecs);
- }
-
- if( $mat_params{mode} =~ /unit|orthonormal/ )
- {
- $answer_evaluator->install_pre_filter(\&are_unit_vecs);
-
- }
- }
- $answer_evaluator->install_evaluator(\&compare_basis, %mat_params);
- $answer_evaluator->install_post_filter(
- sub {my $rh_ans = shift;
- if ($rh_ans->catch_error('SYNTAX') ) {
- $rh_ans->{ans_message} = $rh_ans->{error_message};
- $rh_ans->clear_error('SYNTAX');
- }
- if ($rh_ans->catch_error('EVAL') ) {
- $rh_ans->{ans_message} = $rh_ans->{error_message};
- $rh_ans->clear_error('EVAL');
- }
- $rh_ans;
- }
- );
- $answer_evaluator;
+ $answer_evaluator->install_pre_filter(
+ sub {my $rh_ans = shift;
+ $rh_ans->{_filter_name} = 'remove_white_space';
+ $rh_ans->{student_ans} =~ s/\s+//g; # remove all whitespace
+ $rh_ans;
+ }
+ );
+ $answer_evaluator->install_pre_filter(
+ sub{my $rh_ans = shift;
+ my @options = @_;
+ $rh_ans->{_filter_name} = 'mung_student_answer';
+ if( $rh_ans->{ans_label} =~ /ArRaY/ ){
+ $rh_ans = ans_array_filter($rh_ans,@options);
+ my @student_array = @{$rh_ans->{ra_student_ans}};
+ my @array = ();
+ for( my $i = 0; $i < scalar(@student_array) ; $i ++ )
+ {
+ push( @array, Matrix->new_from_array_ref($student_array[$i]));
+ }
+ $rh_ans->{ra_student_ans} = \@array;
+ $rh_ans;
+ }else{
+ $rh_ans->{student_ans} = math_constants($rh_ans->{student_ans});
+ vec_list_string($rh_ans, '_filter_name' => 'vec_list_string', @options);
+ }
+ }
+ );#ra_student_ans is now the students answer as an array of vectors
+ # anonymous subroutine to check dimension and length of the student vectors
+ # if either is wrong, the answer is wrong.
+ $answer_evaluator->install_pre_filter(
+ sub{
+ my $rh_ans = shift;
+ $rh_ans->{_filter_name} = 'check_vector_size';
+ my $length = $rh_ans->{rm_correct_ans}->[1];
+ my $dim = $rh_ans->{rm_correct_ans}->[2];
+ if( $dim != scalar(@{$rh_ans->{ra_student_ans}}))
+ {
+
+ $rh_ans->{score} = 0;
+ if( $rh_ans->{help} =~ /dim|verbose/ )
+ {
+ $rh_ans->throw_error('EVAL','You have entered the wrong number of vectors.');
+ }else{
+ $rh_ans->throw_error('EVAL');
+ }
+ }
+ for( my $i = 0; $i < scalar( @{$rh_ans->{ra_student_ans} }) ; $i++ )
+ {
+ if( $length != $rh_ans->{ra_student_ans}->[$i]->[1])
+ {
+ $rh_ans->{score} = 0;
+ if( $rh_ans->{help} =~ /length|verbose/ )
+ {
+ $rh_ans->throw_error('EVAL','You have entered vector(s) of the wrong length.');
+ }else{
+ $rh_ans->throw_error('EVAL');
+ }
+ }
+ }
+ $rh_ans;
+ }
+ );
+ # Install prefilter for various modes
+ if( $mat_params{mode} ne 'basis' )
+ {
+ if( $mat_params{mode} =~ /orthogonal|orthonormal/ )
+ {
+ $answer_evaluator->install_pre_filter(\&are_orthogonal_vecs);
+ }
+
+ if( $mat_params{mode} =~ /unit|orthonormal/ )
+ {
+ $answer_evaluator->install_pre_filter(\&are_unit_vecs);
+
+ }
+ }
+ $answer_evaluator->install_evaluator(\&compare_basis, %mat_params);
+ $answer_evaluator->install_post_filter(
+ sub {my $rh_ans = shift;
+ if ($rh_ans->catch_error('SYNTAX') ) {
+ $rh_ans->{ans_message} = $rh_ans->{error_message};
+ $rh_ans->clear_error('SYNTAX');
+ }
+ if ($rh_ans->catch_error('EVAL') ) {
+ $rh_ans->{ans_message} = $rh_ans->{error_message};
+ $rh_ans->clear_error('EVAL');
+ }
+ $rh_ans;
+ }
+ );
+ $answer_evaluator;
}
=head4 compare_basis
- compare_basis( $ans_hash, %options);
+ compare_basis( $ans_hash,
+ %options
+ ra_student_ans # a reference to the array of students answer vectors
+ rm_correct_ans, # a reference to the correct answer matrix
+ %options
+ )
- {ra_student_ans}, # a reference to the array of students answer vectors
- {rm_correct_ans}, # a reference to the correct answer matrix
- %options
- )
=cut
+
+
sub compare_basis {
- my ($rh_ans, %options) = @_;
- my @ch_coord;
- my @vecs = @{$rh_ans->{ra_student_ans}};
-
- # A lot of the follosing code was taken from Matrix::proj_coeff
- # calling this method recursively would be a waste of time since
- # the prof's matrix never changes and solve_LR is an expensive
- # operation. This way it is only done once.
- my $matrix = $rh_ans->{rm_correct_ans};
- my ($dim,$x_vector, $base_matrix);
- my $errors = undef;
- my $lin_space_tr= ~ $matrix;
- $matrix = $lin_space_tr * $matrix;
- my $matrix_lr = $matrix->decompose_LR();
-
- #finds the coefficient vectors for each of the students vectors
- for( my $i = 0; $i < scalar(@{$rh_ans->{ra_student_ans}}) ; $i++ )
- {
-
- $vecs[$i] = $lin_space_tr*$vecs[$i];
- ($dim,$x_vector, $base_matrix) = $matrix_lr->solve_LR($vecs[$i]);
- push( @ch_coord, $x_vector );
- $errors = "A unique adapted answer could not be determined. Possibly the parameters have coefficient zero.<br> dim = $dim base_matrix is $base_matrix\n" if $dim; # only print if the dim is not zero.
- }
-
- if( defined($errors))
- {
- $rh_ans->throw_error('EVAL', $errors) ;
- }else{
- my $ch_coord_mat = Matrix->new_from_col_vecs(\@ch_coord);#creates change of coordinate matrix
- #existence of this matrix implies that
- #the all of the students answers are a
- #linear combo of the prof's
- $ch_coord_mat = $ch_coord_mat->decompose_LR();
-
- if( abs($ch_coord_mat->det_LR()) > $options{zeroLevelTol} )# if the det of the change of coordinate matrix is
- # non-zero, this implies the existence of an inverse
- # which implies all of the prof's vectors are a linear
- # combo of the students vectors, showing containment
- # both ways.
- {
- # I think sometimes if the students space has the same dimension as the profs space it
- # will get projected into the profs space even if it isn't a basis for that space.
- # this just checks that the prof's matrix times the change of coordinate matrix is actually
- #the students matrix
- if( abs(Matrix->new_from_col_vecs(\@{$rh_ans->{ra_student_ans}}) - ($rh_ans->{rm_correct_ans})*(Matrix->new_from_col_vecs(\@ch_coord))) < $options{zeroLevelTol} )
- {
- $rh_ans->{score} = 1;
- }else{
- $rh_ans->{score} = 0;
- }
- }
- else{
- $rh_ans->{score}=0;
- }
- }
- $rh_ans;
-
+ my ($rh_ans, %options) = @_;
+ $rh_ans->{_filter_name} = "compare_basis";
+ my @ch_coord;
+ my @vecs = @{$rh_ans->{ra_student_ans}};
+
+ # A lot of the following code was taken from Matrix::proj_coeff
+ # calling this method recursively would be a waste of time since
+ # the prof's matrix never changes and solve_LR is an expensive
+ # operation. This way it is only done once.
+ my $matrix = $rh_ans->{rm_correct_ans};
+ my ($dim,$x_vector, $base_matrix);
+ my $errors = undef;
+ my $lin_space_tr= ~ $matrix; #transpose of the matrix
+ $matrix = $lin_space_tr * $matrix; #(~A * A)
+ my $matrix_lr = $matrix->decompose_LR();
+
+ #finds the coefficient vectors for each of the students vectors
+ for( my $i = 0; $i < scalar(@{$rh_ans->{ra_student_ans}}) ; $i++ ) {
+
+ $vecs[$i] = $lin_space_tr*$vecs[$i];
+ ($dim,$x_vector, $base_matrix) = $matrix_lr->solve_LR($vecs[$i]);
+ push( @ch_coord, $x_vector );
+ $errors = "A unique adapted answer could not be determined.
+ Possibly the parameters have coefficient zero.<br> dim = $dim base_matrix
+ is $base_matrix\n" if $dim; # only print if the dim is not zero.
+ }
+
+ if( defined($errors)) {
+ $rh_ans->throw_error('EVAL', $errors) ;
+ } else {
+ my $ch_coord_mat = Matrix->new_from_col_vecs(\@ch_coord);
+ #creates change of coordinate matrix
+ #existence of this matrix implies that
+ #the all of the students answers are a
+ #linear combo of the prof's
+ $ch_coord_mat = $ch_coord_mat->decompose_LR();
+
+ if( abs($ch_coord_mat->det_LR()) > $options{zeroLevelTol} ) {
+ # if the det of the change of coordinate matrix is
+ # non-zero, this implies the existence of an inverse
+ # which implies all of the prof's vectors are a linear
+ # combo of the students vectors, showing containment
+ # both ways.
+
+ # I think sometimes if the students space has the same dimension as the profs space it
+ # will get projected into the profs space even if it isn't a basis for that space.
+ # this just checks that the prof's matrix times the change of coordinate matrix is actually
+ #the students matrix
+ if( abs(Matrix->new_from_col_vecs(\@{$rh_ans->{ra_student_ans}}) -
+ ($rh_ans->{rm_correct_ans})*(Matrix->new_from_col_vecs(\@ch_coord)))
+ < $options{zeroLevelTol} ) {
+ $rh_ans->{score} = 1;
+ } else {
+ $rh_ans->{score} = 0;
+ }
+ } else {
+ $rh_ans->{score}=0;
+ }
+ }
+ $rh_ans;
+
}
@@ -378,568 +384,565 @@
but a unmatched close parenthesis ends the vector, and since everything outside is ignored, no error is sent (other than the
later when the length of the vectors is checked.
In the end, the method returns an array of Matrix objects.
-
+
=cut
sub vec_list_string{
- my $rh_ans = shift;
- my %options = @_;
- my $i;
- my $entry = "";
- my $char;
- my @paren_stack;
- my $length = length($rh_ans->{student_ans});
- my @temp;
- my $j = 0;
- my @answers;
- my $paren;
- my $display_ans;
-
- for( $i = 0; $i < $length ; $i++ )
- {
- $char = substr($rh_ans->{student_ans},$i,1);
-
- if( $char =~ /\(|\[|\{/ ){
- push( @paren_stack, $char )
- }
-
- if( !( $char =~ /\(|\[|\{/ && scalar(@paren_stack) == 1 ) )
- {
- if( $char !~ /,|\)|\]|\}/ ){
- $entry .= $char;
- }else{
- if( $char =~ /,/ || ( $char =~ /\)|\]|\}/ && scalar(@paren_stack) == 1 ) )
- {
- if( length($entry) == 0 ){
- if( $char !~ /,/ ){
- $rh_ans->throw_error('EVAL','There is a syntax error in your answer');
- }else{
- $rh_ans->{preview_text_string} .= ",";
- $rh_ans->{preview_latex_string} .= ",";
- $display_ans .= ",";
- }
- }else{
-
- # This parser code was origianally taken from PGanswermacros::check_syntax
- # but parts of it needed to be slighty modified for this context
- my $parser = new AlgParserWithImplicitExpand;
- my $ret = $parser -> parse($entry); #for use with loops
-
- if ( ref($ret) ) { ## parsed successfully
- $parser -> tostring();
- $parser -> normalize();
- $entry = $parser -> tostring();
- $rh_ans->{preview_text_string} .= $entry.",";
- $rh_ans->{preview_latex_string} .= $parser -> tolatex().",";
-
- } else { ## error in parsing
-
- $rh_ans->{'student_ans'} = 'syntax error:'.$display_ans. $parser->{htmlerror},
- $rh_ans->{'ans_message'} = $display_ans.$parser -> {error_msg},
- $rh_ans->{'preview_text_string'} = '',
- $rh_ans->{'preview_latex_string'} = '',
- $rh_ans->throw_error('SYNTAX', 'syntax error in answer:'.$display_ans.$parser->{htmlerror} . "$main::BR" .$parser -> {error_msg}.".$main::BR");
- }
-
- my ($inVal,$PG_eval_errors,$PG_full_error_report) = PG_answer_eval($entry);
-
- if ($PG_eval_errors) {
- $rh_ans->throw_error('EVAL','There is a syntax error in your answer.') ;
- $rh_ans->{ans_message} = clean_up_error_msg($PG_eval_errors);
- last;
- } else {
- $entry = prfmt($inVal,$options{format});
- $display_ans .= $entry.",";
- push(@temp , $entry);
- }
-
- if( $char =~ /\)|\]|\}/ && scalar(@paren_stack) == 1)
- {
- pop @paren_stack;
- chop($rh_ans->{preview_text_string});
- chop($rh_ans->{preview_latex_string});
- chop($display_ans);
- $rh_ans->{preview_text_string} .= "]";
- $rh_ans->{preview_latex_string} .= "]";
- $display_ans .= "]";
- if( scalar(@temp) > 0 )
- {
- push( @answers,Matrix->new_from_col_vecs([\@temp]));
- while(scalar(@temp) > 0 ){
- pop @temp;
- }
- }else{
- $rh_ans->throw_error('EVAL','There is a syntax error in your answer.');
- }
- }
- }
- $entry = "";
- }else{
- $paren = pop @paren_stack;
- if( scalar(@paren_stack) > 0 ){
- #this uses ASCII to check if the parens match up
- # in ASCII ord ( = 40 , ord ) = 41 , ord [ = 91 ,
- # ord ] = 93 , ord { = 123 , ord } = 125
- if( (ord($char) - ord($paren) <= 2) ){
- $entry = $entry . $char;
- }else{
- $rh_ans->throw_error('EVAL','There is a syntax error in your answer');
- }
- }
- }
- }
- }else{
- $rh_ans->{preview_text_string} .= "[";
- $rh_ans->{preview_latex_string} .= "[";
- $display_ans .= "[";
- }
- }
- $rh_ans->{ra_student_ans} = \@answers;
- $rh_ans->{student_ans} = $display_ans unless $rh_ans->{error_flag};
- $rh_ans;
+ my $rh_ans = shift;
+ my %options = @_;
+ my $i;
+ my $entry = "";
+ my $char;
+ my @paren_stack;
+ my $length = length($rh_ans->{student_ans});
+ my @temp;
+ my $j = 0;
+ my @answers;
+ my $paren;
+ my $display_ans;
+
+ for( $i = 0; $i < $length ; $i++ ) {
+ $char = substr($rh_ans->{student_ans},$i,1);
+
+ if( $char =~ /\(|\[|\{/ ){
+ push( @paren_stack, $char )
+ }
+
+ if( !( $char =~ /\(|\[|\{/ && scalar(@paren_stack) == 1 ) ) {
+ if( $char !~ /,|\)|\]|\}/ ){
+ $entry .= $char;
+ } else {
+ if( $char =~ /,/ || ( $char =~ /\)|\]|\}/ && scalar(@paren_stack) == 1 ) ) {
+ if( length($entry) == 0 ){
+ if( $char !~ /,/ ){
+ $rh_ans->throw_error('EVAL','There is a syntax error in your answer');
+ } else {
+ $rh_ans->{preview_text_string} .= ",";
+ $rh_ans->{preview_latex_string} .= ",";
+ $display_ans .= ",";
+ }
+ } else {
+
+ # This parser code was origianally taken from PGanswermacros::check_syntax
+ # but parts of it needed to be slighty modified for this context
+ my $parser = new AlgParserWithImplicitExpand;
+ my $ret = $parser -> parse($entry); #for use with loops
+
+ if ( ref($ret) ) { ## parsed successfully
+ $parser -> tostring();
+ $parser -> normalize();
+ $entry = $parser -> tostring();
+ $rh_ans->{preview_text_string} .= $entry.",";
+ $rh_ans->{preview_latex_string} .= $parser -> tolatex().",";
+
+ } else { ## error in parsing
+
+ $rh_ans->{'student_ans'} = 'syntax error:'.$display_ans. $parser->{htmlerror},
+ $rh_ans->{'ans_message'} = $display_ans.$parser -> {error_msg},
+ $rh_ans->{'preview_text_string'} = '',
+ $rh_ans->{'preview_latex_string'} = '',
+ $rh_ans->throw_error('SYNTAX', 'syntax error in answer:'.$display_ans.$parser->{htmlerror} . "$main::BR" .$parser -> {error_msg}.".$main::BR");
+ }
+
+ my ($inVal,$PG_eval_errors,$PG_full_error_report) = PG_answer_eval($entry);
+
+ if ($PG_eval_errors) {
+ $rh_ans->throw_error('EVAL','There is a syntax error in your answer.') ;
+ $rh_ans->{ans_message} = clean_up_error_msg($PG_eval_errors);
+ last;
+ } else {
+ $entry = prfmt($inVal,$options{format});
+ $display_ans .= $entry.",";
+ push(@temp , $entry);
+ }
+
+ if( $char =~ /\)|\]|\}/ && scalar(@paren_stack) == 1) {
+ pop @paren_stack;
+ chop($rh_ans->{preview_text_string});
+ chop($rh_ans->{preview_latex_string});
+ chop($display_ans);
+ $rh_ans->{preview_text_string} .= "]";
+ $rh_ans->{preview_latex_string} .= "]";
+ $display_ans .= "]";
+ if( scalar(@temp) > 0 ) {
+ push( @answers,Matrix->new_from_col_vecs([\@temp]));
+ while(scalar(@temp) > 0 ){
+ pop @temp;
+ }
+ } else {
+ $rh_ans->throw_error('EVAL','There is a syntax error in your answer.');
+ }
+ }
+ }
+ $entry = "";
+ } else {
+ $paren = pop @paren_stack;
+ if( scalar(@paren_stack) > 0 ){
+ #this uses ASCII to check if the parens match up
+ # in ASCII ord ( = 40 , ord ) = 41 , ord [ = 91 ,
+ # ord ] = 93 , ord { = 123 , ord } = 125
+ if( (ord($char) - ord($paren) <= 2) ){
+ $entry = $entry . $char;
+ }else{
+ $rh_ans->throw_error('EVAL','There is a syntax error in your answer');
+ }
+ }
+ }
+ }
+ } else {
+ $rh_ans->{preview_text_string} .= "[";
+ $rh_ans->{preview_latex_string} .= "[";
+ $display_ans .= "[";
+ }
+ }
+ $rh_ans->{ra_student_ans} = \@answers;
+ $rh_ans->{student_ans} = $display_ans unless $rh_ans->{error_flag};
+ $rh_ans;
}
=head5
- This filter was created to get, format, and evaluate each entry of the ans_array and ans_array_extension
- answer entry methods. Running this filter is necessary to get all the entries out of the answer
- hash. Each entry is evaluated and the resulting number is put in the display for student answer
- as a string. For evaluation purposes an array of arrays of arrays is created called ra_student_ans
- and placed in the hash. The entries are [array_number][row_number][column_number]. The latex strings
- for each entry are taken from the parser and put, as a matrix, into the previewer. The preview text
- string is also created, but this display method becomes confusing when large matrices are used.
+
+ This filter was created to get, format, and evaluate each entry of the ans_array and ans_array_extension
+ answer entry methods. Running this filter is necessary to get all the entries out of the answer
+ hash. Each entry is evaluated and the resulting number is put in the display for student answer
+ as a string. For evaluation purposes an array of arrays of arrays is created called ra_student_ans
+ and placed in the hash. The entries are [array_number][row_number][column_number]. The latex strings
+ for each entry are taken from the parser and put, as a matrix, into the previewer. The preview text
+ string is also created, but this display method becomes confusing when large matrices are used.
+
=cut
sub ans_array_filter{
- my $rh_ans = shift;
- my %options = @_;
-# assign_option_aliases( \%opt,
+ my $rh_ans = shift;
+ my %options = @_;
+# assign_option_aliases( \%opt,
# );
- set_default_options(\%options,
- '_filter_name' => 'ans_array_filter',
- );
-# $rh_ans->{ans_label} =~ /ArRaY(\d+)\[\d+,\d+,\d+\]/; # CHANGE made to accomodate HTML 4.01 standards for name attribute
- $rh_ans->{ans_label} =~ /ArRaY(\d+)\_\_\d+:\d+:\d+\_\_/;
- my $ans_num = $1;
- my @keys = grep /ArRaY$ans_num/, keys(%{$main::inputs_ref});
- my $key;
- my @array = ();
- my ($i,$j,$k) = (0,0,0);
-
- #the keys aren't in order, so their info has to be put into the array before doing anything with it
- foreach $key (@keys){
-# $key =~ /ArRaY\d+\[(\d+),(\d+),(\d+)\]/;
-# ($i,$j,$k) = ($1,$2,$3);
-# $array[$i][$j][$k] = ${$main::inputs_ref}{'ArRaY'.$ans_num.'['.$i.','.$j.','.$k.']'};
- $key =~ /ArRaY\d+\_\_(\d+):(\d+):(\d+)\_\_/;
- ($i,$j,$k) = ($1,$2,$3);
- $array[$i][$j][$k] = ${$main::inputs_ref}{'ArRaY'.$ans_num.'__'.$i.':'.$j.':'.$k.'__'};
-
- }
- $rh_ans->{debug_student_answer }= \@array;
- my $display_ans = "";
-
- for( $i=0; $i < scalar(@array) ; $i ++ )
- {
- $display_ans .= " [";
- $rh_ans->{preview_text_string} .= ' [';
- $rh_ans->{preview_latex_string} .= '\begin{pmatrix} ';
- for( $j = 0; $j < scalar( @{$array[$i]} ) ; $j++ )
- {
- $display_ans .= " [";
- $rh_ans->{preview_text_string} .= ' [';
- for( $k = 0; $k < scalar( @{$array[$i][$j]} ) ; $k ++ ){
- my $entry = $array[$i][$j][$k];
- $entry = math_constants($entry);
- # This parser code was origianally taken from PGanswermacros::check_syntax
- # but parts of it needed to be slighty modified for this context
- my $parser = new AlgParserWithImplicitExpand;
- my $ret = $parser -> parse($entry); #for use with loops
-
- if ( ref($ret) ) { ## parsed successfully
- $parser -> tostring();
- $parser -> normalize();
- $entry = $parser -> tostring();
- $rh_ans->{preview_text_string} .= $entry.",";
- $rh_ans->{preview_latex_string} .= $parser -> tolatex() . '& ';
-
- } else { ## error in parsing
- $rh_ans->{'student_ans'} = 'syntax error:'.$display_ans. $parser->{htmlerror},
- $rh_ans->{'ans_message'} = $display_ans.$parser -> {error_msg},
- $rh_ans->{'preview_text_string'} = '',
- $rh_ans->throw_error('SYNTAX', 'syntax error in answer:'.$display_ans.$parser->{htmlerror} . "$main::BR" .$parser -> {error_msg}.".$main::BR");
- }
-
- my ($inVal,$PG_eval_errors,$PG_full_error_report) = PG_answer_eval($entry);
- if ($PG_eval_errors) {
- $rh_ans->throw_error('EVAL','There is a syntax error in your answer.') ;
- $rh_ans->{ans_message} = clean_up_error_msg($PG_eval_errors);
- last;
- } else {
- $entry = prfmt($inVal,$options{format});
- $display_ans .= $entry.",";
- $array[$i][$j][$k] = $entry;
- }
- }
- chop($rh_ans->{preview_text_string});
- chop($display_ans);
- $rh_ans->{preview_text_string} .= '] ,';
- $rh_ans->{preview_latex_string} .= '\\\\';
- $display_ans .= '] ,';
-
- }
- chop($rh_ans->{preview_text_string});
- chop($display_ans);
+ set_default_options(\%options,
+ _filter_name => 'ans_array_filter',
+ );
+# $rh_ans->{ans_label} =~ /ArRaY(\d+)\[\d+,\d+,\d+\]/; # CHANGE made to accomodate HTML 4.01 standards for name attribute
+ $rh_ans->{ans_label} =~ /ArRaY(\d+)\_\_\d+:\d+:\d+\_\_/;
+ my $ans_num = $1;
+ my @keys = grep /ArRaY$ans_num/, keys(%{$main::inputs_ref});
+ my $key;
+ my @array = ();
+ my ($i,$j,$k) = (0,0,0);
+
+ #the keys aren't in order, so their info has to be put into the array before doing anything with it
+ foreach $key (@keys){
+# $key =~ /ArRaY\d+\[(\d+),(\d+),(\d+)\]/;
+# ($i,$j,$k) = ($1,$2,$3);
+# $array[$i][$j][$k] = ${$main::inputs_ref}{'ArRaY'.$ans_num.'['.$i.','.$j.','.$k.']'};
+ $key =~ /ArRaY\d+\_\_(\d+):(\d+):(\d+)\_\_/;
+ ($i,$j,$k) = ($1,$2,$3);
+ $array[$i][$j][$k] = ${$main::inputs_ref}{'ArRaY'.$ans_num.'__'.$i.':'.$j.':'.$k.'__'};
+
+ }
+ #$rh_ans->{debug_student_answer }= \@array;
+ my $display_ans = "";
+
+ for( $i=0; $i < scalar(@array) ; $i ++ ) {
+ $display_ans .= " [";
+ $rh_ans->{preview_text_string} .= ' [';
+ $rh_ans->{preview_latex_string} .= '\begin{pmatrix} ';
+ for( $j = 0; $j < scalar( @{$array[$i]} ) ; $j++ ) {
+ $display_ans .= " [";
+ $rh_ans->{preview_text_string} .= ' [';
+ for( $k = 0; $k < scalar( @{$array[$i][$j]} ) ; $k ++ ){
+ my $entry = $array[$i][$j][$k];
+ $entry = math_constants($entry);
+ # This parser code was origianally taken from PGanswermacros::check_syntax
+ # but parts of it needed to be slighty modified for this context
+ my $parser = new AlgParserWithImplicitExpand;
+ my $ret = $parser -> parse($entry); #for use with loops
+
+ if ( ref($ret) ) { ## parsed successfully
+ $parser -> tostring();
+ $parser -> normalize();
+ $entry = $parser -> tostring();
+ $rh_ans->{preview_text_string} .= $entry.",";
+ $rh_ans->{preview_latex_string} .= $parser -> tolatex() . '& ';
+
+ } else { ## error in parsing
+ $rh_ans->{'student_ans'} = 'syntax error:'.$display_ans. $parser->{htmlerror},
+ $rh_ans->{'ans_message'} = $display_ans.$parser -> {error_msg},
+ $rh_ans->{'preview_text_string'} = '',
+ $rh_ans->throw_error('SYNTAX', 'syntax error in answer:'.$display_ans.$parser->{htmlerror} . "$main::BR" .$parser -> {error_msg}.".$main::BR");
+ }
+
+ my ($inVal,$PG_eval_errors,$PG_full_error_report) = PG_answer_eval($entry);
+ if ($PG_eval_errors) {
+ $rh_ans->throw_error('EVAL','There is a syntax error in your answer.') ;
+ $rh_ans->{ans_message} = clean_up_error_msg($PG_eval_errors);
+ last;
+ } else {
+ $entry = prfmt($inVal,$options{format});
+ $display_ans .= $entry.",";
+ $array[$i][$j][$k] = $entry;
+ }
+ }
+ chop($rh_ans->{preview_text_string});
+ chop($display_ans);
+ $rh_ans->{preview_text_string} .= '] ,';
+ $rh_ans->{preview_latex_string} .= '\\\\';
+ $display_ans .= '] ,';
+
+ }
+ chop($rh_ans->{preview_text_string});
+ chop($display_ans);
$rh_ans->{preview_text_string} .= '] ,';
$rh_ans->{preview_latex_string} .= '\end{pmatrix}'.' , ';
- $display_ans .= '] ,';
- }
- chop($rh_ans->{preview_text_string});
- chop($rh_ans->{preview_latex_string});
- chop($rh_ans->{preview_latex_string});
- chop($rh_ans->{preview_latex_string});
- chop($display_ans);
-
- my @temp = ();
- for( $i = 0 ; $i < scalar( @array ); $i++ ){
- push @temp , display_matrix($array[$i], 'left'=>'.', 'right'=>'.');
- push @temp , "," unless $i == scalar(@array) - 1;
- }
- $rh_ans->{student_ans} = mbox(\@temp);
- $rh_ans->{ra_student_ans} = \@array;
-
- $rh_ans;
+ $display_ans .= '] ,';
+ }
+ chop($rh_ans->{preview_text_string});
+ chop($rh_ans->{preview_latex_string});
+ chop($rh_ans->{preview_latex_string});
+ chop($rh_ans->{preview_latex_string});
+ chop($display_ans);
+
+ my @temp = ();
+ for( $i = 0 ; $i < scalar( @array ); $i++ ){
+ push @temp , display_matrix($array[$i], 'left'=>'.', 'right'=>'.');
+ push @temp , "," unless $i == scalar(@array) - 1;
+ }
+ $rh_ans->{student_ans} = mbox(\@temp);
+ $rh_ans->{ra_student_ans} = \@array;
+
+ $rh_ans;
}
sub are_orthogonal_vecs{
- my ($vec_ref , %opts) = @_;
- $vec_ref->{_filter_name} = 'are_orthogonal_vecs';
- my @vecs = ();
- if( ref($vec_ref) eq 'AnswerHash' )
- {
- @vecs = @{$vec_ref->{ra_student_ans}};
- }else{
- @vecs = @{$vec_ref};
- }
- my ($i,$j) = (0,0);
-
- my $num = scalar(@vecs);
- my $length = $vecs[0]->[1];
-
- for( ; $i < $num ; $i ++ )
- {
- for( $j = $i+1; $j < $num ; $j++ )
- {
- if( $vecs[$i]->scalar_product($vecs[$j]) > $main::functZeroLevelTolDefault )
- {
- if( ref( $vec_ref ) eq 'AnswerHash' ){
- $vec_ref->{score} = 0;
- if( $vec_ref->{help} =~ /orthogonal|orthonormal|verbose/ )
- {
- $vec_ref->throw_error('EVAL','You have entered vectors which are not orthogonal. ');
- }else{
- $vec_ref->throw_error('EVAL');
- }
- return $vec_ref;
- }else{
- return 0;
- }
- }
- }
- }
- if( ref( $vec_ref ) eq 'AnswerHash' ){
- $vec_ref->{score} = 1;
- $vec_ref;
- }else{
- 1;
- }
+ my ($vec_ref , %opts) = @_;
+ $vec_ref->{_filter_name} = 'are_orthogonal_vecs';
+ my @vecs = ();
+ if( ref($vec_ref) eq 'AnswerHash' )
+ {
+ @vecs = @{$vec_ref->{ra_student_ans}};
+ }else{
+ @vecs = @{$vec_ref};
+ }
+
+ my $num = scalar(@vecs);
+ my $length = $vecs[0]->[1];
+
+ for( my $i=0; $i < $num ; $i ++ ) {
+ for( my $j = $i+1; $j < $num ; $j++ ) {
+ if( $vecs[$i]->scalar_product($vecs[$j]) > $main::functZeroLevelTolDefault ) {
+ if( ref( $vec_ref ) eq 'AnswerHash' ){
+ $vec_ref->{score} = 0;
+ if( $vec_ref->{help} =~ /orthogonal|orthonormal|verbose/ )
+ {
+ $vec_ref->throw_error('EVAL','You have entered vectors which are not orthogonal. ');
+ }else{
+ $vec_ref->throw_error('EVAL');
+ }
+ return $vec_ref;
+ } else {
+ return 0;
+ }
+ }
+ }
+ }
+ if( ref( $vec_ref ) eq 'AnswerHash' ){
+ $vec_ref->{score} = 1;
+ $vec_ref;
+ } else {
+ 1;
+ }
}
sub is_diagonal{
- my $matrix = shift;
- my %options = @_;
- my $process_ans_hash = ( ref( $matrix ) eq 'AnswerHash' ) ? 1 : 0 ;
- my ($rh_ans);
- if ($process_ans_hash) {
- $rh_ans = $matrix;
- $matrix = $rh_ans->{ra_student_ans};
- }
-
- return 0 unless defined($matrix);
-
- if( ref($matrix) eq 'ARRAY' ){
- my @matrix = @{$matrix};
- @matrix = @{$matrix[0]} if ref($matrix[0][0]) eq 'ARRAY';
- if( ref($matrix[0]) ne 'ARRAY' or scalar( @matrix ) != scalar( @{$matrix[0]} ) ){
- warn "It is impossible for a non-square matrix to be diagonal, if you are a student, please tell your professor that there is a problem.";
- }
-
- for( my $i = 0; $i < scalar( @matrix ) ; $i++ ){
- for( my $j = 0; $j < scalar( @{$matrix[0]} ); $j++ ){
- if( $matrix[$i][$j] != 0 and $i != $j )
- {
- if ($process_ans_hash){
- $rh_ans->throw_error('EVAL');
- return $rh_ans;
- } else {
- return 0;
- }
- }
- }
- }
- if ($process_ans_hash){
- return $rh_ans;
- } else {
- return 1;
- }
- }elsif( ref($matrix) eq 'Matrix' ){
- if( $matrix->[1] != $matrix->[2] ){
- warn "It is impossible for a non-square matrix to be diagonal, if you are a student, please tell your professor that there is a problem.";
- if ($process_ans_hash){
- $rh_ans->throw_error('EVAL');
- return $rh_ans;
- } else {
- return 0;
- }
- }
- for( my $i = 0; $i < $matrix->[1] ; $i++ ){
- for( my $j = 0; $j < $matrix->[2] ; $j++ ){
- if( $matrix->[0][$i][$j] != 0 and $i != $j ){
- if ($process_ans_hash){
- $rh_ans->throw_error('EVAL');
- return $rh_ans;
- } else {
- return 0;
- }
- }
- }
- }
- if ($process_ans_hash){
- return $rh_ans;
- } else {
- return 1;
- }
- }else{
- warn "There is a problem with the problem, please alert your professor.";
- if ($process_ans_hash){
- $rh_ans->throw_error('EVAL');
- return $rh_ans;
- } else {
- return 0;
- }
- }
+ my $matrix = shift;
+ my %options = @_;
+ my $process_ans_hash = ( ref( $matrix ) eq 'AnswerHash' ) ? 1 : 0 ;
+ my ($rh_ans);
+ if ($process_ans_hash) {
+ $rh_ans = $matrix;
+ $matrix = $rh_ans->{ra_student_ans};
+ }
+
+ return 0 unless defined($matrix);
+
+ if( ref($matrix) eq 'ARRAY' ) {
+ my @matrix = @{$matrix};
+ @matrix = @{$matrix[0]} if ref($matrix[0][0]) eq 'ARRAY';
+ if( ref($matrix[0]) ne 'ARRAY' or scalar( @matrix ) != scalar( @{$matrix[0]} ) ){
+ warn "It is impossible for a non-square matrix to be diagonal, if you are a student, please tell your professor that there is a problem.";
+ }
+
+ for( my $i = 0; $i < scalar( @matrix ) ; $i++ ) {
+ for( my $j = 0; $j < scalar( @{$matrix[0]} ); $j++ ){
+ if( $matrix[$i][$j] != 0 and $i != $j )
+ {
+ if ($process_ans_hash){
+ $rh_ans->throw_error('EVAL');
+ return $rh_ans;
+ } else {
+ return 0;
+ }
+ }
+ }
+ }
+ if ($process_ans_hash){
+ return $rh_ans;
+ } else {
+ return 1;
+ }
+ } elsif ( ref($matrix) eq 'Matrix' ) {
+ if( $matrix->[1] != $matrix->[2] ) {
+ warn "It is impossible for a non-square matrix to be diagonal, if you are a student, please tell your professor that there is a problem.";
+ if ($process_ans_hash){
+ $rh_ans->throw_error('EVAL');
+ return $rh_ans;
+ } else {
+ return 0;
+ }
+ }
+ for( my $i = 0; $i < $matrix->[1] ; $i++ ) {
+ for( my $j = 0; $j < $matrix->[2] ; $j++ ) {
+ if( $matrix->[0][$i][$j] != 0 and $i != $j ){
+ if ($process_ans_hash){
+ $rh_ans->throw_error('EVAL');
+ return $rh_ans;
+ } else {
+ return 0;
+ }
+ }
+ }
+ }
+ if ($process_ans_hash) {
+ return $rh_ans;
+ } else {
+ return 1;
+ }
+ } else {
+ warn "There is a problem with the problem, please alert your professor.";
+ if ($process_ans_hash){
+ $rh_ans->throw_error('EVAL');
+ return $rh_ans;
+ } else {
+ return 0;
+ }
+ }
}
sub are_unit_vecs{
- my ( $vec_ref,%opts ) = @_;
- $vec_ref->{_filter_name} = 'are_unit_vecs';
- my @vecs = ();
- if( ref($vec_ref) eq 'AnswerHash' )
- {
- @vecs = @{$vec_ref->{ra_student_ans}};
- }else{
- @vecs = @{$vec_ref};
- }
-
- my $i = 0;
- my $num = scalar(@vecs);
- my $length = $vecs[0]->[1];
-
- for( ; $i < $num ; $i ++ )
- {
- if( abs(sqrt($vecs[$i]->scalar_product($vecs[$i]))- 1) > $main::functZeroLevelTolDefault )
- {
- if( ref( $vec_ref ) eq 'AnswerHash' ){
- $vec_ref->{score} = 0;
- if( $vec_ref->{help} =~ /unit|orthonormal|verbose/ )
- {
- $vec_ref->throw_error('EVAL','You have entered vector(s) which are not of unit length.');
- }else{
- $vec_ref->throw_error('EVAL');
- }
- return $vec_ref;
- }else{
- return 0;
- }
-
- }
- }
-
- if( ref( $vec_ref ) eq 'AnswerHash' ){
- $vec_ref->{score} = 1;
- $vec_ref;
- }else{
- 1;
- }
+ my ( $vec_ref,%opts ) = @_;
+ $vec_ref->{_filter_name} = 'are_unit_vecs';
+ my @vecs = ();
+ if( ref($vec_ref) eq 'AnswerHash' )
+ {
+ @vecs = @{$vec_ref->{ra_student_ans}};
+ }else{
+ @vecs = @{$vec_ref};
+ }
+
+ my $i = 0;
+ my $num = scalar(@vecs);
+ my $length = $vecs[0]->[1];
+
+ for( ; $i < $num ; $i ++ ) {
+ if( abs(sqrt($vecs[$i]->scalar_product($vecs[$i]))- 1) > $main::functZeroLevelTolDefault )
+ {
+ if( ref( $vec_ref ) eq 'AnswerHash' ){
+ $vec_ref->{score} = 0;
+ if( $vec_ref->{help} =~ /unit|orthonormal|verbose/ )
+ {
+ $vec_ref->throw_error('EVAL','You have entered vector(s) which are not of unit length.');
+ }else{
+ $vec_ref->throw_error('EVAL');
+ }
+ return $vec_ref;
+ }else{
+ return 0;
+ }
+
+ }
+ }
+
+ if( ref( $vec_ref ) eq 'AnswerHash' ){
+ $vec_ref->{score} = 1;
+ $vec_ref;
+ }else{
+ 1;
+ }
}
sub display_correct_vecs{
- my ( $ra_vecs,%opts ) = @_;
- my @ra_vecs = @{$ra_vecs};
- my @temp = ();
-
- for( my $i = 0 ; $i < scalar(@ra_vecs) ; $i++ ){
- push @temp, display_matrix(Matrix->new_from_col_vecs([$ra_vecs[$i]]),'left'=>'.','right'=>'.');
- push @temp, ",";
- }
-
- pop @temp;
-
- mbox(\@temp);
+ my ( $ra_vecs,%opts ) = @_;
+ my @ra_vecs = @{$ra_vecs};
+ my @temp = ();
+
+ for( my $i = 0 ; $i < scalar(@ra_vecs) ; $i++ ) {
+ push @temp, display_matrix(Matrix->new_from_col_vecs([$ra_vecs[$i]]),'left'=>'.','right'=>'.');
+ push @temp, ",";
+ }
+
+ pop @temp;
+
+ mbox(\@temp);
}
sub vec_solution_cmp{
- my $correctAnswer = shift;
- my %opt = @_;
+ my $correctAnswer = shift;
+ my %opt = @_;
- set_default_options( \%opt,
- 'zeroLevelTol' => $main::functZeroLevelTolDefault,
- 'debug' => 0,
- 'mode' => 'basis',
- 'help' => 'none',
- );
-
- $opt{debug} = 0 unless defined($opt{debug});
-
+ set_default_options( \%opt,
+ 'zeroLevelTol' => $main::functZeroLevelTolDefault,
+ 'debug' => 0,
+ 'mode' => 'basis',
+ 'help' => 'none',
+ );
+
+
## This is where the correct answer should be checked someday.
- my $matrix = Matrix->new_from_col_vecs($correctAnswer);
-
-
+ my $matrix = Matrix->new_from_col_vecs($correctAnswer);
+
+
#construct the answer evaluator
- my $answer_evaluator = new AnswerEvaluator;
+ my $answer_evaluator = new AnswerEvaluator;
- $answer_evaluator->{debug} = $opt{debug};
- $answer_evaluator->ans_hash( correct_ans => display_correct_vecs($correctAnswer),
- old_correct_ans => $correctAnswer,
- rm_correct_ans => $matrix,
- zeroLevelTol => $opt{zeroLevelTol},
- debug => $opt{debug},
- mode => $opt{mode},
- help => $opt{help},
- );
-
- $answer_evaluator->install_pre_filter(\&ans_array_filter);
- $answer_evaluator->install_pre_filter(sub{
- my ($rh_ans,@options) = @_;
- my @student_array = @{$rh_ans->{ra_student_ans}};
- my @array = ();
- for( my $i = 0; $i < scalar(@student_array) ; $i ++ )
- {
- push( @array, Matrix->new_from_array_ref($student_array[$i]));
- }
- $rh_ans->{ra_student_ans} = \@array;
- $rh_ans;
- });#ra_student_ans is now the students answer as an array of vectors
- # anonymous subroutine to check dimension and length of the student vectors
- # if either is wrong, the answer is wrong.
- $answer_evaluator->install_pre_filter(sub{
- my $rh_ans = shift;
- my $length = $rh_ans->{rm_correct_ans}->[1];
- my $dim = $rh_ans->{rm_correct_ans}->[2];
- if( $dim != scalar(@{$rh_ans->{ra_student_ans}}))
- {
-
- $rh_ans->{score} = 0;
- if( $rh_ans->{help} =~ /dim|verbose/ )
- {
- $rh_ans->throw_error('EVAL','You have entered the wrong number of vectors.');
- }else{
- $rh_ans->throw_error('EVAL');
- }
- }
- for( my $i = 0; $i < scalar( @{$rh_ans->{ra_student_ans} }) ; $i++ )
- {
- if( $length != $rh_ans->{ra_student_ans}->[$i]->[1])
+ $answer_evaluator->{debug} = $opt{debug};
+ $answer_evaluator->ans_hash(
+ correct_ans => display_correct_vecs($correctAnswer),
+ old_correct_ans => $correctAnswer,
+ rm_correct_ans => $matrix,
+ zeroLevelTol => $opt{zeroLevelTol},
+ debug => $opt{debug},
+ mode => $opt{mode},
+ help => $opt{help},
+ );
+
+ $answer_evaluator->install_pre_filter(\&ans_array_filter);
+ $answer_evaluator->install_pre_filter(
+ sub{
+ my ($rh_ans,@options) = @_;
+ $rh_ans->{_filter_name} = "create student answer as an array of vectors";
+ my @student_array = @{$rh_ans->{ra_student_ans}};
+ my @array = ();
+ for( my $i = 0; $i < scalar(@student_array) ; $i ++ ) {
+ push( @array, Matrix->new_from_array_ref($student_array[$i]));
+ }
+ $rh_ans->{ra_student_ans} = \@array;
+ $rh_ans;
+ }
+ );
+ #ra_student_ans is now the students answer as an array of vectors
+ # anonymous subroutine to check dimension and length of the student vectors
+ # if either is wrong, the answer is wrong.
+ $answer_evaluator->install_pre_filter(
+ sub{
+ my $rh_ans = shift;
+ $rh_ans->{_filter_name} = "check_dimension_and_length";
+ my $length = $rh_ans->{rm_correct_ans}->[1];
+ my $dim = $rh_ans->{rm_correct_ans}->[2];
+ if( $dim != scalar(@{$rh_ans->{ra_student_ans}}))
{
+
$rh_ans->{score} = 0;
- if( $rh_ans->{help} =~ /length|verbose/ )
+ if( $rh_ans->{help} =~ /dim|verbose/ )
{
- $rh_ans->throw_error('EVAL','You have entered vector(s) of the wrong length.');
+ $rh_ans->throw_error('EVAL','You have entered the wrong number of vectors.');
}else{
$rh_ans->throw_error('EVAL');
}
}
- }
- $rh_ans;
- });
- # Install prefilter for various modes
- if( $opt{mode} ne 'basis' )
- {
- if( $opt{mode} =~ /orthogonal|orthonormal/ )
- {
- $answer_evaluator->install_pre_filter(\&are_orthogonal_vecs);
- }
-
- if( $opt{mode} =~ /unit|orthonormal/ )
- {
- $answer_evaluator->install_pre_filter(\&are_unit_vecs);
-
- }
- }
-
- $answer_evaluator->install_evaluator(\&compare_vec_solution, %opt);
-
- $answer_evaluator->install_post_filter(
- sub {my $rh_ans = shift;
- if ($rh_ans->catch_error('SYNTAX') ) {
- $rh_ans->{ans_message} = $rh_ans->{error_message};
- $rh_ans->clear_error('SYNTAX');
- }
- if ($rh_ans->catch_error('EVAL') ) {
- $rh_ans->{ans_message} = $rh_ans->{error_message};
- $rh_ans->clear_error('EVAL');
+ for( my $i = 0; $i < scalar( @{$rh_ans->{ra_student_ans} }) ; $i++ ) {
+ if( $length != $rh_ans->{ra_student_ans}->[$i]->[1]) {
+ $rh_ans->{score} = 0;
+ if( $rh_ans->{help} =~ /length|verbose/ ) {
+ $rh_ans->throw_error('EVAL','You have entered vector(s) of the wrong length.');
+ }else{
+ $rh_ans->throw_error('EVAL');
+ }
}
- $rh_ans;
- }
- );
- $answer_evaluator;
-
+ }
+ $rh_ans;
+ }
+ );
+ # Install prefilter for various modes
+ if( $opt{mode} ne 'basis' ) {
+ if( $opt{mode} =~ /orthogonal|orthonormal/ ) {
+ $answer_evaluator->install_pre_filter(\&are_orthogonal_vecs);
+ }
+
+ if( $opt{mode} =~ /unit|orthonormal/ ) {
+ $answer_evaluator->install_pre_filter(\&are_unit_vecs);
+
+ }
+ }
+
+ $answer_evaluator->install_evaluator(\&compare_vec_solution, %opt);
+
+ $answer_evaluator->install_post_filter(
+ sub {my $rh_ans = shift;
+ if ($rh_ans->catch_error('SYNTAX') ) {
+ $rh_ans->{ans_message} = $rh_ans->{error_message};
+ $rh_ans->clear_error('SYNTAX');
+ }
+ if ($rh_ans->catch_error('EVAL') ) {
+ $rh_ans->{ans_message} = $rh_ans->{error_message};
+ $rh_ans->clear_error('EVAL');
+ }
+ $rh_ans;
+ }
+ );
+ $answer_evaluator;
+
}
-
+
sub compare_vec_solution {
- my ( $rh_ans, %options ) = @_ ;
- my @space = @{$rh_ans->{ra_student_ans}};
- my $solution = shift @space;
-
- # A lot of the follosing code was taken from Matrix::proj_coeff
- # calling this method recursively would be a waste of time since
- # the prof's matrix never changes and solve_LR is an expensive
- # operation. This way it is only done once.
- my $matrix = $rh_ans->{rm_correct_ans};
- my ($dim,$x_vector, $base_matrix);
- my $errors = undef;
- my $lin_space_tr= ~ $matrix;
- $matrix = $lin_space_tr * $matrix;
- my $matrix_lr = $matrix->decompose_LR();
-
- #this section determines whether or not the first vector, a solution to
- #the system, is a linear combination of the prof's vectors in which there
- #is a nonzero coefficient on the first term, the prof's solution to the system
- $solution = $lin_space_tr*$solution;
- ($dim,$x_vector, $base_matrix) = $matrix_lr->solve_LR($solution);
- if( $dim ){
- $rh_ans->throw_error('EVAL', "A unique adapted answer could not be determined. Possibly the parameters have coefficient zero.<br> dim = $dim base_matrix is $base_matrix\n" ); # only print if the dim is not zero.
- $rh_ans->{score} = 0;
- $rh_ans;
- }elsif( abs($x_vector->[0][0][0]) <= $options{zeroLevelTol} )
- {
- $rh_ans->{score} = 0;
- $rh_ans;
- }else{
- $rh_ans->{score} = 1;
- my @correct_space = @{$rh_ans->{old_correct_ans}};
- shift @correct_space;
- $rh_ans->{rm_correct_ans} = Matrix->new_from_col_vecs(\@correct_space);
- $rh_ans->{ra_student_ans} = \@space;
- return compare_basis( $rh_ans, %options );
- }
+ my ( $rh_ans, %options ) = @_ ;
+ $rh_ans->{_filter_name} = "compare_vec_solution";
+ my @space = @{$rh_ans->{ra_student_ans}};
+ my $solution = shift @space;
+
+ # A lot of the following code was taken from Matrix::proj_coeff
+ # calling this method recursively would be a waste of time since
+ # the prof's matrix never changes and solve_LR is an expensive
+ # operation. This way it is only done once.
+ my $matrix = $rh_ans->{rm_correct_ans};
+ my ($dim,$x_vector, $base_matrix);
+ my $errors = undef;
+ my $lin_space_tr= ~ $matrix;
+ $matrix = $lin_space_tr * $matrix;
+ my $matrix_lr = $matrix->decompose_LR();
+
+ #this section determines whether or not the first vector, a solution to
+ #the system, is a linear combination of the prof's vectors in which there
+ #is a nonzero coefficient on the first term, the prof's solution to the system
+ $solution = $lin_space_tr*$solution;
+ ($dim,$x_vector, $base_matrix) = $matrix_lr->solve_LR($solution);
+ #$rh_ans->{debug_compare_vec_solution} = $x_vector->element(1,1);
+ if( $dim ){
+ $rh_ans->throw_error('EVAL', "A unique adapted answer could not be determined. Possibly the parameters have coefficient zero.<br> dim = $dim base_matrix is $base_matrix\n" ); # only print if the dim is not zero.
+ $rh_ans->{score} = 0;
+ $rh_ans;
+ } elsif( abs($x_vector->element(1,1) -1) >= $options{zeroLevelTol} ) {
+ # changes by MEG 6/24/05
+ # the student answer needs to be a linear combination of the instructors vectors
+ # and the coefficient of the first vector needs to be 1 (it is NOT enough that it be non-zero).
+ # if this is not the case, then the answer is wrong.
+ # replaced $x_vector->[0][0][0] by $x_vector->element(1,1) since this doesn't depend on the internal structure of the matrix object.
+
+ $rh_ans->{score} = 0;
+ $rh_ans;
+ } else {
+ $rh_ans->{score} = 1;
+ my @correct_space = @{$rh_ans->{old_correct_ans}};
+ shift @correct_space;
+ $rh_ans->{rm_correct_ans} = Matrix->new_from_col_vecs(\@correct_space);
+ $rh...
[truncated message content] |
2 messages has been excluded from this view by a project administrator.
