Menu
▾
▴
[WWcvs] pg: Added ability to subtract intervals, sets and unions.
|
From: dpvc v. a. <we...@ma...> - 2005-08-11 20:55:35
|
Log Message:
-----------
Added ability to subtract intervals, sets and unions. Adjusted the
precedence of the union 'U' to be above _ and + so that things like
(1,5) U (7,10) - {8} U (2,3) will do ((1,5) U (7,10)) - ({8} U (2,3))
rather than the previous (1,5) U ((7,10) - {8}) U (2,3). Finally,
added a constant 'R' to the Interval context that is equivalent to
(-inf,inf), so you can do things like R-{0} now.
Still need to work out reducing unions so that things like (1,3)U(2,4)
can become (1,4).
Modified Files:
--------------
pg/lib/Parser:
Constant.pm
pg/lib/Parser/BOP:
subtract.pm
union.pm
pg/lib/Parser/Context:
Default.pm
pg/lib/Value:
Interval.pm
Set.pm
Union.pm
Revision Data
-------------
Index: Constant.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/Constant.pm,v
retrieving revision 1.7
retrieving revision 1.8
diff -Llib/Parser/Constant.pm -Llib/Parser/Constant.pm -u -r1.7 -r1.8
--- lib/Parser/Constant.pm
+++ lib/Parser/Constant.pm
@@ -24,6 +24,8 @@
ref => $ref, equation => $equation
}, $class;
$c->{isConstant} = 1 if $const->{isConstant};
+ $c->{canBeInterval} = 1
+ if Value::isValue($const->{value}) && $const->{value}{canBeInterval};
return $c;
}
Index: union.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/BOP/union.pm,v
retrieving revision 1.7
retrieving revision 1.8
diff -Llib/Parser/BOP/union.pm -Llib/Parser/BOP/union.pm -u -r1.7 -r1.8
--- lib/Parser/BOP/union.pm
+++ lib/Parser/BOP/union.pm
@@ -14,7 +14,7 @@
sub _check {
my $self = shift;
return if ($self->checkStrings());
- if ($self->{lop}->{canBeInterval} && $self->{rop}->{canBeInterval}) {
+ if ($self->{lop}{canBeInterval} && $self->{rop}{canBeInterval}) {
$self->{type} = Value::Type('Union',2,$Value::Type{number});
$self->{canBeInterval} = 1;
foreach my $op ('lop','rop') {
Index: subtract.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/BOP/subtract.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -Llib/Parser/BOP/subtract.pm -Llib/Parser/BOP/subtract.pm -u -r1.5 -r1.6
--- lib/Parser/BOP/subtract.pm
+++ lib/Parser/BOP/subtract.pm
@@ -14,6 +14,24 @@
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/) {
+ $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}->class eq 'Value') {
+ $self->{$op}{value} = Value::Interval::promote($self->{$op}{value});
+ } else {
+ $self->{$op} = bless $self->{$op}, 'Parser::List::Interval';
+ }
+ $self->{$op}->typeRef->{name} = $self->{equation}{context}{parens}{interval}{type};
+ }
+ }
+ }
+ return;
+ }
my ($ltype,$rtype) = $self->promotePoints();
if (Parser::Item::typeMatch($ltype,$rtype)) {$self->{type} = $ltype}
else {$self->matchError($ltype,$rtype)}
Index: Default.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/Context/Default.pm,v
retrieving revision 1.28
retrieving revision 1.29
diff -Llib/Parser/Context/Default.pm -Llib/Parser/Context/Default.pm -u -r1.28 -r1.29
--- lib/Parser/Context/Default.pm
+++ lib/Parser/Context/Default.pm
@@ -11,15 +11,15 @@
',' => {precedence => 0, associativity => 'left', type => 'bin', string => ',',
class => 'Parser::BOP::comma', isComma => 1},
- 'U' => {precedence => 0.5, associativity => 'left', type => 'bin', isUnion => 1,
- string => ' U ', TeX => '\cup ', class => 'Parser::BOP::union'},
-
'+' => {precedence => 1, associativity => 'left', type => 'both', string => '+',
class => 'Parser::BOP::add'},
'-' => {precedence => 1, associativity => 'left', type => 'both', string => '-',
perl => '- ', class => 'Parser::BOP::subtract', rightparens => 'same'},
+ 'U' => {precedence => 1.5, associativity => 'left', type => 'bin', isUnion => 1,
+ string => ' U ', TeX => '\cup ', class => 'Parser::BOP::union'},
+
'><'=> {precedence => 2, associativity => 'left', type => 'bin',
string => ' >< ', TeX => '\times ', perl => ' x ', fullparens => 1,
class => 'Parser::BOP::cross'},
@@ -295,6 +295,10 @@
'[' => {type => 'Interval'},
'{' => {type => 'Set', removable => 0, emptyOK => 1},
);
+my $infinity = Value::Infinity->new();
+$intervalContext->constants->add(
+ R => Value::Interval->new('(',-$infinity,$infinity,')'),
+);
#########################################################################
Index: Set.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Set.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -Llib/Value/Set.pm -Llib/Value/Set.pm -u -r1.1 -r1.2
--- lib/Value/Set.pm
+++ lib/Value/Set.pm
@@ -9,6 +9,7 @@
use overload
'+' => sub {shift->add(@_)},
+ '-' => sub {shift->sub(@_)},
'.' => \&Value::_dot,
'x' => sub {shift->cross(@_)},
'<=>' => sub {shift->compare(@_)},
@@ -86,11 +87,7 @@
sub add {
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}
- Value::Error("Sets can only be added to Intervals, Sets or Unions")
- unless Value::class($l) =~ m/Interval|Union|Set/ &&
- Value::class($r) =~ m/Interval|Union|Set/;
+ $r = promote($r); if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
return Value::Union->new($l,$r)
unless Value::class($l) eq 'Set' && Value::class($r) eq 'Set';
my @combined = (sort {$a <=> $b} (@{$l->data},@{$r->data}));
@@ -103,6 +100,79 @@
}
sub dot {my $self = shift; $self->add(@_)}
+#
+# Subtraction removes items from a set
+#
+sub sub {
+ 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}
+ return Value::Union::form(subIntervalSet($l,$r)) if Value::class($l) eq 'Interval';
+ return Value::Union::form(subSetInterval($l,$r)) if Value::class($r) eq 'Interval';
+ return Value::Union::form(subSetSet($l,$r));
+}
+
+#
+# Subtract one set from another
+# (return the resulting set or nothing for empty set)
+#
+sub subSetSet {
+ my @l = sort {$a <=> $b} (@{$_[0]->data});
+ my @r = sort {$a <=> $b} (@{$_[1]->data});
+ my @entries = ();
+ while (scalar(@l) && scalar(@r)) {
+ if ($l[0] < $r[0]) {push(@entries,shift(@l))}
+ else {if ($l[0] == $r[0]) {shift(@l)}; shift(@r)}
+ }
+ push(@entries,@l);
+ return () unless scalar(@entries);
+ return $pkg->make(@entries);
+}
+
+#
+# Subtract a set from an interval
+# (returns a collection of intervals)
+#
+sub subIntervalSet {
+ my $I = shift; my $S = shift;
+ my @union = (); my ($a,$b) = $I->value;
+ foreach my $x ($S->value) {
+ next if $x < $a;
+ if ($x == $a) {
+ return @union if $a == $b;
+ $I->{open} = '(';
+ } elsif ($x < $b) {
+ push(@union,Value::Interval->new($I->{open},$a,$x,')'));
+ $I->{open} = '('; $I->{data}[0] = $x;
+ } else {
+ $I->{close} = ')' if ($x == $b);
+ last;
+ }
+ }
+ return (@union,$I);
+}
+
+#
+# Subtract an interval from a set
+# (returns the resulting set or nothing for the empty set)
+#
+sub subSetInterval {
+ my $S = shift; my $I = shift;
+ my ($a,$b) = $I->value;
+ my @entries = ();
+ foreach my $x ($S->value) {
+ push(@entries,$x)
+ if ($x < $a || $x > $b) ||
+ ($x == $a && $I->{open} ne '[') ||
+ ($x == $b && $I->{close} ne ']');
+ }
+ return () unless scalar(@entries);
+ return $pkg->make(@entries);
+}
+
+#
+# Compare two sets lexicographically on their sorted contents
+#
sub compare {
my ($l,$r,$flag) = @_;
if ($l->promotePrecedence($r)) {return $r->compare($l,!$flag)}
@@ -126,4 +196,3 @@
###########################################################################
1;
-
Index: Interval.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Interval.pm,v
retrieving revision 1.21
retrieving revision 1.22
diff -Llib/Value/Interval.pm -Llib/Value/Interval.pm -u -r1.21 -r1.22
--- lib/Value/Interval.pm
+++ lib/Value/Interval.pm
@@ -11,6 +11,7 @@
use overload
'+' => sub {shift->add(@_)},
+ '-' => sub {shift->sub(@_)},
'.' => \&Value::_dot,
'x' => sub {shift->cross(@_)},
'<=>' => sub {shift->compare(@_)},
@@ -159,15 +160,54 @@
sub add {
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}
- Value::Error("Intervals can only be added to Intervals, Sets or Unions")
- unless Value::class($l) =~ m/Interval|Union|Set/ &&
- Value::class($r) =~ m/Interval|Union|Set/;
+ $r = promote($r); if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
return Value::Union->new($l,$r);
}
sub dot {my $self = shift; $self->add(@_)}
+#
+# Subtraction can split into a union
+#
+sub sub {
+ 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}
+ Value::Union::form(subIntervalInterval($l,$r));
+}
+
+#
+# Subtract an interval from another
+# (returns the resulting interval(s), set
+# or nothing for emtpy set)
+#
+sub subIntervalInterval {
+ my ($l,$r) = @_;
+ my ($a,$b) = $l->value; my ($c,$d) = $r->value;
+ my @union = ();
+ if ($d <= $a) {
+ $l->{open} = '(' if $d == $a && $r->{close} eq ']';
+ push(@union,$l) unless $a == $b && $l->{open} eq '(';
+ } elsif ($c >= $b) {
+ $l->{close} = ')' if $c == $b && $r->{open} eq '[';
+ push(@union,$l) unless $a == $b && $l->{close} eq ')';
+ } else {
+ if ($a == $c) {
+ push(@union,Value::Set->new($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));
+ }
+ if ($d == $b) {
+ push(@union,Value::Set->new($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}));
+ }
+ }
+ return @union;
+}
#
# Lexicographic order, but with type of endpoint included
@@ -176,8 +216,7 @@
sub compare {
my ($l,$r,$flag) = @_;
if ($l->promotePrecedence($r)) {return $r->compare($l,!$flag)}
- $r = promote($r);
- if ($flag) {my $tmp = $l; $l = $r; $r = $tmp};
+ $r = promote($r); if ($flag) {my $tmp = $l; $l = $r; $r = $tmp};
my ($la,$lb) = @{$l->data}; my ($ra,$rb) = @{$r->data};
my $cmp = $la <=> $ra; return $cmp if $cmp;
$cmp = $l->{open} cmp $r->{open}; return $cmp if $cmp && !$l->{ignoreEndpointTypes};
Index: Union.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Value/Union.pm,v
retrieving revision 1.15
retrieving revision 1.16
diff -Llib/Value/Union.pm -Llib/Value/Union.pm -u -r1.15 -r1.16
--- lib/Value/Union.pm
+++ lib/Value/Union.pm
@@ -9,6 +9,7 @@
use overload
'+' => sub {shift->add(@_)},
+ '-' => sub {shift->sub(@_)},
'.' => \&Value::_dot,
'x' => sub {shift->cross(@_)},
'<=>' => sub {shift->compare(@_)},
@@ -29,7 +30,7 @@
return $x if $x->type =~ m/Interval|Union|Set/;
Value::Error("Formula does not return an Interval, Set or Union");
}
- return promote($x);
+ return $self->new(promote($x));
}
Value::Error("Empty unions are not allowed") if scalar(@_) == 0;
my @intervals = (); my $isFormula = 0;
@@ -68,6 +69,16 @@
}
#
+# Make a union or interval or set, depending on how
+# many there are in the union
+#
+sub form {
+ return @_[0] if scalar(@_) == 1;
+ return Value::Set->new() if scalar(@_) == 0;
+ $pkg->new(@_);
+}
+
+#
# Return the appropriate data.
#
sub typeRef {
@@ -112,16 +123,12 @@
#
#
-# Addition forms additional unions
+# Addition forms unions
#
sub add {
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}
- Value::Error("Unions can only be added to Intervals, Sets or Unions")
- unless Value::class($l) =~ m/Interval|Union|Set/ &&
- Value::class($r) =~ m/Interval|Union|Set/;
+ $r = promote($r); if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
$l = $pkg->make($l) if ($l->class ne 'Union');
$r = $pkg->make($r) if ($r->class ne 'Union');
return $pkg->make(@{$l->data},@{$r->data});
@@ -129,14 +136,52 @@
sub dot {my $self = shift; $self->add(@_)}
#
-# @@@ Needs work @@@
+# Subtraction can split intervals into unions
+#
+sub sub {
+ 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}
+ my $ll = [($l->class eq 'Union')? $l->value: $l];
+ my $rr = [($r->class eq 'Union')? $r->value: $r];
+ form(subUnionUnion($ll,$rr));
+}
+
+#
+# Which routines to call for the various combinations
+# of sets and intervals to do subtraction
+#
+my %subCall = (
+ SetSet => \&Value::Set::subSetSet,
+ SetInterval => \&Value::Set::subSetInterval,
+ IntervalSet => \&Value::Set::subIntervalSet,
+ IntervalInterval => \&Value::Interval::subIntervalInterval,
+);
+
+#
+# Subtract a union from another by running through both lists
+# and subtracting everything in the second list from everything
+# in the first.
+#
+sub subUnionUnion {
+ my ($l,$r) = @_;
+ my @union = (@{$l});
+ foreach my $J (@{$r}) {
+ my @newUnion = ();
+ foreach my $I (@union)
+ {push(@newUnion,&{$subCall{$I->type.$J->type}}($I,$J))}
+ @union = @newUnion;
+ }
+ return @union;
+}
+
#
# Sort the intervals lexicographically, and then
# compare interval by interval.
#
sub compare {
my ($l,$r,$flag) = @_;
- if ($l->promotePrecedence($r)) {return $r->add($l,!$flag)}
+ if ($l->promotePrecedence($r)) {return $r->compare($l,!$flag)}
$r = promote($r);
if ($flag) {my $tmp = $l; $l = $r; $r = $tmp};
my @l = sort {$a <=> $b} $l->value; my @r = sort {$a <=> $b} $r->value;
@@ -161,20 +206,23 @@
}
sub string {
- my $self = shift; my $equation = shift;
- my $context = $equation->{context} || $$Value::context;
- my $union = $context->{operators}{'U'}{string} || ' U ';
+ my $self = shift; my $equation = shift; shift; shift; my $prec = shift;
+ my $op = ($equation->{context} || $$Value::context)->{operators}{'U'};
my @intervals = ();
foreach my $x (@{$self->data}) {push(@intervals,$x->string($equation))}
- return join($union,@intervals);
+ my $string = join($op->{string} || ' U ',@intervals);
+ $string = '('.$string.')' if $prec > ($op->{precedence} || 1.5);
+ return $string;
}
sub TeX {
- my $self = shift; my $equation = shift;
- my $context = $equation->{context} || $$Value::context;
- my @intervals = (); my $op = $context->{operators}{'U'};
+ my $self = shift; my $equation = shift; shift; shift; my $prec = shift;
+ my $op = ($equation->{context} || $$Value::context)->{operators}{'U'};
+ my @intervals = ();
foreach my $x (@{$self->data}) {push(@intervals,$x->TeX($equation))}
- return join($op->{TeX} || $op->{string} || ' U ',@intervals);
+ my $TeX = join($op->{TeX} || $op->{string} || ' U ',@intervals);
+ $TeX = '\left('.$TeX.'\right)' if $prec > ($op->{precedence} || 1.5);
+ return $TeX;
}
###########################################################################
|
