Menu
▾
▴
[WWcvs] pg: Added new Set object class to the Parser.
|
From: dpvc v. a. <we...@ma...> - 2005-08-11 14:17:48
|
Log Message:
-----------
Added new Set object class to the Parser. It implements a finite set
of real numbers, for use with unions and intervals. E.g., (1,2) U {3}
or (1,2) U {3,4,5}. You can created Set objects in your perl code via
the Set() command, e.g, Set(3,4,5) or Set("{1,2,3}"). You should set
the Context to Context("Interval") if you plan to use Set objects, as
this defined the braces to form sets (rather than using them as
parentheses, which is the default WW behavior). Note that in Interval
context, you can NOT use braces as parentheses.
Current, Set objects are only allowed to be sets of numbers. It would
be possible to extend that in the future.
Modified Files:
--------------
pg/macros:
Value.pl
pg/lib/Parser:
List.pm
Value.pm
Added Files:
-----------
pg/lib/Parser/List:
Set.pm
pg/lib/Value:
Set.pm
Revision Data
-------------
--- /dev/null
+++ lib/Parser/List/Set.pm
@@ -0,0 +1,28 @@
+#########################################################################
+#
+# Implements the Set class
+#
+package Parser::List::Set;
+use strict; use vars qw(@ISA);
+@ISA = qw(Parser::List);
+
+#
+# Check that the entries are numbers.
+#
+sub _check {
+ my $self = shift;
+ foreach my $x (@{$self->{coords}}) {
+ $self->Error("Sets can't contain infinity") if $x->{isInfinite};
+ $self->Error("Entries in a set must be real numbers") unless $x->isRealNumber;
+ }
+}
+
+sub checkInterval {
+ my $self = shift;
+ $self->{canBeInterval} = 1;
+}
+
+#########################################################################
+
+1;
+
--- /dev/null
+++ lib/Value/Set.pm
@@ -0,0 +1,129 @@
+###########################################################################
+
+package Value::Set;
+my $pkg = 'Value::Set';
+
+use strict;
+use vars qw(@ISA);
+@ISA = qw(Value);
+
+use overload
+ '+' => sub {shift->add(@_)},
+ '.' => \&Value::_dot,
+ 'x' => sub {shift->cross(@_)},
+ '<=>' => sub {shift->compare(@_)},
+ 'cmp' => sub {shift->compare_string(@_)},
+ 'nomethod' => sub {shift->nomethod(@_)},
+ '""' => sub {shift->stringify(@_)};
+
+# Convert a value to a Set. The value can be
+# a list of numbers, or an reference to an array of numbers
+# a point, vector or set object
+# a matrix if it is n x 1 or 1 x n
+# a string that evaluates to a point
+#
+sub new {
+ my $self = shift; my $class = ref($self) || $self;
+ my $p = shift; $p = [$p,@_] if (scalar(@_) > 0);
+ $p = Value::makeValue($p) if (defined($p) && !ref($p));
+ 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}
+ 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]}
+ else {
+ $p = [$p] if (defined($p) && ref($p) ne 'ARRAY');
+ foreach my $x (@{$p}) {
+ $x = Value::makeValue($x);
+ $isFormula = 1 if Value::isFormula($x);
+ Value::Error("An element of sets can't be %s",Value::showClass($x))
+ unless Value::isRealNumber($x);
+ }
+ }
+ return $self->formula($p) if $isFormula;
+ my $def = $$Value::context->lists->get('Set');
+ bless {
+ data => $p, canBeInterval => 1,
+ open => $def->{open}, close => $def->{close}
+ }, $class;
+}
+
+#
+# Set the canBeInterval flag
+#
+sub make {
+ 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;
+}
+
+sub isOne {0}
+sub isZero {0}
+
+#
+# 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/;
+ Value::Error("Can't convert %s to a Set",Value::showClass($x));
+}
+
+############################################
+#
+# Operations on sets
+#
+
+#
+# Addition forms additional sets
+#
+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/;
+ 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}));
+ my @entries = ();
+ while (scalar(@combined)) {
+ push(@entries,shift(@combined));
+ shift(@combined) while (scalar(@combined) && $entries[-1] == $combined[0]);
+ }
+ return $pkg->make(@entries);
+}
+sub dot {my $self = shift; $self->add(@_)}
+
+sub compare {
+ my ($l,$r,$flag) = @_;
+ if ($l->promotePrecedence($r)) {return $r->compare($l,!$flag)}
+ $r = promote($r);
+ if ($r->class eq 'Interval') {
+ return ($flag? 1: -1) if $l->length == 0;
+ my ($a,$b) = $r->value; my $c = $l->{data}[0];
+ return (($flag) ? $a <=> $c : $c <=> $a)
+ if ($l->length == 1 && $a == $b) || $a != $c;
+ return ($flag? 1: -1);
+ }
+ if ($flag) {my $tmp = $l; $l = $r; $r = $tmp};
+ my @l = sort {$a <=> $b} @{$l->data}; my @r = sort {$a <=> $b} @{$r->data};
+ while (scalar(@l) && scalar(@r)) {
+ my $cmp = shift(@l) <=> shift(@r);
+ return $cmp if $cmp;
+ }
+ return scalar(@l) - scalar(@r);
+}
+
+###########################################################################
+
+1;
+
Index: Value.pl
===================================================================
RCS file: /webwork/cvs/system/pg/macros/Value.pl,v
retrieving revision 1.6
retrieving revision 1.7
diff -Lmacros/Value.pl -Lmacros/Value.pl -u -r1.6 -r1.7
--- macros/Value.pl
+++ macros/Value.pl
@@ -14,6 +14,7 @@
sub Matrix {Value::Matrix->new(@_)}
sub List {Value::List->new(@_)}
sub Interval {Value::Interval->new(@_)}
+sub Set {Value::Set->new(@_)}
sub Union {Value::Union->new(@_)}
sub ColumnVector {Value::Vector->new(@_)->with(ColumnVector=>1,open=>undef,close=>undef)}
Index: Value.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/Value.pm,v
retrieving revision 1.13
retrieving revision 1.14
diff -Llib/Parser/Value.pm -Llib/Parser/Value.pm -u -r1.13 -r1.14
--- lib/Parser/Value.pm
+++ lib/Parser/Value.pm
@@ -37,7 +37,10 @@
value => $value, type => $type, isConstant => 1,
ref => $ref, equation => $equation,
}, $class;
- $c->{canBeInterval} = 1 if ($value->class eq 'Point' && $type->{length} == 2);
+ $c->{canBeInterval} = 1
+ if $value->{canBeInterval} ||
+ ($value->class =~ m/Point|List/ &&
+ $type->{length} == 2 && $type->{entryType}{name} eq 'Number');
$c->{isZero} = $value->isZero;
$c->{isOne} = $value->isOne;
@@ -78,7 +81,7 @@
sub perl {
my $self = shift; my $parens = shift; my $matrix = shift;
my $perl = $self->{value}->perl(0,$matrix);
- $perl = 'Closed('.$perl.')'
+ $perl = "(($perl)->with(open=>'$self->{open}',close=>'$self->{close}'))"
if $self->{canBeInterval} && $self->{open}.$self->{close} eq '[]';
$perl = '('.$perl.')' if $parens;
return $perl;
@@ -99,7 +102,7 @@
#
# Get a Union object's data
#
-sub makeUnion {@{shift->{value}->{data}}}
+sub makeUnion {@{shift->{value}{data}}}
#########################################################################
Index: List.pm
===================================================================
RCS file: /webwork/cvs/system/pg/lib/Parser/List.pm,v
retrieving revision 1.14
retrieving revision 1.15
diff -Llib/Parser/List.pm -Llib/Parser/List.pm -u -r1.14 -r1.15
--- lib/Parser/List.pm
+++ lib/Parser/List.pm
@@ -27,7 +27,7 @@
my $open = shift || ''; my $close = shift || '';
my $context = $equation->{context};
my $parens = $context->{parens}; my $list;
-
+
if ($paren && $close && $paren->{formInterval}) {
$paren = $parens->{interval}
if ($paren->{close} ne $close || (scalar(@{$coords}) == 2 &&
@@ -36,7 +36,7 @@
}
my $type = Value::Type($paren->{type},scalar(@{$coords}),$entryType,
list => 1, formMatrix => $paren->{formMatrix});
- if ($type->{name} ne 'Interval') {
+ if ($type->{name} ne 'Interval' && ($type->{name} ne 'Set' || $type->{length} != 0)) {
if ($paren->{formMatrix} && $entryType->{formMatrix}) {$type->{name} = 'Matrix'}
elsif ($entryType->{name} eq 'unknown') {
if ($paren->{formList}) {$type->{name} = 'List'}
@@ -228,7 +228,7 @@
my $perl; my @p = ();
foreach my $x (@{$self->{coords}}) {push(@p,$x->perl)}
$perl = 'new Value::'.$self->type.'('.join(',',@p).')';
- $perl = 'Closed('.$perl.')'
+ $perl = "${perl}->with(open=>'$self->{open}',close=>'$self->{close}')"
if $self->{canBeInterval} && $self->{open}.$self->{close} eq '[]';
$perl = '('.$perl.')' if $parens;
return $perl;
@@ -244,6 +244,7 @@
use Parser::List::Matrix;
use Parser::List::List;
use Parser::List::Interval;
+use Parser::List::Set;
use Parser::List::AbsoluteValue;
#########################################################################
|
