[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