openwebwork-cvs — WeBWorK CVS activity

[WWcvs] webwork-modperl: Remove the no longer valid message: This may take a

[Arnie P. v. a. <we...@ma...>]

Log Message:
-----------
Remove the no longer valid message:
This may take a long time. Even if your browser times 
out, all the files will be exported

Modified Files:
--------------
    webwork-modperl/lib/WeBWorK/ContentGenerator/Instructor:
        ProblemSetList.pm

Revision Data
-------------
Index: ProblemSetList.pm
===================================================================
RCS file: /webwork/cvs/system/webwork-modperl/lib/WeBWorK/ContentGenerator/Instructor/ProblemSetList.pm,v
retrieving revision 1.84
retrieving revision 1.85
diff -Llib/WeBWorK/ContentGenerator/Instructor/ProblemSetList.pm -Llib/WeBWorK/ContentGenerator/Instructor/ProblemSetList.pm -u -r1.84 -r1.85
--- lib/WeBWorK/ContentGenerator/Instructor/ProblemSetList.pm
+++ lib/WeBWorK/ContentGenerator/Instructor/ProblemSetList.pm
@@ -1142,7 +1142,7 @@
 
 sub saveExport_form {
 	my ($self, $onChange, %actionParams) = @_;
-	return "Export selected sets (This may take a long time.  Even if your browser times out, all the files will be exported).";
+	return "Export selected sets.";
 }
 
 sub saveExport_handler {

[WWcvs] pg: Changed Context() call to direct reference to context, so as not to

[dpvc v. a. <we...@ma...>]

Log Message:
-----------
Changed Context() call to direct reference to context, so as not to
leave the wrong content selected as the current one.

Modified Files:
--------------
    pg/lib/Parser/Legacy:
        PGanswermacros.pl

Revision Data
-------------
Index: PGanswermacros.pl
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/Legacy/PGanswermacros.pl,v
retrieving revision 1.8
retrieving revision 1.9
diff -Llib/Parser/Legacy/PGanswermacros.pl -Llib/Parser/Legacy/PGanswermacros.pl -u -r1.8 -r1.9
--- lib/Parser/Legacy/PGanswermacros.pl
+++ lib/Parser/Legacy/PGanswermacros.pl
@@ -1931,7 +1931,7 @@
 	#
 	#  Initialize the context for the formula
 	#
-	my $context = &$Context("LegacyNumeric")->copy;
+	my $context = $Parser::Context::Default::context{"LegacyNumeric"}->copy;
 	$context->flags->set(
 	  tolerance    => $func_params{'tolerance'},
 	  tolType      => $func_params{'tolType'},

[WWcvs] webwork-modperl: Add the beginnings of a facility for archiving a

[Mike G. v. a. <we...@ma...>]

Log Message:
-----------
Add the beginnings of a facility for archiving a course.  This method uses mysqldump
and therefore will work only with a mysql database.  Many things are still hardwired
In particular mysqldump is hardwired.                                             
The database name is hardwired to  "webwork"

Archiving consists of dumping the tables associated to the course to a file 
$courseID/DATA/$courseID_mysql.database  (this file can be used
to created a new database for the course.  it will not overwrite existing
tables however.)

Then the entire course directory is tarred and gzipped and placed 
in the courses directory with the naem $courseID.tar.gz 

Currently nothing is deleted from the database and no directories are deleted.
So the implementation is fairly safe, but not yet very useful for course management.

There is not yet a facility for automatically importing the archived course.

Modified Files:
--------------
    webwork-modperl/lib/WeBWorK/Utils:
        CourseManagement.pm
    webwork-modperl/lib/WeBWorK/Utils/CourseManagement:
        sql_single.pm

Revision Data
-------------
Index: CourseManagement.pm
===================================================================
RCS file: /webwork/cvs/system/webwork-modperl/lib/WeBWorK/Utils/CourseManagement.pm,v
retrieving revision 1.23
retrieving revision 1.24
diff -Llib/WeBWorK/Utils/CourseManagement.pm -Llib/WeBWorK/Utils/CourseManagement.pm -u -r1.23 -r1.24
--- lib/WeBWorK/Utils/CourseManagement.pm
+++ lib/WeBWorK/Utils/CourseManagement.pm
@@ -38,6 +38,7 @@
 	addCourse
 	renameCourse
 	deleteCourse
+	archiveCourse
 	dbLayoutSQLSources
 );
 
@@ -454,6 +455,125 @@
 	}
 }
 
+
+=item archiveCourse(%options)
+
+%options must contain:
+
+ courseID    => $courseID,
+ ce          => $ce,
+ dbOptions   => $dbOptions,
+ newCourseID => $newCourseID,
+
+Archive the course named $courseID  in the $webworkDirs{courses} directory
+as $webworkDirs{courses}/$courseID.tar.gz.  The data from the database is
+stored in several files at $courseID/DATA/$table_name.txt before the course's directories
+are tarred and gzipped.  The table names are $courseID_user, $courseID_set
+and so forth.  Only files and directories stored directly in the course directory
+are archived.  The contents of linked files is not archived although the symbolic links
+themselves are saved.
+
+$ce is a WeBWorK::CourseEnvironment object that describes the existing course's
+environment.
+
+# $dbOptions is a reference to a hash containing information required to create
+# the course's new database and delete the course's old database.
+# 
+#  if dbLayout == "sql":
+#  
+#  	host         => host to connect to
+#  	port         => port to connect to
+#  	username     => user to connect as (must have CREATE, DELETE, FILE, INSERT,
+#  	                SELECT, UPDATE privileges, WITH GRANT OPTION.)
+#  	password     => password to supply
+#  	old_database => the name of the database to delete
+#  	new_database => the name of the database to create
+#  	wwhost       => the host from which the webwork database users will be allowed
+#  	                to connect. (if host is set to localhost, this should be set to
+#  	                localhost too.)
+# 
+# The name of the course's directory is changed to $newCourseID.
+
+If the course's database layout is C<sql_single>, the contents of 
+the courses database tables are exported to text files using the sql database's
+export facility.  Then the tables are deleted from the database.
+
+# If the course's database layout is C<sql>, a new database is created, course
+# data is copied from the old database to the new database, and the old database
+# is deleted.
+# 
+# If the course's database layout is C<gdbm>, the DBM files are simply renamed on
+# disk.
+
+If the course's database layout is something else, no database changes are made.
+
+Any errors encountered while renaming the course are returned.
+
+=cut
+
+sub archiveCourse {
+	my (%options) = @_;
+	
+	# renameCourseHelper needs:
+	#    $fromCourseID ($oldCourseID)
+	#    $fromCE ($ce)
+	#    $toCourseID ($newCourseID)
+	#    $toCE (construct from $ce)
+	#    $dbLayoutName ($ce->{dbLayoutName})
+	#    %options ($dbOptions)
+	
+	my $courseID = $options{courseID};
+	my $ce = $options{ce};
+	my %dbOptions = defined $options{dbOptions} ? %{ $options{dbOptions} } : ();
+
+	
+	# get the database layout out of the options hash
+	my $dbLayoutName = $ce->{dbLayoutName};
+	
+	die "I happen to know that renameCourse() will only succeed for sql_single courses. Bug Mike to write support for gdbm and sql courses.\n"
+		unless $dbLayoutName eq "sql_single";
+	
+	# collect some data
+	my $coursesDir  = $ce->{webworkDirs}->{courses};
+	my $courseDir   = "$coursesDir/$courseID";
+	my $dataDir     = "$courseDir/DATA";
+	my $archivePath = "$coursesDir/$courseID.tar.gz";
+	
+	# create DATA directory if it does not exist.
+	unless (-e $dataDir) {
+		mkdir "$dataDir" or die "Failed to create course directory $dataDir";
+	}
+	# fail if the target file already exists
+	if (-e $archivePath) {
+		croak "The course $courseID has already been archived at $archivePath";
+	}
+	
+	# fail if the source course does not exist
+	unless (-e $courseDir) {
+		croak "$courseID: course not found";
+	}
+	
+	$dbOptions{archiveDatabasePath}   =  "$dataDir/${courseID}_mysql.database";
+	##### step 1: export database contents ######
+	# munge DB options to move new_database => database
+
+	
+	my $archiveHelperResult = archiveCourseHelper($courseID, $ce, $dbLayoutName, %dbOptions);
+	die "$courseID: course database dump failed.\n" unless $archiveHelperResult;
+		
+	##### step 2: tar and gzip course directory #####
+	
+	# archive top-level course directory
+	#FIXME (check) don't follow links
+	my $tarCmd = $ce->{externalPrograms}->{tar};
+	debug("archiving course dir: $tarCmd $archivePath $courseDir \n");
+	my $tarStatement = "$tarCmd  -zcf   $archivePath  $courseDir";
+	my $tarResult = system $tarStatement ;
+	$tarResult and die "failed to tar course directory with command: '$tarStatement ' (errno: $tarResult): $!\n";
+	
+}
+
+
 =item dbLayoutSQLSources($dbLayout)
 
 Retrun a hash of database sources for the sql and sql_single database layouts.
@@ -543,6 +663,18 @@
 	return $result;
 }
 
+=item archiveCourseHelper($courseID, $ce, $dbLayoutName, %options)
+
+Perform database-layout specific operations for archiving the data in a course.
+
+=cut
+
+sub archiveCourseHelper {
+	my ($courseID, $ce, $dbLayoutName, %options) = @_;
+	my $result = callHelperIfExists("archiveCourseHelper", $dbLayoutName, @_);
+	return $result;
+}
+
 =item copyCourseDataHelper($fromCourseID, $fromCE, $toCourseID, $toCE, $dbLayoutName, %options)
 
 Perform database-layout specific operations for copying a course's data from one
Index: sql_single.pm
===================================================================
RCS file: /webwork/cvs/system/webwork-modperl/lib/WeBWorK/Utils/CourseManagement/sql_single.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -Llib/WeBWorK/Utils/CourseManagement/sql_single.pm -Llib/WeBWorK/Utils/CourseManagement/sql_single.pm -u -r1.5 -r1.6
--- lib/WeBWorK/Utils/CourseManagement/sql_single.pm
+++ lib/WeBWorK/Utils/CourseManagement/sql_single.pm
@@ -171,7 +171,7 @@
 	return 1;
 }
 
-=item renameCourseHelper($fromCourseID, $fromCE, $toCourseID, $toCE, $dbLayoutName, %options)
+=item copyCourseHelper($fromCourseID, $fromCE, $toCourseID, $toCE, $dbLayoutName, %options)
 
 Uses addCourseHelper() to create a new course database on the same server.
 Copies the data from the old course database to the new one. Uses
@@ -290,6 +290,89 @@
 	return 1;
 }
 
+=item archiveCourseHelper($fromCourseID, $fromCE, $toCourseID, $toCE, $dbLayoutName, %options)
+
+Dumps the data from the  course database to text files in the courseID/DATA directory. Uses
+deleteCourseHelper() to delete the old course database.
+
+=cut
+
+sub archiveCourseHelper {
+	my ($courseID, $ce,  $dbLayoutName, %options) = @_;
+	debug("courseID=$courseID, ce=$ce dbLayoutName=$dbLayoutName\n");
+	
+	##### get list of tables to archive #####
+	
+	my $dbLayout    = $ce->{dbLayouts}->{$dbLayoutName};
+	debug("dbLayout=$dbLayout\n");
+	my %sources     = dbLayoutSQLSources($dbLayout);
+	debug("fSources: ", Dumper(\%sources));
+	my $source    = mostPopularSource(%sources);
+	debug("source=$source\n");
+	my %source = %{ $sources{$source} };
+	my @tables = @{ $source{tables} };
+	my $username = $source{username};
+	my $password = $source{password};
+	my $archiveDatabasePath = $options{archiveDatabasePath};
+	
+	##### construct SQL statements to copy the data in each table #####
+	
+	my @stmts;
+	my @dataTables = ();
+	foreach my $table (@tables) {
+		debug("Table: $table\n");
+		my $table = do {
+			my $paramsRef = $dbLayout->{$table}->{params};
+			if ($paramsRef) {
+				if (exists $paramsRef->{tableOverride}) {
+					$paramsRef->{tableOverride}
+				} else {
+					""; # no override
+				}
+			} else {
+				""; # no params
+			}
+		} || $table;
+		debug("sql \"real\" table name: $table\n");
+		
+       
+        # this method would be mysql specific but it's a start
+		# mysqldump  --user=$username   --password=$password database   tables
+#		my $stmt = "DUMP SELECT * FROM `$fromTable`";
+#		debug("stmt = $stmt\n");
+#		push @stmts, $stmt;
+	    push @dataTables, $table;
+	}
+	debug("Database tables to export are ",join(" ", @dataTables));
+	# this method would be mysql specific but it's a start
+	my $exportStatement = " mysqldump  --user=$username  ".
+	"--password=$password " .
+	" webwork   ".
+	join(" ", @dataTables).
+	"   >$archiveDatabasePath";
+	debug($exportStatement);
+	my $exportResult = system $exportStatement;
+	$exportResult and die "failed to tar course directory with command: '$exportResult ' (errno: $exportResult): $!\n";
+
+	##### issue SQL statements #####
+	
+# 	my $dbh = DBI->connect($source, $username, $password);
+# 	unless (defined $dbh) {
+# 		die "sql_single: failed to connect to DBI source '$source': $DBI::errstr\n";
+# 	}
+# 	
+# 	foreach my $stmt (@stmts) {
+# 		my $rows = $dbh->do($stmt);
+# 		unless (defined $rows) {
+# 			die "sql_single: failed to execute SQL statement '$stmt': $DBI::errstr\n";
+# 		}
+# 	}
+# 	
+# 	$dbh->disconnect;
+	
+	return 1;
+}
+
 # returns the name of the source with the most tables
 sub mostPopularSource {
 	my (%sources) = @_;

[WWcvs] webwork-modperl: Add the beginnings of a facility for archiving a

[Mike G. v. a. <we...@ma...>]

Log Message:
-----------
Add the beginnings of a facility for archiving a course.  This method uses mysqldump
and therefore will work only with a mysql database.  Many things are still hardwired
In particular mysqldump is hardwired.
The database name is hardwired to  "webwork"

Archiving consists of dumping the tables associated to the course to a file 
$courseID/DATA/$courseID_mysql.database  (this file can be used
to created a new database for the course.  it will not overwrite existing
tables however.)

Then the entire course directory is tarred and gzipped and placed 
in the courses directory with the naem $courseID.tar.gz

Currently nothing is deleted from the database and no directories are deleted.
So the implementation is fairly safe, but not yet very useful for course management.

There is not yet a facility for automatically importing the archived course.

Modified Files:
--------------
    webwork-modperl/lib/WeBWorK/ContentGenerator:
        CourseAdmin.pm

Revision Data
-------------
Index: CourseAdmin.pm
===================================================================
RCS file: /webwork/cvs/system/webwork-modperl/lib/WeBWorK/ContentGenerator/CourseAdmin.pm,v
retrieving revision 1.39
retrieving revision 1.40
diff -Llib/WeBWorK/ContentGenerator/CourseAdmin.pm -Llib/WeBWorK/ContentGenerator/CourseAdmin.pm -u -r1.39 -r1.40
--- lib/WeBWorK/ContentGenerator/CourseAdmin.pm
+++ lib/WeBWorK/ContentGenerator/CourseAdmin.pm
@@ -31,7 +31,7 @@
 use WeBWorK::CourseEnvironment;
 use IO::File;
 use WeBWorK::Utils qw(cryptPassword writeLog listFilesRecursive);
-use WeBWorK::Utils::CourseManagement qw(addCourse renameCourse deleteCourse listCourses);
+use WeBWorK::Utils::CourseManagement qw(addCourse renameCourse deleteCourse listCourses archiveCourse);
 use WeBWorK::Utils::DBImportExport qw(dbExport dbImport);
 
 # put the following database layouts at the top of the list, in this order
@@ -165,6 +165,29 @@
 			}
 		}
 		
+		elsif ($subDisplay eq "archive_course") {
+			if (defined $r->param("archive_course")) {
+				# validate or confirm
+				@errors = $self->archive_course_validate;
+				if (@errors) {
+					$method_to_call = "archive_course_form";
+				} else {
+					$method_to_call = "archive_course_confirm";
+				}
+			} elsif (defined $r->param("confirm_archive_course")) {
+				# validate and archive
+				@errors = $self->archive_course_validate;
+				if (@errors) {
+					$method_to_call = "archive_course_form";
+				} else {
+					$method_to_call = "do_archive_course";
+				}
+			} else {
+				# form only
+				$method_to_call = "archive_course_form";
+			}
+		}
+		
 		else {
 			@errors = "Unrecognized sub-display @{[ CGI::b($subDisplay) ]}.";
 		}
@@ -252,6 +275,8 @@
 		CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"export_database"})}, "Export Database"),
 		" | ",
 		CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"import_database"})}, "Import Database"),
+		" | ",
+		CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"archive_course"})}, "Archive Course"),
 		CGI::hr(),
 		$methodMessage,
 		
@@ -1745,5 +1770,284 @@
 		);
 	}
 }
+##########################################################################
+sub archive_course_form {
+	my ($self) = @_;
+	my $r = $self->r;
+	my $ce = $r->ce;
+	#my $db = $r->db;
+	#my $authz = $r->authz;
+	#my $urlpath = $r->urlpath;
+	
+	my $archive_courseID     = $r->param("archive_courseID")     || "";
+	my $archive_sql_host     = $r->param("archive_sql_host")     || "";
+	my $archive_sql_port     = $r->param("archive_sql_port")     || "";
+	my $archive_sql_username = $r->param("archive_sql_username") || "";
+	my $archive_sql_password = $r->param("archive_sql_password") || "";
+	my $archive_sql_database = $r->param("archive_sql_database")    || "";
+	
+	my @courseIDs = listCourses($ce);
+	@courseIDs    = sort {lc($a) cmp lc ($b) } @courseIDs; #make sort case insensitive 
+	
+	my %courseLabels; # records... heh.
+	foreach my $courseID (@courseIDs) {
+		my $tempCE = WeBWorK::CourseEnvironment->new(
+			$ce->{webworkDirs}->{root},
+			$ce->{webworkURLs}->{root},
+			$ce->{pg}->{directories}->{root},
+			$courseID,
+		);
+		$courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")";
+	}
+	
+	print CGI::h2("archive Course");
+	
+	print CGI::start_form("POST", $r->uri);
+	print $self->hidden_authen_fields;
+	print $self->hidden_fields("subDisplay");
+	
+	print CGI::p("Select a course to archive.");
+	
+	print CGI::table({class=>"FormLayout"},
+		CGI::Tr(
+			CGI::th({class=>"LeftHeader"}, "Course Name:"),
+			CGI::td(
+				CGI::scrolling_list(
+					-name => "archive_courseID",
+					-values => \@courseIDs,
+					-default => $archive_courseID,
+					-size => 10,
+					-multiple => 0,
+					-labels => \%courseLabels,
+				),
+			),
+		),
+	);
+	
+	print CGI::p(
+		"Currently the archive facility is only available for mysql databases.
+		It depends on the mysqldump application."
+	);
+# 	print CGI::p(
+# 		"If the course's database layout (indicated in parentheses above) is "
+# 		. CGI::b("sql") . ", supply the SQL connections information requested below."
+# 	);
+	
+# 	print CGI::start_table({class=>"FormLayout"});
+# 	print CGI::Tr(CGI::td({colspan=>2}, 
+# 			"Enter the user ID and password for an SQL account with sufficient permissions to archive an existing database."
+# 		)
+# 	);
+# 	print CGI::Tr(
+# 		CGI::th({class=>"LeftHeader"}, "SQL Admin Username:"),
+# 		CGI::td(CGI::textfield("archive_sql_username", $archive_sql_username, 25)),
+# 	);
+# 	print CGI::Tr(
+# 		CGI::th({class=>"LeftHeader"}, "SQL Admin Password:"),
+# 		CGI::td(CGI::password_field("archive_sql_password", $archive_sql_password, 25)),
+# 	);
+# 	
+# 	#print CGI::Tr(CGI::td({colspan=>2},
+# 	#		"The optionial SQL settings you enter below must match the settings in the DBI source"
+# 	#		. " specification " . CGI::tt($dbi_source) . ". Replace " . CGI::tt("COURSENAME")
+# 	#		. " with the course name you entered above."
+# 	#	)
+# 	#);
+# 	print CGI::Tr(
+# 		CGI::th({class=>"LeftHeader"}, "SQL Server Host:"),
+# 		CGI::td(
+# 			CGI::textfield("archive_sql_host", $archive_sql_host, 25),
+# 			CGI::br(),
+# 			CGI::small("Leave blank to use the default host."),
+# 		),
+# 	);
+# 	print CGI::Tr(
+# 		CGI::th({class=>"LeftHeader"}, "SQL Server Port:"),
+# 		CGI::td(
+# 			CGI::textfield("archive_sql_port", $archive_sql_port, 25),
+# 			CGI::br(),
+# 			CGI::small("Leave blank to use the default port."),
+# 		),
+# 	);
+# 
+# 	print CGI::Tr(
+# 		CGI::th({class=>"LeftHeader"}, "SQL Database Name:"),
+# 		CGI::td(
+# 			CGI::textfield("archive_sql_database", $archive_sql_database, 25),
+# 			CGI::br(),
+# 			CGI::small("Leave blank to use the name ", CGI::tt("webwork_COURSENAME"), "."),
+# 		),
+# 	);
+# 	print CGI::end_table();
+	
+	print CGI::p({style=>"text-align: center"}, CGI::submit("archive_course", "archive Course"));
+	
+	print CGI::end_form();
+}
+
+sub archive_course_validate {
+	my ($self) = @_;
+	my $r = $self->r;
+	my $ce = $r->ce;
+	#my $db = $r->db;
+	#my $authz = $r->authz;
+	my $urlpath = $r->urlpath;
+	
+	my $archive_courseID     = $r->param("archive_courseID")     || "";
+	my $archive_sql_host     = $r->param("archive_sql_host")     || "";
+	my $archive_sql_port     = $r->param("archive_sql_port")     || "";
+	my $archive_sql_username = $r->param("archive_sql_username") || "";
+	my $archive_sql_password = $r->param("archive_sql_password") || "";
+	my $archive_sql_database = $r->param("archive_sql_database") || "";
+	
+	my @errors;
+	
+	if ($archive_courseID eq "") {
+		push @errors, "You must specify a course name.";
+	} elsif ($archive_courseID eq $urlpath->arg("courseID")) {
+		push @errors, "You cannot archive the course you are currently using.";
+	}
+	
+	my $ce2 = WeBWorK::CourseEnvironment->new(
+		$ce->{webworkDirs}->{root},
+		$ce->{webworkURLs}->{root},
+		$ce->{pg}->{directories}->{root},
+		$archive_courseID,
+	);
+	
+	if ($ce2->{dbLayoutName} eq "sql") {
+		push @errors, "You must specify the SQL admin username." if $archive_sql_username eq "";
+		#push @errors, "You must specify the SQL admin password." if $archive_sql_password eq "";
+		#push @errors, "You must specify the SQL database name." if $archive_sql_database eq "";
+	}
+	
+	return @errors;
+}
+
+sub archive_course_confirm {
+	my ($self) = @_;
+	my $r = $self->r;
+	my $ce = $r->ce;
+	#my $db = $r->db;
+	#my $authz = $r->authz;
+	#my $urlpath = $r->urlpath;
+	
+	print CGI::h2("archive Course");
+	
+	my $archive_courseID     = $r->param("archive_courseID")     || "";
+	my $archive_sql_host     = $r->param("archive_sql_host")     || "";
+	my $archive_sql_port     = $r->param("archive_sql_port")     || "";
+	my $archive_sql_database = $r->param("archive_sql_database") || "";
+	
+	my $ce2 = WeBWorK::CourseEnvironment->new(
+		$ce->{webworkDirs}->{root},
+		$ce->{webworkURLs}->{root},
+		$ce->{pg}->{directories}->{root},
+		$archive_courseID,
+	);
+	
+	if ($ce2->{dbLayoutName} eq "sql") {
+		print CGI::p("Are you sure you want to archive the course " . CGI::b($archive_courseID)
+		. "? All course files and data and the following database will be destroyed."
+		. " There is no undo available.");
+		
+		print CGI::table({class=>"FormLayout"},
+			CGI::Tr(
+				CGI::th({class=>"LeftHeader"}, "SQL Server Host:"),
+				CGI::td($archive_sql_host || "system default"),
+			),
+			CGI::Tr(
+				CGI::th({class=>"LeftHeader"}, "SQL Server Port:"),
+				CGI::td($archive_sql_port || "system default"),
+			),
+			CGI::Tr(
+				CGI::th({class=>"LeftHeader"}, "SQL Database Name:"),
+				CGI::td($archive_sql_database || "webwork_$archive_courseID"),
+			),
+		);
+	} else {
+		print CGI::p("Are you sure you want to archive the course " . CGI::b($archive_courseID)
+			. "? All course files and data will be destroyed. There is no undo available.");
+	}
+	
+	print CGI::start_form("POST", $r->uri);
+	print $self->hidden_authen_fields;
+	print $self->hidden_fields("subDisplay");
+	print $self->hidden_fields(qw/archive_courseID archive_sql_host archive_sql_port archive_sql_username archive_sql_password archive_sql_database/);
+	
+	print CGI::p({style=>"text-align: center"},
+		CGI::submit("decline_archive_course", "Don't archive"),
+		" ",
+		CGI::submit("confirm_archive_course", "archive"),
+	);
+	
+	print CGI::end_form();
+}
 
+sub do_archive_course {
+	my ($self) = @_;
+	my $r = $self->r;
+	my $ce = $r->ce;
+	#my $db = $r->db;
+	#my $authz = $r->authz;
+	#my $urlpath = $r->urlpath;
+	
+	my $archive_courseID     = $r->param("archive_courseID")     || "";
+	my $archive_sql_host     = $r->param("archive_sql_host")     || "";
+	my $archive_sql_port     = $r->param("archive_sql_port")     || "";
+	my $archive_sql_username = $r->param("archive_sql_username") || "";
+	my $archive_sql_password = $r->param("archive_sql_password") || "";
+	my $archive_sql_database = $r->param("archive_sql_database") || "";
+	
+	my $ce2 = WeBWorK::CourseEnvironment->new(
+		$ce->{webworkDirs}->{root},
+		$ce->{webworkURLs}->{root},
+		$ce->{pg}->{directories}->{root},
+		$archive_courseID,
+	);
+	
+	my %dbOptions;
+	if ($ce2->{dbLayoutName} eq "sql") {
+		$dbOptions{host}     = $archive_sql_host if $archive_sql_host ne "";
+		$dbOptions{port}     = $archive_sql_port if $archive_sql_port ne "";
+		$dbOptions{username} = $archive_sql_username;
+		$dbOptions{password} = $archive_sql_password;
+		$dbOptions{database} = $archive_sql_database || "webwork_$archive_courseID";
+	}
+	
+	eval {
+		archiveCourse(
+			courseID => $archive_courseID,
+			ce => $ce2,
+			dbOptions => \%dbOptions,
+		);
+	};
+	
+	if ($@) {
+		my $error = $@;
+		print CGI::div({class=>"ResultsWithError"},
+			CGI::p("An error occured while archiving the course $archive_courseID:"),
+			CGI::tt(CGI::escapeHTML($error)),
+		);
+	} else {
+		print CGI::div({class=>"ResultsWithoutError"},
+			CGI::p("Successfully archived the course $archive_courseID"),
+		);
+		 writeLog($ce, "hosted_courses", join("\t",
+	    	"\tarchived",
+	    	"",
+	    	"",
+	    	$archive_courseID,
+	    ));
+		print CGI::start_form("POST", $r->uri);
+		print $self->hidden_authen_fields;
+		print $self->hidden_fields("subDisplay");
+		
+		print CGI::p({style=>"text-align: center"}, CGI::submit("decline_archive_course", "OK"),);
+		
+		print CGI::end_form();
+	}
+}
+
+################################################################################
 1;

[WWcvs] webwork-modperl: Eliminate extra insetting of tables within the results

[dpvc v. a. <we...@ma...>]

Log Message:
-----------
Eliminate extra insetting of tables within the results area (e.g.,
tables produced by the matrix array answer checkers).

Modified Files:
--------------
    webwork-modperl/htdocs/css:
        ur.css

Revision Data
-------------
Index: ur.css
===================================================================
RCS file: /webwork/cvs/system/webwork-modperl/htdocs/css/ur.css,v
retrieving revision 1.7
retrieving revision 1.8
diff -Lhtdocs/css/ur.css -Lhtdocs/css/ur.css -u -r1.7 -r1.8
--- htdocs/css/ur.css
+++ htdocs/css/ur.css
@@ -128,6 +128,8 @@
 /*
  * override above settings in tables used to display ans_array results
  */
+table.attemptResults td td,
+table.attemptResults td th,
 table.ArrayLayout td {
 	border-style: none; 
 	border-width: 0px; 

[WWcvs] webwork-modperl: Added mising ';' in viewOptions

[dpvc v. a. <we...@ma...>]

Log Message:
-----------
Added mising ';' in viewOptions

Modified Files:
--------------
    webwork-modperl/htdocs/css:
        ur.css

Revision Data
-------------
Index: ur.css
===================================================================
RCS file: /webwork/cvs/system/webwork-modperl/htdocs/css/ur.css,v
retrieving revision 1.6
retrieving revision 1.7
diff -Lhtdocs/css/ur.css -Lhtdocs/css/ur.css -u -r1.6 -r1.7
--- htdocs/css/ur.css
+++ htdocs/css/ur.css
@@ -47,7 +47,7 @@
 div.Message { font-style: italic; }
 div.Body {  }
 div.Warnings {  }
-div.viewOptions { border: thin groove; padding: 1ex; margin: 2ex align: left; }
+div.viewOptions { border: thin groove; padding: 1ex; margin: 2ex; align: left; }
 
 /* background colors for success and failure messages */
 div.ResultsWithoutError { background-color: #66ff99 } /* light green */

[WWcvs] pg: Added methods for testing containment of one set in another, and so

[dpvc v. a. <we...@ma...>]

Log Message:
-----------
Added methods for testing containment of one set in another, and so
on.  These include:

     $A->contains($B)        Test if $B is a subset of $A (or an
                             element of $A if $B$ is a real number).

     $A->isSubsetOf($B)      Test if $A is a subset of $B.

     $A->isEmpty             True if $A is the empty set.

     $A->intersects($B)      True if $A and $B have numbers in common.

     $A->intersect($B)       The set of numbers common to both $A and $B.

Be careful of the difference between "intersect" and "intersects".
One is a set the other a true/false value.

Modified Files:
--------------
    pg/lib/Value:
        Interval.pm
        Set.pm
        Union.pm

Revision Data
-------------
Index: Set.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Set.pm,v
retrieving revision 1.8
retrieving revision 1.9
diff -Llib/Value/Set.pm -Llib/Value/Set.pm -u -r1.8 -r1.9
--- lib/Value/Set.pm
+++ lib/Value/Set.pm
@@ -118,8 +118,12 @@
   my @l = $_[0]->sort->value; my @r = $_[1]->sort->value;
   my @entries = ();
   while (scalar(@l) && scalar(@r)) {
-    if ($l[0] < $r[0]) {push(@entries,shift(@l))}
-      else {while ($l[0] == $r[0]) {shift(@l)}; shift(@r)}
+    if ($l[0] < $r[0]) {
+      push(@entries,shift(@l));
+    } else {
+      while ($l[0] == $r[0]) {shift(@l); last if scalar(@l) == 0};
+      shift(@r);
+    }
   }
   push(@entries,@l);
   return () unless scalar(@entries);
@@ -131,9 +135,9 @@
 #    (returns a collection of intervals)
 #
 sub subIntervalSet {
-  my $I = shift; my $S = shift;
+  my $I = (shift)->copy; my $S = shift;
   my @union = (); my ($a,$b) = $I->value;
-  foreach my $x ($S->value) {
+  foreach my $x ($S->reduce->value) {
     next if $x < $a;
     if ($x == $a) {
       return @union if $a == $b;
@@ -227,6 +231,34 @@
   return $self->make(CORE::sort {$a <=> $b} $self->value);
 }
 
+
+#
+#  Tests for containment, subsets, etc.
+#
+
+sub contains {
+  my $self = shift; my $other = promote(shift)->reduce;
+  return unless $other->type eq 'Set';
+  return ($other-$self)->isEmpty;
+}
+
+sub isSubsetOf {
+  my $self = shift; my $other = promote(shift);
+  return $other->contains($self);
+}
+
+sub isEmpty {(shift)->length == 0}
+
+sub intersect {
+  my $self = shift; my $other = shift;
+  return $self-($self-$other);
+}
+
+sub intersects {
+  my $self = shift; my $other = shift;
+  return !$self->intersect($other)->isEmpty;
+}
+
 ###########################################################################
 
 1;
Index: Interval.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Interval.pm,v
retrieving revision 1.26
retrieving revision 1.27
diff -Llib/Value/Interval.pm -Llib/Value/Interval.pm -u -r1.26 -r1.27
--- lib/Value/Interval.pm
+++ lib/Value/Interval.pm
@@ -182,7 +182,7 @@
 #     or nothing for emtpy set)
 #
 sub subIntervalInterval {
-  my ($l,$r) = @_;
+  my ($l,$r) = @_; $l = $l->copy; $r = $r->copy;
   my ($a,$b) = $l->value; my ($c,$d) = $r->value;
   my @union = ();
   if ($d <= $a) {
@@ -235,6 +235,33 @@
 sub isReduced {1}
 sub sort {shift}
 
+
+#
+#  Tests for containment, subsets, etc.
+#
+
+sub contains {
+  my $self = shift; my $other = promote(shift);
+  return ($other - $self)->isEmpty;
+}
+
+sub isSubsetOf {
+  my $self = shift; my $other = promote(shift);
+  return $other->contains($self);
+}
+
+sub isEmpty {0}
+
+sub intersect {
+  my $self = shift; my $other = shift;
+  return $self-($self-$other);
+}
+
+sub intersects {
+  my $self = shift; my $other = shift;
+  return !$self->intersect($other)->isEmpty;
+}
+
 ###########################################################################
 
 1;
Index: Union.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Union.pm,v
retrieving revision 1.22
retrieving revision 1.23
diff -Llib/Value/Union.pm -Llib/Value/Union.pm -u -r1.22 -r1.23
--- lib/Value/Union.pm
+++ lib/Value/Union.pm
@@ -126,7 +126,7 @@
   my ($l,$r,$flag) = @_;
   if ($l->promotePrecedence($r)) {return $r->add($l,!$flag)}
   $r = promote($r); if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
-  form(@{$l->data},@{$r->data});
+  form($l->value,$r->value);
 }
 sub dot {my $self = shift; $self->add(@_)}
 
@@ -137,6 +137,8 @@
   my ($l,$r,$flag) = @_;
   if ($l->promotePrecedence($r)) {return $r->sub($l,!$flag)}
   $r = promote($r); if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
+  $l = $l->reduce; $l = $pkg->make($l) unless $l->type eq 'Union';
+  $r = $r->reduce; $r = $pkg->make($r) unless $r->type eq 'Union';
   form(subUnionUnion($l->data,$r->data));
 }
 
@@ -204,7 +206,7 @@
   foreach my $x ($self->value) {
     if ($x->type eq 'Set') {push(@singletons,$x->value)}
     elsif ($x->{data}[0] == $x->{data}[1]) {push(@singletons,$x->{data}[0])}
-    else {push(@intervals,$x)}
+    else {push(@intervals,$x->copy)}
   }
   my @union = (); my @set = (); my $prevX;
   @intervals = (CORE::sort {$a <=> $b} @intervals);
@@ -261,6 +263,36 @@
   $self->make(CORE::sort {$a <=> $b} $self->value);
 }
 
+
+#
+#  Tests for containment, subsets, etc.
+#
+
+sub contains {
+  my $self = shift; my $other = promote(shift);
+  return ($other - $self)->isEmpty;
+}
+
+sub isSubsetOf {
+  my $self = shift; my $other = promote(shift);
+  return $other->contains($self);
+}
+
+sub isEmpty {
+  my $self = (shift)->reduce;
+  $self->type eq 'Set' && $self->isEmpty;
+}
+
+sub intersect {
+  my $self = shift; my $other = shift;
+  return $self-($self-$other);
+}
+
+sub intersects {
+  my $self = shift; my $other = shift;
+  return !$self->intersect($other)->isEmpty;
+}
+
 ############################################
 #
 #  Generate the various output formats

[WWcvs] pg: Added a copy method that produces a deep copy of the given object.

[dpvc v. a. <we...@ma...>]

Log Message:
-----------
Added a copy method that produces a deep copy of the given object.
This probably should be used through the new() methods to ducplicate
the data used when creating an object, otherwise changes to the
sub-objects will cause changes to the outer one.  For example, if an
interval is used to create a union and then the internal data for the
interval is changed by hand, the changes will also occur in the
union.  That is, Value objects contain their data by REFERENCE.  This
should probably be changed, but fortunately, no one should be
adjusting the internal structure of the objects by hand.

Modified Files:
--------------
    pg/lib:
        Value.pm

Revision Data
-------------
Index: Value.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value.pm,v
retrieving revision 1.45
retrieving revision 1.46
diff -Llib/Value.pm -Llib/Value.pm -u -r1.45 -r1.46
--- lib/Value.pm
+++ lib/Value.pm
@@ -114,6 +114,13 @@
   return shift;
 }
 
+sub copy {
+  my $self = shift;
+  my $copy = {%{$self}}; $copy->{data} = [@{$self->{data}}];
+  foreach my $x (@{$copy->{data}}) {$x = $x->copy if Value::isValue($x)}
+  return bless $copy, ref($self);
+}
+
 #############################################################
 
 #

[WWcvs] pg: Added canBeInUnion and isSetOfReals methods to the Parser package

[dpvc v. a. <we...@ma...>]

Log Message:
-----------
Added canBeInUnion and isSetOfReals methods to the Parser package
(similar to the ones in the Value package), replacing the
canBeInterval flag and other ad hoc checks.

Removed ability to form interval like [a] now that we have sets.

Modified Files:
--------------
    pg/lib/Parser:
        Constant.pm
        Item.pm
        List.pm
        Value.pm
    pg/lib/Parser/BOP:
        subtract.pm
        union.pm
    pg/lib/Parser/List:
        Interval.pm
        List.pm
        Set.pm
    pg/lib/Value:
        Formula.pm

Revision Data
-------------
Index: Value.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/Value.pm,v
retrieving revision 1.16
retrieving revision 1.17
diff -Llib/Parser/Value.pm -Llib/Parser/Value.pm -u -r1.16 -r1.17
--- lib/Parser/Value.pm
+++ lib/Parser/Value.pm
@@ -47,15 +47,14 @@
 sub check {
   my $self = shift;
   my $type = $self->{type}; my $value = $self->{value};
-  $self->{canBeInterval} = $value->canBeInUnion;
   $self->{isZero} = $value->isZero;
   $self->{isOne}  = $value->isOne;
 }
 
 #
-#  Return the Value.pm object
+#  Return the Value object
 #
-sub eval {return (shift)->{value}}
+sub eval {(shift)->{value}}
 
 #
 #  Call the Value object's reduce method and reset the flags
@@ -68,6 +67,11 @@
 }
 
 #
+#  Pass on the request to the Value object
+#
+sub canBeInUnion {(shift)->{value}->canBeInUnion}
+
+#
 #  Return the item's list of coordinates
 #    (for points, vectors, matrices, etc.)
 #
@@ -96,8 +100,6 @@
 sub perl {
   my $self = shift; my $parens = shift; my $matrix = shift;
   my $perl = $self->{value}->perl(0,$matrix);
-  $perl = "(($perl)->with(open=>'$self->{open}',close=>'$self->{close}'))"
-    if $self->{canBeInterval} && $self->{open}.$self->{close} eq '[]';
   $perl = '('.$perl.')' if $parens;
   return $perl;
 }
Index: List.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/List.pm,v
retrieving revision 1.15
retrieving revision 1.16
diff -Llib/Parser/List.pm -Llib/Parser/List.pm -u -r1.15 -r1.16
--- lib/Parser/List.pm
+++ lib/Parser/List.pm
@@ -31,8 +31,7 @@
   if ($paren && $close && $paren->{formInterval}) {
     $paren = $parens->{interval}
       if ($paren->{close} ne $close || (scalar(@{$coords}) == 2 &&
-           ($coords->[0]->{isInfinite} || $coords->[1]->{isInfinite})) ||
-           (scalar(@{$coords}) == 1 && $coords->[0]->{isInfinite}));
+           ($coords->[0]->{isInfinite} || $coords->[1]->{isInfinite})));
   }
   my $type = Value::Type($paren->{type},scalar(@{$coords}),$entryType,
                                 list => 1, formMatrix => $paren->{formMatrix});
@@ -54,28 +53,24 @@
   foreach my $x (@{$coords}) {$zero = 0, last unless $x->{isZero}}
   $list->{isZero} = 1 if $zero && scalar(@{$coords}) > 0;
 
-  $list->checkInterval;
   $list->_check;
 
 #  warn ">> $list->{type}{name} of $list->{type}{entryType}{name} of length $list->{type}{length}\n";
 
   if ($list->{isConstant} && $context->flag('reduceConstants')) {
-    my $saveCBI = $list->{canBeInterval}; $type = $list->{type};
+    $type = $list->{type};
     $list = $context->{parser}{Value}->new($equation,[$list->eval]);
     $list->{type} = $type; $list->{open} = $open; $list->{close} = $close;
     $list->{value}->{open} = $open, $list->{value}->{close} = $close
       if ref($list->{value});
-    $list->{canBeInterval} = $saveCBI if $saveCBI;
   }
   return $list;
 }
 
-sub checkInterval {
+sub canBeInUnion {
   my $self = shift;
-  if ((($self->{open} eq '(' || $self->{open} eq '[') &&
-       ($self->{close} eq ')' || $self->{close} eq ']') && $self->length == 2) ||
-      ($self->{open}.$self->{close} eq '[]' && $self->length == 1))
-          {$self->{canBeInterval} = 1}
+  $self->length == 2 && $self->typeRef->{entryType}{name} eq 'Number' &&
+    $self->{open} =~ m/^[\(\[]$/ && $self->{close} =~ m/^[\)\]]$/;
 }
 
 sub _check {}
@@ -228,8 +223,9 @@
   my $perl; my @p = ();
   foreach my $x (@{$self->{coords}}) {push(@p,$x->perl)}
   $perl = 'new Value::'.$self->type.'('.join(',',@p).')';
-  $perl = "${perl}->with(open=>'$self->{open}',close=>'$self->{close}')"
-    if $self->{canBeInterval} && $self->{open}.$self->{close} eq '[]';
+  $perl = "(${perl})->with(open=>'$self->{open}',close=>'$self->{close}')"
+    if $self->canBeInUnion ||
+      ($self->type eq 'List' && $self->{open}.$self->{close} ne '()');
   $perl = '('.$perl.')' if $parens;
   return $perl;
 }
Index: Constant.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/Constant.pm,v
retrieving revision 1.8
retrieving revision 1.9
diff -Llib/Parser/Constant.pm -Llib/Parser/Constant.pm -u -r1.8 -r1.9
--- lib/Parser/Constant.pm
+++ lib/Parser/Constant.pm
@@ -24,8 +24,6 @@
     ref => $ref, equation => $equation
   }, $class;
   $c->{isConstant} = 1 if $const->{isConstant};
-  $c->{canBeInterval} = 1
-    if Value::isValue($const->{value}) && $const->{value}{canBeInterval};
   return $c;
 }
 
@@ -47,6 +45,14 @@
 }
 
 #
+#  Use constant to tell if it can be in a union
+#
+sub canBeInUnion {
+  my $self = shift;
+  Value::isValue($self->{def}{value}) && $self->{def}{value}->canBeInUnion;
+}
+
+#
 #  Return the constant's name
 #
 sub string {(shift)->{name}}
Index: Item.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/Item.pm,v
retrieving revision 1.7
retrieving revision 1.8
diff -Llib/Parser/Item.pm -Llib/Parser/Item.pm -u -r1.7 -r1.8
--- lib/Parser/Item.pm
+++ lib/Parser/Item.pm
@@ -61,6 +61,13 @@
 }
 
 #
+#  Check if an item can be in a union or is a set or reals
+#    (overridden in subclasses)
+#
+sub canBeInUnion {0}
+sub isSetOfReals {(shift)->type =~ m/^(Interval|Union|Set)$/}
+
+#
 #  Add parens to an expression (alternating the type of paren)
 #
 sub addParens {
Index: union.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/BOP/union.pm,v
retrieving revision 1.8
retrieving revision 1.9
diff -Llib/Parser/BOP/union.pm -Llib/Parser/BOP/union.pm -u -r1.8 -r1.9
--- lib/Parser/BOP/union.pm
+++ lib/Parser/BOP/union.pm
@@ -14,14 +14,13 @@
 sub _check {
   my $self = shift;
   return if ($self->checkStrings());
-  if ($self->{lop}{canBeInterval} && $self->{rop}{canBeInterval}) {
+  if ($self->{lop}->canBeInUnion && $self->{rop}->canBeInUnion) {
     $self->{type} = Value::Type('Union',2,$Value::Type{number});
-    $self->{canBeInterval} = 1;
     foreach my $op ('lop','rop') {
-      if ($self->{$op}->type !~ m/^(Interval|Union|Set)$/) {
+      if (!$self->{$op}->isSetOfReals) {
 	if ($self->{$op}->class eq 'Value') {
 	  $self->{$op}{value} = Value::Interval::promote($self->{$op}{value});
-	} else {
+	} else  {
 	  $self->{$op} = bless $self->{$op}, 'Parser::List::Interval';
 	}
 	$self->{$op}->typeRef->{name} = $self->{equation}{context}{parens}{interval}{type};
@@ -30,6 +29,8 @@
   } else {$self->Error("Operands of '%s' must be intervals or sets",$self->{bop})}
 }
 
+sub canBeInUnion {(shift)->type eq 'Union'}
+
 
 #
 #  Make a union of the two operands.
Index: subtract.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/BOP/subtract.pm,v
retrieving revision 1.6
retrieving revision 1.7
diff -Llib/Parser/BOP/subtract.pm -Llib/Parser/BOP/subtract.pm -u -r1.6 -r1.7
--- lib/Parser/BOP/subtract.pm
+++ lib/Parser/BOP/subtract.pm
@@ -14,13 +14,11 @@
   return if ($self->checkStrings());
   return if ($self->checkLists());
   return if ($self->checkNumbers());
-  if ($self->{lop}{canBeInterval} && $self->{rop}{canBeInterval}) {
-    if ($self->{lop}->type =~ m/Interval|Union|Set/ ||
-	$self->{rop}->type =~ m/Interval|Union|Set/) {
+  if ($self->{lop}->canBeInUnion && $self->{rop}->canBeInUnion) {
+    if ($self->{lop}->isSetOfReals || $self->{rop}->isSetOfReals) {
       $self->{type} = Value::Type('Union',2,$Value::Type{number});
-      $self->{canBeInterval} = 1;
       foreach my $op ('lop','rop') {
-	if ($self->{$op}->type !~ m/Interval|Union|Set/) {
+	if (!$self->{$op}->isSetOfReals) {
 	  if ($self->{$op}->class eq 'Value') {
 	    $self->{$op}{value} = Value::Interval::promote($self->{$op}{value});
 	  } else {
@@ -37,6 +35,8 @@
   else {$self->matchError($ltype,$rtype)}
 }
 
+sub canBeInUnion {(shift)->type eq 'Union'}
+
 #
 #  Do subtraction
 #
Index: Set.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/List/Set.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -Llib/Parser/List/Set.pm -Llib/Parser/List/Set.pm -u -r1.1 -r1.2
--- lib/Parser/List/Set.pm
+++ lib/Parser/List/Set.pm
@@ -17,10 +17,7 @@
   }
 }
 
-sub checkInterval {
-  my $self = shift;
-  $self->{canBeInterval} = 1;
-}
+sub canBeInUnion {1}
 
 #########################################################################
 
Index: List.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/List/List.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -Llib/Parser/List/List.pm -Llib/Parser/List/List.pm -u -r1.3 -r1.4
--- lib/Parser/List/List.pm
+++ lib/Parser/List/List.pm
@@ -23,4 +23,3 @@
 #########################################################################
 
 1;
-
Index: Interval.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/List/Interval.pm,v
retrieving revision 1.7
retrieving revision 1.8
diff -Llib/Parser/List/Interval.pm -Llib/Parser/List/Interval.pm -u -r1.7 -r1.8
--- lib/Parser/List/Interval.pm
+++ lib/Parser/List/Interval.pm
@@ -13,22 +13,21 @@
 sub _check {
   my $self = shift;
   my $length = $self->{type}{length}; my $coords = $self->{coords};
-  $self->Error("Intervals can have only two endpoints") if ($length > 2);
-  $self->Error("Intervals must have at least one endpoint") if ($length == 0);
+  $self->Error("Intervals can have only two endpoints") if $length > 2;
+  $self->Error("Intervals must have two endpoints") if $length < 2;
   $self->Error("Coordinates of intervals can only be numbers or infinity")
-    if !$coords->[0]->isNumOrInfinity ||
-       ($length == 2 && !$coords->[1]->isNumOrInfinity);
-  $self->Error("Infinite intervals require two endpoints")
-    if ($length == 1 && $coords->[0]{isInfinite});
+    if !$coords->[0]->isNumOrInfinity || !$coords->[1]->isNumOrInfinity;
   $self->Error("The left endpoint of an interval can't be positive infinity")
-    if ($coords->[0]{isInfinity});
+    if $coords->[0]{isInfinity};
   $self->Error("The right endpoint of an interval can't be negative infinity")
-    if ($length == 2 && $coords->[1]{isNegativeInfinity});
+    if $coords->[1]{isNegativeInfinity};
   $self->Error("Infinite endpoints must be open")
     if ($self->{open} ne '(' && $coords->[0]{isInfinite}) ||
-       ($self->{close} ne ')' && $length == 2 && $coords->[1]{isInfinite});
+       ($self->{close} ne ')' && $coords->[1]{isInfinite});
 }
 
+sub canBeInUnion {1}
+
 #
 #  Use the Value.pm class to produce the result
 #
Index: Formula.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Formula.pm,v
retrieving revision 1.35
retrieving revision 1.36
diff -Llib/Value/Formula.pm -Llib/Value/Formula.pm -u -r1.35 -r1.36
--- lib/Value/Formula.pm
+++ lib/Value/Formula.pm
@@ -71,7 +71,7 @@
 sub isZero {(shift)->{tree}{isZero}}
 sub isOne {(shift)->{tree}{isOne}}
 
-sub isSetOfReals {(shift)->type =~ m/Interval|Set|Union/}
+sub isSetOfReals {(shift)->{tree}->isSetOfReals}
 sub canBeInUnion {(shift)->{tree}->canBeInUnion}
 
 ############################################

[WWcvs] pg: Maintain parentheses correctly when converting to perl.

[dpvc v. a. <we...@ma...>]

Log Message:
-----------
Maintain parentheses correctly when converting to perl.

Modified Files:
--------------
    pg/lib:
        Value.pm

Revision Data
-------------
Index: Value.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value.pm,v
retrieving revision 1.44
retrieving revision 1.45
diff -Llib/Value.pm -Llib/Value.pm -u -r1.44 -r1.45
--- lib/Value.pm
+++ lib/Value.pm
@@ -548,6 +548,8 @@
     $perl = '['.$perl.']' if $mtype > 0;
   } else {
     $perl = 'new '.ref($self).'('.join(',',@p).')';
+    $perl = "($perl)->with(open=>'$self->{open}',close=>'$self->{close}')"
+      if $class eq 'List' && $self->{open}.$self->{close} ne '()';
     $perl = '('.$perl.')' if $parens == 1;
   }
   return $perl;

[WWcvs] webwork-modperl: Add style for comments originating from COMMENT() and

[jj v. a. <we...@ma...>]

Log Message:
-----------
Add style for comments originating from COMMENT() and rendered in the
Library browser.

Modified Files:
--------------
    webwork-modperl/htdocs/css:
        ur.css

Revision Data
-------------
Index: ur.css
===================================================================
RCS file: /webwork/cvs/system/webwork-modperl/htdocs/css/ur.css,v
retrieving revision 1.5
retrieving revision 1.6
diff -Lhtdocs/css/ur.css -Lhtdocs/css/ur.css -u -r1.5 -r1.6
--- htdocs/css/ur.css
+++ htdocs/css/ur.css
@@ -92,6 +92,7 @@
 
 /* for problems which are rendered by themselves, e.g., by Set Maker */
 div.RenderSolo { background-color: #E0E0E0; color: black; }
+div.AuthorComment { background-color: #00E0E0; color: black; }
 
 /* minimal style for lists of links (generated by the links escape) */
 ul.LinksMenu { list-style: none; margin-left: 0; padding-left: 0; }

[WWcvs] pg: Implimentation of COMMENT for comments to appear in the library

[jj v. a. <we...@ma...>]

Log Message:
-----------
Implimentation of COMMENT for comments to appear in the library browser.

Modified Files:
--------------
    pg/macros:
        PG.pl
        PGbasicmacros.pl

Revision Data
-------------
Index: PGbasicmacros.pl
===================================================================
RCS file: /webwork/cvs/system/pg/macros/PGbasicmacros.pl,v
retrieving revision 1.38
retrieving revision 1.39
diff -Lmacros/PGbasicmacros.pl -Lmacros/PGbasicmacros.pl -u -r1.38 -r1.39
--- macros/PGbasicmacros.pl
+++ macros/PGbasicmacros.pl
@@ -44,6 +44,7 @@
 	$SOL,
 	$SOLUTION,
 	$HINT,
+	$COMMENT,
 	$US,
 	$SPACE,
 	$BBOLD,
@@ -976,6 +977,31 @@
 # End hints and solutions macros
 #################################
 
+=head2 Comments to instructors
+
+	COMMENT('text','text2',...);
+
+Takes the text to be lines of a comment to be shown only 
+in the Library Browser below the rendered problem.
+
+The function COMMENT stores the needed html in the variable
+pgComment, which gets transfered to the flag 'comment' in PG_FLAGS.
+
+=cut
+
+# Add a comment which will display in the Library browser
+#  Currently, the only output is html
+
+sub COMMENT {
+   	my @in = @_;
+	my $out = join("$BR", @in);
+	my $out = '<div class=\"AuthorComment\">'.$out.'</div>';
+
+	PG_restricted_eval(q!$main::pgComment = "!.$out.q!"!);
+	return('');
+}
+
+#################################
 #	Produces a random number between $begin and $end with increment 1.
 #	You do not have to worry about integer or floating point types.
 
Index: PG.pl
===================================================================
RCS file: /webwork/cvs/system/pg/macros/PG.pl,v
retrieving revision 1.21
retrieving revision 1.22
diff -Lmacros/PG.pl -Lmacros/PG.pl -u -r1.21 -r1.22
--- macros/PG.pl
+++ macros/PG.pl
@@ -137,6 +137,7 @@
 	$main::showHint = 1 unless defined($main::showHint);
 	$main::solutionExists =0;
 	$main::hintExists =0;
+	$main::pgComment = '';
 	%main::gifs_created = ();
 	
     !);
@@ -446,9 +447,10 @@
 	    images are not used).
 	(4) solutionExits   -- indicates the existence of a solution.
 	(5) hintExits   -- indicates the existence of a hint.
-	(6) showHintLimit -- determines the number of attempts after which hint(s) will be shown
+	(6) comment   -- contents of COMMENT commands if any.
+	(7) showHintLimit -- determines the number of attempts after which hint(s) will be shown
 
-	(7) PROBLEM_GRADER_TO_USE -- chooses the problem grader to be used in this order
+	(8) PROBLEM_GRADER_TO_USE -- chooses the problem grader to be used in this order
 		(a) A problem grader specified by the problem using:
 		    install_problem_grader(\&grader);
 		(b) One of the standard problem graders defined in PGanswermacros.pl when set to
@@ -478,6 +480,7 @@
 		$main::PG_FLAGS{'showPartialCorrectAnswers'} = $main::showPartialCorrectAnswers;
 		$main::PG_FLAGS{'recordSubmittedAnswers'} = $main::recordSubmittedAnswers;
 		$main::PG_FLAGS{'refreshCachedImages'} = $main::refreshCachedImages;
+		$main::PG_FLAGS{'comment'} = $main::pgComment;
 		$main::PG_FLAGS{'hintExists'} = $main::hintExists;
 		$main::PG_FLAGS{'showHintLimit'} = $main::showHint;
 		$main::PG_FLAGS{'solutionExists'} = $main::solutionExists;

[WWcvs] webwork-modperl: Print contents of COMMENT() commands in the Library

[jj v. a. <we...@ma...>]

Log Message:
-----------
Print contents of COMMENT() commands in the Library Browser.

Modified Files:
--------------
    webwork-modperl/lib/WeBWorK/ContentGenerator/Instructor:
        SetMaker.pm

Revision Data
-------------
Index: SetMaker.pm
===================================================================
RCS file: /webwork/cvs/system/webwork-modperl/lib/WeBWorK/ContentGenerator/Instructor/SetMaker.pm,v
retrieving revision 1.51
retrieving revision 1.52
diff -Llib/WeBWorK/ContentGenerator/Instructor/SetMaker.pm -Llib/WeBWorK/ContentGenerator/Instructor/SetMaker.pm -u -r1.51 -r1.52
--- lib/WeBWorK/ContentGenerator/Instructor/SetMaker.pm
+++ lib/WeBWorK/ContentGenerator/Instructor/SetMaker.pm
@@ -809,6 +809,7 @@
 	my $problem_output = $pg->{flags}->{error_flag} ?
 		CGI::div({class=>"ResultsWithError"}, CGI::em("This problem produced an error"))
 		: CGI::div({class=>"RenderSolo"}, $pg->{body_text});
+	$problem_output .= $pg->{flags}->{comment} if($pg->{flags}->{comment});
 
 
 	#if($self->{r}->param('browse_which') ne 'browse_library') {

[WWcvs] pg: Allow a list of numbers to be converted to a set.

[dpvc v. a. <we...@ma...>]

Log Message:
-----------
Allow a list of numbers to be converted to a set.

Modified Files:
--------------
    pg/lib/Value:
        Set.pm

Revision Data
-------------
Index: Set.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Set.pm,v
retrieving revision 1.7
retrieving revision 1.8
diff -Llib/Value/Set.pm -Llib/Value/Set.pm -u -r1.7 -r1.8
--- lib/Value/Set.pm
+++ lib/Value/Set.pm
@@ -30,7 +30,8 @@
   return $p if (Value::isFormula($p) && $p->type eq Value::class($self));
   my $pclass = Value::class($p); my $isFormula = 0;
   my @d; @d = $p->dimensions if $pclass eq 'Matrix';
-  if ($pclass =~ m/Point|Vector|Set/) {$p = $p->data}
+  if ($pclass eq 'List' && $p->typeRef->{entryType}{name} eq 'Number') {$p = $p->data}
+  elsif ($pclass =~ m/Point|Vector|Set/) {$p = $p->data}
   elsif ($pclass eq 'Matrix' && scalar(@d) == 1) {$p = [$p->value]}
   elsif ($pclass eq 'Matrix' && scalar(@d) == 2 && $d[0] == 1) {$p = ($p->value)[0]}
   elsif ($pclass eq 'Matrix' && scalar(@d) == 2 && $d[1] == 1) {$p = ($p->transpose->value)[0]}
@@ -76,6 +77,8 @@
   return $x if ref($x) eq $pkg;
   $x = Value::Interval::promote($x) if $x->canBeInUnion;
   return $x if $x->isSetOfReals;
+  return $pkg->new($x->value)
+    if $x->type eq 'List' && $x->typeRef->{entryType}{name} eq 'Number';
   Value::Error("Can't convert %s to a Set",Value::showClass($x));
 }
 

[WWcvs] pg: Pass the canBeInUnion call on to the Formula's root node

[dpvc v. a. <we...@ma...>]

Log Message:
-----------
Pass the canBeInUnion call on to the Formula's root node

Modified Files:
--------------
    pg/lib/Value:
        Formula.pm

Revision Data
-------------
Index: Formula.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Formula.pm,v
retrieving revision 1.34
retrieving revision 1.35
diff -Llib/Value/Formula.pm -Llib/Value/Formula.pm -u -r1.34 -r1.35
--- lib/Value/Formula.pm
+++ lib/Value/Formula.pm
@@ -72,6 +72,7 @@
 sub isOne {(shift)->{tree}{isOne}}
 
 sub isSetOfReals {(shift)->type =~ m/Interval|Set|Union/}
+sub canBeInUnion {(shift)->{tree}->canBeInUnion}
 
 ############################################
 #

[WWcvs] pg: Added isSetOfReals and canBeInUnion methods to the Value objects,

[dpvc v. a. <we...@ma...>]

Log Message:
-----------
Added isSetOfReals and canBeInUnion methods to the Value objects, and
replaced the ad hoc tests for these conditions to call these
routines.

Cleaned up the make() methods for Intervals, Sets and Unions, and
improved the new() methods to handle more cases better.

Fixed Value::makeValue() to handle an array reference correctly.

I don't THINK any of this will break anything.  :-)

Modified Files:
--------------
    pg/lib:
        Value.pm
    pg/lib/Parser:
        Value.pm
    pg/lib/Value:
        AnswerChecker.pm
        Interval.pm
        Set.pm
        Union.pm

Revision Data
-------------
Index: Value.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value.pm,v
retrieving revision 1.43
retrieving revision 1.44
diff -Llib/Value.pm -Llib/Value.pm -u -r1.43 -r1.44
--- lib/Value.pm
+++ lib/Value.pm
@@ -155,12 +155,19 @@
 
 sub isOne {0}
 
+sub isSetOfReals {0}
+sub canBeInUnion {
+  my $self = shift;
+  return $self->length == 2 && $self->typeRef->{entryType}{name} eq 'Number' &&
+    $self->{open} =~ m/^[\(\[]$/ && $self->{close} =~ m/^[\)\]]$/;
+}
+
 #
 #  Convert non-Value objects to Values, if possible
 #
 sub makeValue {
   my $x = shift; my %params = (showError => 0, makeFormula => 1, @_);
-  return $x if ref($x) || $x eq '';
+  return $x if (ref($x) && ref($x) ne 'ARRAY') || $x eq '';
   return Value::Real->make($x) if matchNumber($x);
   if (matchInfinite($x)) {
     my $I = Value::Infinity->new();
Index: Value.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/Value.pm,v
retrieving revision 1.15
retrieving revision 1.16
diff -Llib/Parser/Value.pm -Llib/Parser/Value.pm -u -r1.15 -r1.16
--- lib/Parser/Value.pm
+++ lib/Parser/Value.pm
@@ -47,10 +47,7 @@
 sub check {
   my $self = shift;
   my $type = $self->{type}; my $value = $self->{value};
-  $self->{canBeInterval} = 1 
-    if $value->{canBeInterval} ||
-       ($value->class =~ m/Point|List/ &&
-        $type->{length} == 2 && $type->{entryType}{name} eq 'Number');
+  $self->{canBeInterval} = $value->canBeInUnion;
   $self->{isZero} = $value->isZero;
   $self->{isOne}  = $value->isOne;
 }
Index: Set.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Set.pm,v
retrieving revision 1.6
retrieving revision 1.7
diff -Llib/Value/Set.pm -Llib/Value/Set.pm -u -r1.6 -r1.7
--- lib/Value/Set.pm
+++ lib/Value/Set.pm
@@ -45,8 +45,7 @@
   }
   return $self->formula($p) if $isFormula;
   my $def = $$Value::context->lists->get('Set');
-  my $set = bless {data => $p, canBeInterval => 1,
-    open => $def->{open}, close => $def->{close}}, $class;
+  my $set = bless {data => $p, open => $def->{open}, close => $def->{close}}, $class;
   $set = $set->reduce if $self->getFlag('reduceSets');
   return $set;
 }
@@ -58,7 +57,6 @@
   my $self = shift;
   my $def = $$Value::context->lists->get('Set');
   $self = $self->SUPER::make(@_);
-  $self->{canBeInterval} = 1;
   $self->{open} = $def->{open}; $self->{close} = $def->{close};
   return $self;
 }
@@ -66,14 +64,18 @@
 sub isOne {0}
 sub isZero {0}
 
+sub canBeInUnion {1}
+sub isSetOfReals {1}
+
 #
 #  Try to promote arbitrary data to a set
 #
 sub promote {
-  my $x = shift;
-  return $pkg->new($x,@_)
-    if scalar(@_) > 0 || ref($x) eq 'ARRAY' || Value::isRealNumber($x);
-  return $x if Value::class($x) =~ m/Interval|Union|Set/;
+  my $x = Value::makeValue(shift);
+  return $pkg->new($x,@_) if scalar(@_) > 0 || Value::isRealNumber($x);
+  return $x if ref($x) eq $pkg;
+  $x = Value::Interval::promote($x) if $x->canBeInUnion;
+  return $x if $x->isSetOfReals;
   Value::Error("Can't convert %s to a Set",Value::showClass($x));
 }
 
@@ -134,7 +136,7 @@
       return @union if $a == $b;
       $I->{open} = '(';
     } elsif ($x < $b) {
-      push(@union,Value::Interval->new($I->{open},$a,$x,')'));
+      push(@union,Value::Interval->make($I->{open},$a,$x,')'));
       $I->{open} = '('; $I->{data}[0] = $x;
     } else {
       $I->{close} = ')' if ($x == $b);
@@ -192,7 +194,7 @@
 #
 
 #
-#  Remove redundant values
+#  Remove repeated values
 #
 sub reduce {
   my $self = shift;
Index: AnswerChecker.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/AnswerChecker.pm,v
retrieving revision 1.59
retrieving revision 1.60
diff -Llib/Value/AnswerChecker.pm -Llib/Value/AnswerChecker.pm -u -r1.59 -r1.60
--- lib/Value/AnswerChecker.pm
+++ lib/Value/AnswerChecker.pm
@@ -199,7 +199,7 @@
   my $self = shift; my $ans = shift;
   my $class = $self->showClass; $class =~ s/Real //;
   return $class if $class =~ m/Formula/;
-  return "an Interval, Set or Union" if $class =~ m/Interval|Set|Union/i;
+  return "an Interval, Set or Union" if $self->isSetOfReals;
   return $class; 
 }
 
@@ -260,7 +260,7 @@
 	unless $R[$i] == $S[$i] && $R[$i]->length == $S[$i]->length;
     }
   } elsif ($student->type eq 'Set' && $student->length >= 2) {
-    return "Your$nth set should have no redundant elements"
+    return "Your$nth set should have no repeated elements"
       unless $student->reduce->length == $student->length;
   }
   return;
@@ -803,15 +803,10 @@
 
 sub typeMatch {
   my $self = shift; my $other = shift;
-  return 0 unless ref($other) && $other->class ne 'Formula';
-  return $other->length == 2 &&
-         ($other->{open} eq '(' || $other->{open} eq '[') &&
-         ($other->{close} eq ')' || $other->{close} eq ']')
-	   if $other->type =~ m/^(Point|List)$/;
-  $other->type =~ m/^(Interval|Union|Set)$/;
+  return 0 if !Value::isValue($other) || $other->isFormula;
+  return $other->canBeInUnion;
 }
 
-
 #
 #  Check for unreduced sets and unions
 #
@@ -851,12 +846,8 @@
 
 sub typeMatch {
   my $self = shift; my $other = shift;
-  return 0 unless ref($other) && $other->class ne 'Formula';
-  return $other->length == 2 &&
-         ($other->{open} eq '(' || $other->{open} eq '[') &&
-         ($other->{close} eq ')' || $other->{close} eq ']')
-	   if $other->type =~ m/^(Point|List)$/;
-  $other->type =~ m/^(Interval|Union|Set)/;
+  return 0 if !Value::isValue($other) || $other->isFormula;
+  return $other->canBeInUnion;
 }
 
 #
@@ -905,7 +896,7 @@
          ($other->{open} eq '(' || $other->{open} eq '[') &&
          ($other->{close} eq ')' || $other->{close} eq ']')
 	   if $other->type =~ m/^(Point|List)$/;
-  $other->type =~ m/^(Interval|Union|Set)/;
+  $other->isSetOfReals;
 }
 
 #
Index: Interval.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Interval.pm,v
retrieving revision 1.25
retrieving revision 1.26
diff -Llib/Value/Interval.pm -Llib/Value/Interval.pm -u -r1.25 -r1.26
--- lib/Value/Interval.pm
+++ lib/Value/Interval.pm
@@ -26,7 +26,7 @@
 #
 sub new {
   my $self = shift; my $class = ref($self) || $self;
-  if (scalar(@_) == 1 && !ref($_[0])) {
+  if (scalar(@_) == 1 && (!ref($_[0]) || ref($_[0]) eq 'ARRAY')) {
     my $x = Value::makeValue($_[0]);
     if (Value::isFormula($x)) {
       return $x if $x->type eq 'Interval';
@@ -34,13 +34,16 @@
     }
     return promote($x);
   }
-  my ($open,$a,$b,$close) = @_;
+  my @params = @_;
+  Value::Error("Interval can't be empty") unless scalar(@params) > 0;
+  Value::Error("Extra arguments for Interval()") if scalar(@params) > 4;
+  return Value::Set->new(@params) if scalar(@params) == 1;
+  @params = ('(',@params,')') if (scalar(@params) == 2);
+  my ($open,$a,$b,$close) = @params;
   if (!defined($close)) {$close = $b; $b = $a}
-  Value::Error("Interval() must be called with 3 or 4 arguments")
-    unless defined($open) && defined($a) && defined($b) && defined($close) && scalar(@_) <= 4;
   $a = Value::makeValue($a); $b = Value::makeValue($b);
   return $self->formula($open,$a,$b,$close) if Value::isFormula($a) || Value::isFormula($b);
-  Value::Error("Endpoints of intervals must be numbers on infinities") unless
+  Value::Error("Endpoints of intervals must be numbers or infinities") unless
     isNumOrInfinity($a) && isNumOrInfinity($b);
   my ($ia,$ib) = (isInfinity($a),isInfinity($b));
   my ($nia,$nib) = (isNegativeInfinity($a),isNegativeInfinity($b));
@@ -60,7 +63,6 @@
   bless {
     data => [$a,$b], open => $open, close => $close,
     leftInfinite => $nia, rightInfinite => $ib,
-    canBeInterval => 1,
   }, $class;
 }
 
@@ -74,7 +76,6 @@
   bless {
     data => [$a,$b], open => $open, close => $close,
     leftInfinite => isNegativeInfinity($a), rightInfinite => isInfinity($b),
-    canBeInterval => 1,
   }, $class
 }
 
@@ -114,6 +115,9 @@
 sub isOne {0}
 sub isZero {0}
 
+sub canBeInUnion {1}
+sub isSetOfReals {1}
+
 #
 #  Return the open and close parens as well as the endpoints
 #
@@ -136,16 +140,13 @@
 #  Convert points and lists to intervals, when needed
 #
 sub promote {
-  my $x = shift;
-  return $pkg->new($x,@_) if scalar(@_) > 0 || ref($x) eq 'ARRAY';
-  return $x if ref($x) eq $pkg;
-  $x = Value::makeValue($x);
+  my $x = Value::makeValue(shift);
+  return $pkg->new($x,@_) if scalar(@_) > 0;
+  return $x if $x->isSetOfReals;
   return Value::Set->new($x) if Value::class($x) eq 'Real';
   my $open  = $x->{open};  $open  = '(' unless defined($open);
   my $close = $x->{close}; $close = ')' unless defined($close);
-  return $pkg->new($open,$x->value,$close)
-    if Value::class($x) =~ m/^(Point|List)$/ && $x->length == 2 &&
-       ($open eq '(' || $open eq '[') && ($close eq ')' || $close eq ']');
+  return $pkg->new($open,$x->value,$close) if $x->canBeInUnion;
   Value::Error("Can't convert %s to an Interval",Value::showClass($x));
 }
 
@@ -192,18 +193,18 @@
     push(@union,$l) unless $a == $b && $l->{close} eq ')';
   } else {
     if ($a == $c) {
-      push(@union,Value::Set->new($a))
+      push(@union,Value::Set->make($a))
 	if $l->{open} eq '[' && $r->{open} eq '(';
     } elsif ($a < $c) {
       my $close = ($r->{open} eq '[')? ')': ']';
-      push(@union,Value::Interval->new($l->{open},$a,$c,$close));
+      push(@union,Value::Interval->make($l->{open},$a,$c,$close));
     }
     if ($d == $b) {
-      push(@union,Value::Set->new($b))
+      push(@union,Value::Set->make($b))
 	if $l->{close} eq ']' && $r->{close} eq ')';
     } elsif ($d < $b) {
       my $open = ($r->{close} eq ']') ? '(': '[';
-      push(@union,Value::Interval->new($open,$d,$b,$l->{close}));
+      push(@union,Value::Interval->make($open,$d,$b,$l->{close}));
     }
   }
   return @union;
Index: Union.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Union.pm,v
retrieving revision 1.21
retrieving revision 1.22
diff -Llib/Value/Union.pm -Llib/Value/Union.pm -u -r1.21 -r1.22
--- lib/Value/Union.pm
+++ lib/Value/Union.pm
@@ -33,28 +33,26 @@
     $x = promote($x); $x = $pkg->make($x) unless $x->type eq 'Union';
     return $x;
   }
-  Value::Error("Empty unions are not allowed") if scalar(@_) == 0;
   my @intervals = (); my $isFormula = 0;
   foreach my $xx (@_) {
-    my $x = $xx; $x = Value::makeValue($x);
-    if (Value::isFormula($x)) {
+    next if $xx eq ''; my $x = Value::makeValue($xx);
+    if ($x->isFormula) {
       $x->{tree}->typeRef->{name} = 'Interval'
 	if ($x->type =~ m/Point|List/ && $x->length == 2 &&
 	    $x->typeRef->{entryType}{name} eq 'Number');
-      if ($x->type =~ m/Interval|Set/) {push(@intervals,$x)}
-      elsif ($x->type eq 'Union') {push(@intervals,$x->{tree}->makeUnion)}
+      if ($x->type eq 'Union') {push(@intervals,$x->{tree}->makeUnion)}
+      elsif ($x->isSetOfReals) {push(@intervals,$x)}
       else {Value::Error("Unions can be taken only for Intervals and Sets")}
       $isFormula = 1;
     } else {
-      if (Value::class($x) eq 'Point' || Value::class($x) eq 'List') {
-        if ($x->length == 1) {$x = Value::Interval->new('[',$x->value,$x->value,']')}
-        elsif ($x->length == 2) {$x = Value::Interval->new($x->{open},$x->value,$x->{close})}
-      }
-      if (Value::class($x) =~ m/Interval|Set/) {push(@intervals,$x)}
-      elsif (Value::class($x) eq 'Union') {push(@intervals,@{$x->{data}})}
+      if ($x->type ne 'Interval' && $x->canBeInUnion) 
+        {$x = Value::Interval->new($x->{open},$x->value,$x->{close})}
+      if ($x->class eq 'Union') {push(@intervals,$x->value)}
+      elsif ($x->isSetOfReals) {push(@intervals,$x)}
       else {Value::Error("Unions can be taken only for Intervals or Sets")}
     }
   }
+  Value::Error("Empty unions are not allowed") if scalar(@intervals) == 0;
   return $self->formula(@intervals) if $isFormula;
   my $union = form(@intervals);
   $union = $self->make($union) unless $union->type eq 'Union';
@@ -62,16 +60,6 @@
 }
 
 #
-#  Set the canBeInterval flag
-#
-sub make {
-  my $self = shift;
-  $self = $self->SUPER::make(@_);
-  $self->{canBeInterval} = 1;
-  return $self;
-}
-
-#
 #  Make a union or interval or set, depending on how
 #  many there are in the union, and mark the
 #  
@@ -95,6 +83,9 @@
 sub isOne {0}
 sub isZero {0}
 
+sub canBeInUnion {1}
+sub isSetOfReals {1}
+
 #
 #  Recursively convert the list of intervals to a tree of unions
 #
@@ -115,12 +106,11 @@
 #  Try to promote arbitrary data to a set
 #
 sub promote {
-  my $x = shift;
-  return Value::Set->new($x,@_)
-    if scalar(@_) > 0 || ref($x) eq 'ARRAY' || Value::isRealNumber($x);
-  return $x if Value::class($x) eq 'Union';
-  $x = Value::Interval::promote($x) if Value::class($x) eq 'List';
-  return $pkg->make($x) if Value::class($x) =~ m/Interval|Set/;
+  my $x = Value::makeValue(shift);
+  return Value::Set->new($x,@_) if scalar(@_) > 0 || Value::isRealNumber($x);
+  return $x if ref($x) eq $pkg;
+  $x = Value::Interval::promote($x) if $x->canBeInUnion;
+  return $pkg->make($x) if Value::isValue($x) && $x->isSetOfReals;
   Value::Error("Can't convert %s to an Interval, Set or Union",Value::showClass($x));
 }
 

[WWcvs] pg: Make formulas that produce lists get default open and close parens,

[dpvc v. a. <we...@ma...>]

Log Message:
-----------
Make formulas that produce lists get default open and close parens,
and have them retained in Formula() results.

Modified Files:
--------------
    pg/lib:
        Parser.pm
    pg/lib/Value:
        Formula.pm

Revision Data
-------------
Index: Parser.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser.pm,v
retrieving revision 1.28
retrieving revision 1.29
diff -Llib/Parser.pm -Llib/Parser.pm -u -r1.28 -r1.29
--- lib/Parser.pm
+++ lib/Parser.pm
@@ -26,8 +26,9 @@
   my $context = Parser::Context->current;
   my $class = $context->{parser}{Formula};
   my $string = shift;
-  $string = Value::List->new($string,@_)
-    if scalar(@_) > 0 || ref($string) eq 'ARRAY';
+  $string = Value::List->new($string,@_) if scalar(@_) > 0;
+  $string = Value::List->new($string)->with(open=>'[',close=>']')
+    if ref($string) eq 'ARRAY';
   my $math = bless {
     string => undef,
     tokens => [], tree => undef, 
Index: Formula.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Formula.pm,v
retrieving revision 1.33
retrieving revision 1.34
diff -Llib/Value/Formula.pm -Llib/Value/Formula.pm -u -r1.33 -r1.34
--- lib/Value/Formula.pm
+++ lib/Value/Formula.pm
@@ -34,9 +34,14 @@
          '""' => sub {shift->stringify(@_)};
 
 #
-#  Call Parser to make the new item
+#  Call Parser to make the new item, copying important
+#    fields from the tree.
 #
-sub new {shift; $pkg->SUPER::new(@_)}
+sub new {
+  shift; my $self = $pkg->SUPER::new(@_);
+  foreach my $id ('open','close') {$self->{$id} = $self->{tree}{$id}}
+  return $self;
+}
 
 #
 #  Create the new parser with no string
@@ -66,6 +71,8 @@
 sub isZero {(shift)->{tree}{isZero}}
 sub isOne {(shift)->{tree}{isOne}}
 
+sub isSetOfReals {(shift)->type =~ m/Interval|Set|Union/}
+
 ############################################
 #
 #  Create a BOP from two operands
@@ -97,7 +104,7 @@
   $l = $parser->{Value}->new($formula,$l) unless ref($l) =~ m/^Parser::/;
   $r = $parser->{Value}->new($formula,$r) unless ref($r) =~ m/^Parser::/;
   $bop = 'U' if $bop eq '+' &&
-    ($l->type =~ m/Interval|Union|Set/ || $r->type =~ m/Interval|Union|Set/);
+    ($l->type =~ m/Interval|Set|Union/ || $r->type =~ m/Interval|Set|Union/);
   $formula->{tree} = $parser->{BOP}->new($formula,$bop,$l,$r);
   $formula->{variables} = $formula->{tree}->getVariables;
   return $formula->eval if scalar(%{$formula->{variables}}) == 0;

[WWcvs] pg: Make sure the singletons are sorted before comparing them to the

[dpvc v. a. <we...@ma...>]

Log Message:
-----------
Make sure the singletons are sorted before comparing them to the
intervals (and each other).

Modified Files:
--------------
    pg/lib/Value:
        Union.pm

Revision Data
-------------
Index: Union.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Union.pm,v
retrieving revision 1.20
retrieving revision 1.21
diff -Llib/Value/Union.pm -Llib/Value/Union.pm -u -r1.20 -r1.21
--- lib/Value/Union.pm
+++ lib/Value/Union.pm
@@ -218,7 +218,7 @@
   }
   my @union = (); my @set = (); my $prevX;
   @intervals = (CORE::sort {$a <=> $b} @intervals);
-  ELEMENT: foreach my $x (@singletons) {
+  ELEMENT: foreach my $x (sort {$a <=> $b} @singletons) {
     next if defined($prevX) && $prevX == $x; $prevX = $x;
     foreach my $I (@intervals) {
       my ($a,$b) = $I->value;

[WWcvs] pg: Fixed treatment of options in setting the mode and optional

[jj v. a. <we...@ma...>]

Log Message:
-----------
Fixed treatment of options in setting the mode and optional parameters
related to reducing unions.

Modified Files:
--------------
    pg/macros:
        extraAnswerEvaluators.pl

Revision Data
-------------
Index: extraAnswerEvaluators.pl
===================================================================
RCS file: /webwork/cvs/system/pg/macros/extraAnswerEvaluators.pl,v
retrieving revision 1.10
retrieving revision 1.11
diff -Lmacros/extraAnswerEvaluators.pl -Lmacros/extraAnswerEvaluators.pl -u -r1.10 -r1.11
--- macros/extraAnswerEvaluators.pl
+++ macros/extraAnswerEvaluators.pl
@@ -158,7 +158,7 @@
 
 sub mode2context {
 	my $mode = shift;
-	my $options = @_;
+	my %options = @_;
 	my $context;
 	for ($mode) {
 		/^strict$/i	   and do {
@@ -176,15 +176,18 @@
 			$context->operators->redefine(',');
 			last;
 		};
-		if(defined($options{'complex'}) &&
-		   ($options{'complex'} =~ /(yes|ok)/i)) {
-			$context = $Parser::Context::Default::context{Complex}->copy;
-			last;
-		}
 		
 		# default
 		$context = $Parser::Context::Default::context{LegacyNumeric}->copy;
 	}
+	# If we are using complex numbers, then we ignore the other mode parts
+	if(defined($options{'complex'}) &&
+	   ($options{'complex'} =~ /(yes|ok)/i)) {
+		#$context->constants->redefine('i', from=>'Complex');
+		#$context->functions->redefine(['arg','mod','Re','Im','conj', 'sqrt', 'log'], from=>'Complex');
+		#$context->operators->redefine(['^', '**'], from=>'Complex');
+		$context = $Parser::Context::Default::context{'Complex'};
+	}
 	$options{tolType} = $options{tolType} || 'relative';
 	$options{tolerance} = $options{tolerance} || $options{tol} ||
 		$options{reltol} || $options{relTol} || $options{abstol} || 1;
@@ -300,11 +303,7 @@
 		$context->parens->redefine('[', from=>'Interval');
 		$context->parens->redefine('{', from=>'Interval');
 		
-		#$context->constants->redefine('R',from=>'Interval');
-		my $infinity = Value::Infinity->new();
-		$context->constants->add(
-		   R => Value::Interval->new('(',-$infinity,$infinity,')'),
-		);
+		$context->constants->redefine('R',from=>'Interval');
 		$context->operators->redefine('U',from=>"Interval");
 		$context->operators->redefine('u',from=>"Interval",using=>"U");
 		$ans_type = 'Union';
@@ -313,9 +312,13 @@
 	for my $o qw( showCoordinateHints showHints partialCredit showLengthHints ) {
 		$options{$o} = $opts{$o} || 0;
 	}
-	$options{ordered} = 1 if(defined($opts{ordered}) and $opts{ordered});
-	$options{showUnionReduceWarnings}= $opts{showUnionReduceWarnings} || 1;
-	$options{studentsMustReduceUnions} = $opts{studentsMustReduceUnions} || 0;
+	$options{showUnionReduceWarnings} = $opts{showUnionReduceWarnings};
+	$options{studentsMustReduceUnions} = $opts{studentsMustReduceUnions};
+	if(defined($opts{ordered}) and $opts{ordered}) {
+		$options{ordered} = 1;
+		# Force this option if the the union must be ordered
+		$options{studentsMustReduceUnions} = 1;
+	}
 	if (defined($opts{'sloppy'}) && $opts{'sloppy'} eq 'yes') {
 		 $options{requireParenMatch} = 0;
 	}
@@ -327,7 +330,7 @@
 		'minfty' => {alias=>'minfinity'},
 		'minf' => {alias=>'minfinity'},
 		'mi' => {alias=>'minfinity'},
-    );
+	);
 	# Add any strings
 	if ($opts{strings}) {
 		foreach my $string (@{$opts{strings}}) {

[WWcvs] pg: Can't use the length check when reducing unions, since it could

[dpvc v. a. <we...@ma...>]

Log Message:
-----------
Can't use the length check when reducing unions, since it could
contain a single set that is not reduced, and we need to check that,
too.

Modified Files:
--------------
    pg/lib/Value:
        Union.pm

Revision Data
-------------
Index: Union.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Union.pm,v
retrieving revision 1.19
retrieving revision 1.20
diff -Llib/Value/Union.pm -Llib/Value/Union.pm -u -r1.19 -r1.20
--- lib/Value/Union.pm
+++ lib/Value/Union.pm
@@ -209,7 +209,7 @@
 #
 sub reduce {
   my $self = shift;
-  return $self if $self->{isReduced} || $self->length < 2;
+  return $self if $self->{isReduced};
   my @singletons = (); my @intervals = ();
   foreach my $x ($self->value) {
     if ($x->type eq 'Set') {push(@singletons,$x->value)}
@@ -253,7 +253,7 @@
 #
 sub isReduced {
   my $self = shift;
-  return 1 if $self->{isReduced} || $self->length < 2;
+  return 1 if $self->{isReduced};
   my $reduced = $self->reduce;
   return unless $reduced->type eq 'Union' && $reduced->length == $self->length;
   my @R = $reduced->sort->value; my @S = $self->sort->value;

[WWcvs] pg: Fixed reduction warnings for individual sets, intervals and unions

[dpvc v. a. <we...@ma...>]

Log Message:
-----------
Fixed reduction warnings for individual sets, intervals and unions (in
making it work for lists, I broke it for the single items).

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.58
retrieving revision 1.59
diff -Llib/Value/AnswerChecker.pm -Llib/Value/AnswerChecker.pm -u -r1.58 -r1.59
--- lib/Value/AnswerChecker.pm
+++ lib/Value/AnswerChecker.pm
@@ -818,7 +818,7 @@
 sub cmp_compare {
   my $self = shift; my $student = shift; my $ans = shift;
   my $error = $self->cmp_checkUnionReduce($student,$ans,@_);
-  if ($error) {$$Value::context->setError($error,'',undef,undef,$CMP_WARNING); return 0}
+  if ($error) {$$Value::context->setError($error,'',undef,undef,$CMP_WARNING); return}
   $self->SUPER::cmp_compare($student,$ans,@_);
 }
 
@@ -890,7 +890,7 @@
 sub cmp_compare {
   my $self = shift; my $student = shift; my $ans = shift;
   my $error = $self->cmp_checkUnionReduce($student,$ans,@_);
-  if ($error) {$$Value::context->setError($error,'',undef,undef,$CMP_WARNING); return 0}
+  if ($error) {$$Value::context->setError($error,'',undef,undef,$CMP_WARNING); return}
   $self->SUPER::cmp_compare($student,$ans,@_);
 }
 
@@ -921,7 +921,12 @@
   entry_type => 'an interval or set',
 )}
 
-sub cmp_equal {Value::List::cmp_equal(@_)}
+sub cmp_equal {
+  my $self = shift; my $ans = shift;
+  my $error = $self->cmp_checkUnionReduce($ans->{student_value},$ans);
+  if ($error) {$self->cmp_Error($ans,$error); return}
+  Value::List::cmp_equal($self,$ans);
+}
 
 #
 #  Check for unreduced sets and unions
@@ -929,7 +934,7 @@
 sub cmp_compare {
   my $self = shift; my $student = shift; my $ans = shift;
   my $error = $self->cmp_checkUnionReduce($student,$ans,@_);
-  if ($error) {$$Value::context->setError($error,'',undef,undef,$CMP_WARNING); return 0}
+  if ($error) {$$Value::context->setError($error,'',undef,undef,$CMP_WARNING); return}
   $self->SUPER::cmp_compare($student,$ans,@_);
 }
 

[WWcvs] pg: Fixed a problem with redefine when used with classes that store

[dpvc v. a. <we...@ma...>]

Log Message:
-----------
Fixed a problem with redefine when used with classes that store their
data in a on-standard form (i.e., by overridding the create()
method).  Now they can define uncreate() to get the original data back
for use with redefine().

Modified Files:
--------------
    pg/lib/Parser/Context:
        Constants.pm
        Variables.pm
    pg/lib/Value/Context:
        Data.pm

Revision Data
-------------
Index: Constants.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/Context/Constants.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -Llib/Parser/Context/Constants.pm -Llib/Parser/Context/Constants.pm -u -r1.3 -r1.4
--- lib/Parser/Context/Constants.pm
+++ lib/Parser/Context/Constants.pm
@@ -16,12 +16,13 @@
 }
 
 #
-#  Create data for constants
+#  Create/Uncreate data for constants
 #
 sub create {
   my $self = shift; my $value = shift;
   return {value => $value, keepName => 1};
 }
+sub uncreate {shift; (shift)->{value}}
 
 #
 #  Return a constant's value
Index: Variables.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/Context/Variables.pm,v
retrieving revision 1.8
retrieving revision 1.9
diff -Llib/Parser/Context/Variables.pm -Llib/Parser/Context/Variables.pm -u -r1.8 -r1.9
--- lib/Parser/Context/Variables.pm
+++ lib/Parser/Context/Variables.pm
@@ -61,6 +61,7 @@
   }
   return {type => $value, @extra};
 }
+sub uncreate {shift; (shift)->{type}};
 
 #
 #  Return a variable's type
Index: Data.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Context/Data.pm,v
retrieving revision 1.7
retrieving revision 1.8
diff -Llib/Value/Context/Data.pm -Llib/Value/Context/Data.pm -u -r1.7 -r1.8
--- lib/Value/Context/Data.pm
+++ lib/Value/Context/Data.pm
@@ -26,6 +26,7 @@
 #
 sub init {}
 sub create {shift; shift}
+sub uncreate {shift; shift}
 
 #
 #  Sort names so that they can be joined for regexp matching
@@ -158,7 +159,7 @@
     Value::Error("No definition for %s '%s' in the given context",$self->{name},$y)
       unless $from->{$self->{dataName}}{$y};
     push(@remove,$x) if $self->get($x);
-    push(@data,$x => $from->{$self->{dataName}}{$y});
+    push(@data,$x => $self->uncreate($from->{$self->{dataName}}{$y}));
   }
   $self->remove(@remove);
   $self->add(@data);

[WWcvs] pg: Fixed mad error message (change needed due to new message

[dpvc v. a. <we...@ma...>]

Log Message:
-----------
Fixed mad error message (change needed due to new message translation
facility).

Modified Files:
--------------
    pg/lib:
        Value.pm

Revision Data
-------------
Index: Value.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value.pm,v
retrieving revision 1.42
retrieving revision 1.43
diff -Llib/Value.pm -Llib/Value.pm -u -r1.42 -r1.43
--- lib/Value.pm
+++ lib/Value.pm
@@ -256,7 +256,7 @@
   elsif ($type eq 'Infinity') {$type = $Value::Type{infinity}}
   elsif ($type eq 'value' || $type eq 'Formula') {$type = $value->typeRef}
   elsif ($type eq 'unknown') {
-    $equation->Error("Can't convert %s to a constant",Value::showClass($value));
+    $equation->Error(["Can't convert %s to a constant",Value::showClass($value)]);
   } else {
     $type = 'Value::'.$type, $value = $type->new(@{$value});
     $type = $value->typeRef;

[WWcvs] pg: Added isReduced method to tell if a Union, Set or Interval is

[dpvc v. a. <we...@ma...>]

Log Message:
-----------
Added isReduced method to tell if a Union, Set or Interval is already
reduced.  Fixed up sort to use CORE::sort, and added sort and reduce
to Intervals, which do nothing, but are there for consistency.

Modified Files:
--------------
    pg/lib/Value:
        Interval.pm
        Set.pm
        Union.pm

Revision Data
-------------
Index: Set.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Set.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -Llib/Value/Set.pm -Llib/Value/Set.pm -u -r1.5 -r1.6
--- lib/Value/Set.pm
+++ lib/Value/Set.pm
@@ -186,6 +186,11 @@
   return scalar(@l) - scalar(@r);
 }
 
+############################################
+#
+#  Utility routines
+#
+
 #
 #  Remove redundant values
 #
@@ -201,11 +206,20 @@
 }
 
 #
+#  True if the set is reduced
+#
+sub isReduced {
+  my $self = shift;
+  return 1 if $self->{isReduced} || $self->length < 2;
+  return $self->reduce->length == $self->length;
+}
+
+#
 #  Sort the data for a set
 #
 sub sort {
   my $self = shift;
-  return $self->make(sort {$a <=> $b} $self->value);
+  return $self->make(CORE::sort {$a <=> $b} $self->value);
 }
 
 ###########################################################################
Index: Interval.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Interval.pm,v
retrieving revision 1.24
retrieving revision 1.25
diff -Llib/Value/Interval.pm -Llib/Value/Interval.pm -u -r1.24 -r1.25
--- lib/Value/Interval.pm
+++ lib/Value/Interval.pm
@@ -225,6 +225,15 @@
   return $l->{close} cmp $r->{close};
 }
 
+############################################
+#
+#  Utility routines
+#
+
+sub reduce {shift}
+sub isReduced {1}
+sub sort {shift}
+
 ###########################################################################
 
 1;
Index: Union.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Union.pm,v
retrieving revision 1.18
retrieving revision 1.19
diff -Llib/Value/Union.pm -Llib/Value/Union.pm -u -r1.18 -r1.19
--- lib/Value/Union.pm
+++ lib/Value/Union.pm
@@ -201,9 +201,12 @@
 
 ############################################
 #
-#  Reduce unions to simplest form
+#  Utility routines
 #
 
+#
+#  Reduce unions to simplest form
+#
 sub reduce {
   my $self = shift;
   return $self if $self->{isReduced} || $self->length < 2;
@@ -245,7 +248,21 @@
   return $pkg->make(@union)->with(isReduced=>1);
 }
 
-############################################
+#
+#  True if a union is reduced
+#
+sub isReduced {
+  my $self = shift;
+  return 1 if $self->{isReduced} || $self->length < 2;
+  my $reduced = $self->reduce;
+  return unless $reduced->type eq 'Union' && $reduced->length == $self->length;
+  my @R = $reduced->sort->value; my @S = $self->sort->value;
+  foreach my $i (0..$#R) {
+    return unless $R[$i] == $S[$i] && $R[$i]->length == $S[$i]->length;
+  }
+  return 1;
+}
+
 #
 #  Sort a union lexicographically
 #

[WWcvs] pg: Fixed error in testing is a union is reduced (didn't test if sets

[dpvc v. a. <we...@ma...>]

Log Message:
-----------
Fixed error in testing is a union is reduced (didn't test if sets
within a union were reduced properly).

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.57
retrieving revision 1.58
diff -Llib/Value/AnswerChecker.pm -Llib/Value/AnswerChecker.pm -u -r1.57 -r1.58
--- lib/Value/AnswerChecker.pm
+++ lib/Value/AnswerChecker.pm
@@ -257,12 +257,11 @@
     my @S = $student->sort->value;
     foreach my $i (0..$#R) {
       return "Your$nth union can be written in a simpler form"
-	unless $R[$i] == $S[$i];
+	unless $R[$i] == $S[$i] && $R[$i]->length == $S[$i]->length;
     }
-  } elsif ($student->type eq 'Set') {
-    my $reduced = $student->reduce;
+  } elsif ($student->type eq 'Set' && $student->length >= 2) {
     return "Your$nth set should have no redundant elements"
-      unless $reduced->length == $student->length;
+      unless $student->reduce->length == $student->length;
   }
   return;
 }