From 33ea129c0935ba5a98b827736dd77d348b8bcb50 Mon Sep 17 00:00:00 2001
From: Glenn Rice <grice1@missouriwestern.edu>
Date: Sat, 21 Jan 2023 21:01:59 -0600
Subject: [PATCH] Add a macro for multiple choice checkbox answers.

This is intended to be a replacement for using PGchoicemacros.pl with
new_checkbox_multiple_choice.

In order for this to work when used with a MultiAnswer object with
singleResult true, the NAMED_ANS_CHECKBOX and NAMED_ANS_CHECKBOX_OPTION
methods need to be updated to match the NAMED_ANS_RADIO and
NAMED_ANS_RADIO_EXTENSION methods.

In addition, this fixes repeated ids on checkboxes created via
NAMED_ANS_CHECKBOX_OPTION, and makes the coloring of checkboxes with
incorrect and incorrect colors work as it does for almost all other
answers.
---
 htdocs/js/apps/Problem/problem.scss  |   2 +-
 macros/core/PGbasicmacros.pl         |  15 +-
 macros/parsers/parserCheckboxList.pl | 526 +++++++++++++++++++++++++++
 3 files changed, 536 insertions(+), 7 deletions(-)
 create mode 100644 macros/parsers/parserCheckboxList.pl

diff --git a/htdocs/js/apps/Problem/problem.scss b/htdocs/js/apps/Problem/problem.scss
index ef76efc177..2da73fae53 100644
--- a/htdocs/js/apps/Problem/problem.scss
+++ b/htdocs/js/apps/Problem/problem.scss
@@ -60,7 +60,7 @@
 		line-height: 20px;
 	}
 
-	select, input[type=text], input[type=radio] {
+	select, input[type=text], input[type=radio], input[type=checkbox] {
 		&.correct {
 			border-color: rgba(81, 153, 81, 0.8); /* green */
 			outline: 0;
diff --git a/macros/core/PGbasicmacros.pl b/macros/core/PGbasicmacros.pl
index c58d622077..207560d963 100644
--- a/macros/core/PGbasicmacros.pl
+++ b/macros/core/PGbasicmacros.pl
@@ -675,9 +675,11 @@ sub contained_in {
 ##########################
 
 sub NAMED_ANS_CHECKBOX {
-	my $name  = shift;
-	my $value = shift;
-	my $tag   = shift;
+	my $name    = shift;
+	my $value   = shift;
+	my $tag     = shift;
+	my $extend  = shift;
+	my %options = @_;
 
 	my $checked = '';
 	if ($value =~ /^\%/) {
@@ -693,7 +695,8 @@ sub NAMED_ANS_CHECKBOX {
 		}
 
 	}
-	$name = RECORD_ANS_NAME($name, { $value => $checked });
+	$name = RECORD_ANS_NAME($name, { $value => $checked }) unless $extend;
+	INSERT_RESPONSE($options{answer_group_name}, $name, { $value => $checked }) if $extend;
 	my $label = generate_aria_label($name);
 	$label .= "option 1 ";
 
@@ -728,7 +731,7 @@ sub NAMED_ANS_CHECKBOX_OPTION {
 		}
 
 	}
-	EXTEND_RESPONSE($name, $name, $value, $checked);
+	EXTEND_RESPONSE($options{answer_group_name} // $name, $name, $value, $checked);
 	my $label;
 	if (defined($options{aria_label})) {
 		$label = $options{aria_label};
@@ -741,7 +744,7 @@ sub NAMED_ANS_CHECKBOX_OPTION {
 		Latex2HTML =>
 			qq!\\begin{rawhtml}\n<INPUT TYPE=CHECKBOX NAME="$name" id="$name" VALUE="$value" $checked>\\end{rawhtml}$tag!,
 		HTML =>
-			qq!<label><INPUT TYPE=CHECKBOX NAME="$name" id="$name" aria-label="$label" VALUE="$value" $checked>$tag</label>!,
+			qq!<label><INPUT TYPE=CHECKBOX NAME="$name" id="${name}_$value" aria-label="$label" VALUE="$value" $checked>$tag</label>!,
 		PTX => '<li>' . "$tag" . '</li>' . "\n",
 	);
 
diff --git a/macros/parsers/parserCheckboxList.pl b/macros/parsers/parserCheckboxList.pl
new file mode 100644
index 0000000000..09ff6c7014
--- /dev/null
+++ b/macros/parsers/parserCheckboxList.pl
@@ -0,0 +1,526 @@
+################################################################################
+# WeBWorK Online Homework Delivery System
+# Copyright &copy; 2000-2022 The WeBWorK Project, https://github.com/openwebwork
+#
+# This program is free software; you can redistribute it and/or modify it under
+# the terms of either: (a) the GNU General Public License as published by the
+# Free Software Foundation; either version 2, or (at your option) any later
+# version, or (b) the "Artistic License" which comes with this package.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE.  See either the GNU General Public License or the
+# Artistic License for more details.
+################################################################################
+
+=head1 NAME
+
+parserCheckboxList.pl - Multiple choice checkbox answers compatible with
+                        MathObjects, MultiAnswer objects, and PGML.
+
+=head1 DESCRIPTION
+
+This file implements a multiple choice checkbox object that is compatible with
+MathObjects, and in particular, with the MultiAnswer object, and with PGML.
+
+To create a CheckboxList object, use
+
+    $checks = CheckboxList([choices, ...], [correct_choices, ...], options);
+
+where "S<choices>" are the label value strings for the checkboxes,
+"S<correct_choices>" are the choices that are the correct answera (or their
+indices, with 0 being the first one), and options are chosen from among those
+listed below.  If the correct answer is a number, it is interpretted as an
+index, even if the array of choices are also numbers.  (See the C<noindex> below
+for more details.)
+
+The entries in the choices array can either be strings that are the text to use
+for the choice buttons, or C<< { label => text } >> where C<label> is a label to
+use for the choice when showing the student or correct answers, and C<text> is
+the text to use for the choice.  See below for options controlling how the
+labels will be used.  If a choice includes mathematics, you should use labels as
+above or through the C<labels> option below in order to have the student and
+correct answers display properly in the results table when an answer is
+submitted.  Use the C<displayLabels> option to make the labels be part of the
+choice as it is displayed following the checkbox.
+
+By default, the choices are left in the order that you provide them, but you can
+cause some or all of them to be ordered randomly by enclosing those that should
+be randomized within a second set of brackets.  For example
+
+    $checks = CheckboxList(
+        [
+            "First Item",
+            [ "Random 1", "Random 2", "Random 3" ],
+            "Last Item"
+        ],
+        ["First Item", "Random 3"]
+    );
+
+will make a list of checkboxes that has the first item always on top, the next
+three ordered randomly, and the last item always on the bottom.  In this example
+
+    $checks = CheckboxList([[ "Random 1", "Random 2", "Random 3" ]], 2);
+
+all the entries are randomized, and the correct answer is "Random 3" (the one
+with index 2 in the original, unrandomized list).  You can have as many
+randomized groups, with as many static items in between, as you want.
+
+The C<options> are taken from the following list:
+
+=over
+
+=item C<S<< labels => "123", "ABC", "text", or [label1, ...] >>>
+
+Labels are used to replace the text of the choice in the student and correct
+answers, and can also be shown just before the choice text (if C<displayLabels>
+is set).  If the value is C<"123"> then the choices will be labeled with numbers
+(the choices will be numbered sequentially after they have been randomized).  If
+the value is C<"ABC"> then the choices will be labeled with capital letters
+after they have been randomized.  If the value is C<"text"> then the button text
+is used (note, however, that if the text contains things like math or formatting
+or special characters, these may not display well in the student and correct
+answer columns of the results table).
+
+If any choices have explicit labels (via C<< { label => text } >>), those labels
+will be used instead of the automatic number or letter (and the number or letter
+will be skipped).  The third form allows you to specify labels for each of the
+choices in their original order (though the C<< { label => text } >> form is
+preferred).
+
+Default: labels are the text of the choice when they don't include any special
+characters, and "Button 1", "Button 2", etc., otherwise.
+
+=item C<S<< displayLabels => 0 or 1 >>>
+
+Specifies whether labels should be displayed after the checkbox and before its
+text.  This makes the association between the choices and the label used as an
+answer more explicit.  Default: 1
+
+=item C<S<< labelFormat => string >>>
+
+Specifies a format string to use when displaying labels before the choice text.
+It is an C<sprintf> string that contains C<%s> where the label should go.  By
+default, it is C<${BBOLD}%s. ${EBOLD}>, which produces the label in bold
+followed by a period and a space.
+
+=item C<S<< forceLabelFormat => 0 or 1 >>>
+
+When C<displayLabels> is set, this controls how blank labels are handled.  When
+set to C<0>, no label is inserted before the choice text for blank labels, and
+when C<1>, the C<labelFormat> is applied ot the empty string and the result is
+inserted before the choice text.  Default: 0.
+
+=item C<S<< separator => string >>>
+
+Specifies the text to put between the checkboxes.  Default: $BR
+
+=item C<S<< checked => choice >>>
+
+A list of texts or indices (starting at zero) of the checkboxes to be checked
+initially.  Default: [] (none checked)
+
+=item C<S<< maxLabelSize => n >>>
+
+The approximate largest size that should be used for the answer strings to be
+generated by the checkboxes (if the choice strings are too long, they will be
+trimmed and "..." inserted) Default: 25
+
+=item C<S<< noindex => 0 or 1 >>>
+
+Determines whether a numeric value for the correct answer is interpretted as an
+index into the choice array or not.  If set to 1, then the number is treated as
+the literal correct answer, not an index to it.  Default: 0
+
+=back
+
+To insert the checkboxes into the problem text use
+
+    BEGIN_PGML
+    [_]{$checks}
+    END_PGML
+
+with PGML, or
+
+    BEGIN_TEXT
+    \{$checks->checks\}
+    END_TEXT
+
+    ANS($checks->cmp);
+
+with basic PG.
+
+You can use the CheckboxList object in MultiAnswer objects.  This is the reason
+for the CheckboxLists's C<ans_rule> method (since that is what MultiAnswer calls
+to get answer rules).  Just pass a CheckboxList object as one of the arguments
+of the MultiAnswer constructor.
+
+When writing a custom answer checker involving a CheckboxList object (e.g. if it
+is part of a MultiAnswer and its answer depends on, or affects, the answers
+given to other parts), note that the actual answer strings associated to a
+CheckboxList object (which are those appearing in the "student answer" argument
+passed to a custom answer checker) are neither the supplied choice strings nor
+the supplied labels, but are an internal implementation detail whose format
+should not be depended on.  You can convert one of these answer strings to a
+choice string or a label with the methods answerChoice or answerLabel.
+
+=cut
+
+loadMacros('MathObjects.pl');
+
+sub _parserCheckboxList_init {
+	main::PG_restricted_eval('sub CheckboxList { parser::CheckboxList->new(@_) }');
+	return;
+}
+
+package parser::CheckboxList;
+our @ISA = qw(Value::List);
+
+sub new {
+	my ($invocant, @inputs) = @_;
+
+	shift @inputs if Value::isContext($inputs[0]);
+
+	my $choices = shift @inputs;
+	my $correct = shift @inputs;
+
+	Value::Error(q{A CheckboxLists's first argument should be a list of checkbox label values.})
+		unless ref($choices) eq 'ARRAY';
+	Value::Error(q{A CheckboxList's second argument should be a list of correct choices.})
+		unless ref($correct) eq 'ARRAY';
+
+	my %options;
+	main::set_default_options(
+		\%options,
+		labels           => 'auto',
+		displayLabels    => 'auto',
+		labelFormat      => "${main::BBOLD}%s${main::EBOLD}. ",
+		forceLabelFormat => 0,
+		separator        => $main::BR,
+		checked          => [],
+		maxLabelSize     => 25,
+		noindex          => 0,
+		checkedI         => [],
+		@inputs
+	);
+
+	my $context = Parser::Context->getCopy('Numeric');
+
+	my $self = $invocant->SUPER::new($context, 0 .. $#$correct);
+	$self->{$_} = $options{$_} for keys %options;
+	$self->{choices} = $choices;
+
+	$self->getChoiceOrder;
+	$self->addLabels;
+	$self->getCorrectChoices($correct);
+	$self->getCheckedChoices($self->{checked});
+
+	$context->strings->are(map { ("B$_" => {}) } (0 .. ($self->{n} - 1)));
+	$_ = Value::makeValue($_, context => $context) for @{ $self->data };
+
+	return $self;
+}
+
+sub type { return 'List'; }
+
+# Order the choices (randomizing where requested).
+sub getChoiceOrder {
+	my $self = shift;
+
+	my @choices;
+	for my $choice (@{ $self->{choices} }) {
+		if   (ref($choice) eq 'ARRAY') { push(@choices, $self->randomOrder($choice)) }
+		else                           { push(@choices, $choice) }
+	}
+	$self->{orderedChoices} = \@choices;
+	$self->{n}              = scalar(@choices);
+
+	return;
+}
+
+sub randomOrder {
+	my ($self, $choices) = @_;
+	my %index = (map { $main::PG_random_generator->rand => $_ } (0 .. scalar(@$choices) - 1));
+	return (map { $choices->[ $index{$_} ] } main::PGsort(sub { $_[0] lt $_[1] }, keys %index));
+}
+
+# Collect the labels from those that have them, and add ones to those that don't (if requested).
+sub addLabels {
+	my $self = shift;
+
+	my $choices = $self->{orderedChoices};
+	my $labels  = $self->{labels};
+	$labels = [ 1 .. $self->{n} ]                        if $labels eq '123';
+	$labels = [ @main::ALPHABET[ 0 .. $self->{n} - 1 ] ] if uc($labels) eq 'ABC';
+	$labels = []                                         if $labels eq 'text';
+
+	if (ref($labels) ne 'ARRAY') {
+		my $replace = $labels ne 'auto';
+		if (!$replace) {
+			for (@$choices) { $replace = 1 if $_ =~ m/[^-+.,;:()!\[\]a-z0-9 ]/i }
+		}
+		$labels                = [ map {"Choice $_"} (1 .. $self->{n}) ] if $replace;
+		$self->{displayLabels} = 0                                       if $self->{displayLabels} eq 'auto';
+	}
+
+	$labels = [] unless ref($labels) eq 'ARRAY';
+
+	for (0 .. $self->{n} - 1) {
+		if (ref($choices->[$_]) eq 'HASH') {
+			my $key = (keys %{ $choices->[$_] })[0];
+			$labels->[$_]  = $key;
+			$choices->[$_] = $choices->[$_]{$key};
+		}
+	}
+
+	$self->{labels}        = $labels;
+	$self->{displayLabels} = 1 if $self->{displayLabels} eq 'auto';
+
+	return;
+}
+
+# Find the correct choices in the ordered array
+sub getCorrectChoices {
+	my ($self, $values) = @_;
+
+	$self->{data} = [];
+
+	for my $value (@$values) {
+		if ($value =~ m/^\d+$/ && !$self->{noindex}) {
+			$value = ($self->flattenChoices)[$value];
+			if (!defined($value)) {
+				Value::Error('The correct answer index is outside the range of choices provided');
+				return;
+			}
+		}
+
+		for (0 .. $#{ $self->{orderedChoices} }) {
+			if ($value eq $self->{orderedChoices}[$_] || $value eq ($self->{labels}[$_] || '')) {
+				push(@{ $self->{data} }, "B$_");
+				last;
+			}
+		}
+	}
+
+	# Sort the correct choices into display order.
+	$self->{data} = [ main::PGsort(sub { $_[0] lt $_[1] }, @{ $self->{data} }) ];
+
+	Value::Error('The correct choices must be among the label values') unless @{ $self->{data} };
+
+	return;
+}
+
+sub getCheckedChoices {
+	my ($self, $values) = @_;
+	return unless @$values;
+
+	for my $value (@$values) {
+		$value = ($self->flattenChoices)[$value] if $value =~ m/^\d+$/;
+
+		if (!defined($value)) {
+			Value::Error('The correct answer index is outside the range of choices provided');
+			return;
+		}
+
+		for (0 .. $#{ $self->{orderedChoices} }) {
+			if ($value eq $self->{orderedChoices}[$_] || $value eq $self->{labels}[$_]) {
+				push(@{ $self->{checkedI} }, $_);
+				last;
+			}
+		}
+	}
+
+	Value::Error('The checked choices must be among the label values') unless @{ $self->{checkedI} };
+	return;
+}
+
+sub flattenChoices {
+	my $self    = shift;
+	my @choices = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @{ $self->{choices} };
+	for my $choice (@choices) {
+		if (ref($choice) eq 'HASH') {
+			my $key = (keys %$choice)[0];
+			$choice = $choice->{$key};
+		}
+	}
+	return @choices;
+}
+
+# Format a label using the user-provided format string
+sub labelFormat {
+	my ($self, $label) = @_;
+	return ''   unless $label || $self->{forceLabelFormat};
+	$label = '' unless defined $label;
+	return sprintf($self->{labelFormat}, $self->protect($label));
+}
+
+# Trim the selected choice or label so that it is not too long to be displayed in the results table.
+sub labelText {
+	my ($self, $index) = @_;
+	$index = substr($index, 1);
+	my $choice = $self->{labels}[$index];
+	$choice = $self->{orderedChoices}[$index] unless defined $choice;
+	return $choice if length($choice) < $self->{maxLabelSize};
+	my @words = split(/( |\b)/, $choice);
+	my ($s, $e) = ('', '');
+	return $choice if scalar(@words) < 3;
+	do { $s .= shift(@words); $e = pop(@words) . $e if @words }
+		while length($s) + length($e) + 10 < $self->{maxLabelSize} && scalar(@words);
+	return $s . " ... " . $e;
+}
+
+# Use the actual choice strings in the output rather than the "Bn" string.
+sub TeX {
+	my $self = shift;
+	return $self->quoteTeX(join(', ', map { $self->labelText($_) } $self->value));
+}
+
+sub string {
+	my $self = shift;
+	return $self->quoteHTML(join(', ', map { $self->labelText($_) } $self->value));
+}
+
+sub cmp_defaults {
+	my ($self, %options) = @_;
+	return (
+		$self->SUPER::cmp_defaults(%options),
+		entry_type        => 'choice',
+		list_type         => 'selection',
+		requireParenMatch => 0,
+		implicitList      => 0,
+		correct_choices   => $self->data
+	);
+}
+
+# Adjust student preview and answer strings to be the actual choice strings rather than the "Bn" strings.
+sub cmp_preprocess {
+	my ($self, $ans) = @_;
+	if (defined $ans->{student_value} && @{ $ans->{student_value}->data }) {
+		$ans->{original_student_ans} = join(', ', map { $self->labelText($_) } @{ $ans->{student_value}->data });
+		$ans->{preview_latex_string} = $self->quoteTeX($ans->{original_student_ans});
+		$ans->{student_ans}          = $self->quoteHTML($ans->{original_student_ans});
+	}
+	return;
+}
+
+sub verb {
+	my ($self, $s) = @_;
+	$s =~ s/\r/ /g;
+	my $d = main::MODES(HTML => chr(0x1F), TeX => chr(0xD), PTX => chr(0xD));
+	return "{\\verb$d$s$d}";
+}
+
+# Put normal strings into \text{} and others into \verb
+sub quoteTeX {
+	my ($self, $s) = @_;
+	return $self->verb($s) unless $s =~ m/^[-a-z0-9 ,.;:+=?()\[\]]*$/i;
+	return "\\text{$s}";
+}
+
+# Quote HTML special characters
+sub quoteHTML {
+	my ($self, $s, $nospan) = @_;
+	return unless defined $s;
+	return $s if $main::displayMode eq 'TeX';
+
+	$s =~ s/&/\&amp;/g;
+	$s =~ s/</\&lt;/g;
+	$s =~ s/>/\&gt;/g;
+	$s =~ s/"/\&quot;/g;
+
+	return $s if $nospan || $s !~ m/(\$|\\\(|\\\[)/;
+	return qq{<span class="tex2jax_ignore">$s</span>};
+}
+
+sub answerChoice {
+	my ($self, $index) = @_;
+	return $self->{orderedChoices}[ substr($index, 1) ];
+}
+
+sub answerLabel {
+	my ($self, $index) = @_;
+	return $self->{labels}[ substr($index, 1) ];
+}
+
+# Given a choice, a label, or an index into the choices array, return the choice.
+sub findChoice {
+	my ($self, $value) = @_;
+	my $index = $self->Index($value);
+	return $self->{choices}[$index] unless $index == -1;
+	for (0 .. ($self->{n} - 1)) {
+		my $label  = $self->{labels}[$_] // '';
+		my $choice = $self->{choices}[$_];
+		return $choice if $label eq $value || $choice eq $value;
+	}
+	return;
+}
+
+# Get a numeric index (-1 if not defined or not a number).
+sub Index {
+	my ($self, $index) = @_;
+	return -1 unless defined $index && $index =~ m/^\d$/;
+	return $index;
+}
+
+# Create the checkbox text
+sub CHECKS {
+	my ($self, $extend, $name, $size, %options) = @_;
+
+	my @checks;
+	$name = main::NEW_ANS_NAME() unless $name;
+	my $label = main::generate_aria_label($name);
+
+	for my $i (0 .. $#{ $self->{orderedChoices} }) {
+		my $value = "B$i";
+		my $tag   = $self->{orderedChoices}[$i];
+		$value = '%' . $value                                   if (grep { $i == $_ } @{ $self->{checkedI} });
+		$tag   = $self->labelFormat($self->{labels}[$i]) . $tag if $self->{displayLabels};
+		if ($i > 0) {
+			push(
+				@checks,
+				main::NAMED_ANS_CHECKBOX_OPTION(
+					$name, $value, " $tag",
+					aria_label => $label . 'option ' . ($i + 1) . ' ',
+					%options
+				)
+			);
+		} else {
+			push(@checks, main::NAMED_ANS_CHECKBOX($name, $value, " $tag", $extend, %options));
+		}
+	}
+
+	if ($main::displayMode eq 'TeX') {
+		$checks[0] = "\n\\begin{itemize}\n" . $checks[0];
+		$checks[-1] .= "\n\\end{itemize}\n";
+	}
+
+	# FIXME: Alex, what is needed here?
+	if ($main::displayMode eq 'PTX') {
+		$checks[0] = qq{<var form="buttons" name="$name">\n$checks[0]};
+		$checks[-1] .= '</var>';
+		# Change math delimiters
+		@checks = map { $_ =~ s/\\\(/<m>/gr } @checks;
+		@checks = map { $_ =~ s/\\\)/<\/m>/gr } @checks;
+	}
+
+	return wantarray ? @checks : join($main::displayMode eq 'PTX' ? '' : $self->{separator}, @checks);
+}
+
+sub protect {
+	my ($self, $s) = @_;
+	return '' if !defined $s || $s eq '';
+	return main::MODES(TeX => $self->quoteTeX($s), HTML => $self->quoteHTML($s));
+}
+
+sub checks { my ($self, $size, %options) = @_; return $self->CHECKS(0, undef, $size, %options); }
+sub named_checks { my ($self, $name, $size, %options) = @_; return $self->CHECKS(0, $name, $size, %options); }
+
+sub ans_rule { my ($self, $size, %options) = @_; return $self->CHECKS(0, undef, $size, %options); }
+sub named_ans_rule { my ($self, $name, $size, %options) = @_; return $self->CHECKS(0, $name, $size, %options); }
+
+sub named_ans_rule_extension {
+	my ($self, $name, $size, %options) = @_;
+	return $self->CHECKS(1, $name, $size, %options);
+}
+
+1;