[system] / trunk / pg / lib / Value / Set.pm Repository:
ViewVC logotype

View of /trunk/pg/lib/Value/Set.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3716 - (download) (as text) (annotate)
Sun Oct 16 03:37:17 2005 UTC (14 years, 1 month ago) by dpvc
File size: 7145 byte(s)
In the past, when Value objects were inserted into strings, they would
automatically include parentheses so that if you had $f equal to 1+x
and $g equal to 1-x, then Formula("$f/$g") would mean (1+x)/(1-x)
rather than 1+(x/1)-x, which is what would happen as a straing string
substitution.

The problem is that this would also happen for real numbers, vectors,
and everything else, even when it wasn't necessary.  So if $x=Real(3),
then "Let x = $x" would be "Let x = (3)".

I have changed the behavior of the string concatenation for Value
objects so that parentheses are only added in a few cases: for
Formulas, Complex numbers, and Unions.  This makes the other Value
objects work more like regular variables in strings, but might cause
some problems with strings that are used as formulas.  For example, if
$a = Real(-3), then "x + 2 $a" will become "x + 2 -3", or "x-1" rather
than the expected "x - 6".  (The old approach would have made it "x +
2 (-3)" which would have worked properly).  For the most part, it is
easier to use something like "x + 2*$a" or even "x" + 2*$a in this
case, so the extra trouble of having to avoid parentheses when you
really meant to substitute the value into a string didn't seem worth
it.

    1 ###########################################################################
    2 
    3 package Value::Set;
    4 my $pkg = 'Value::Set';
    5 
    6 use strict;
    7 use vars qw(@ISA);
    8 @ISA = qw(Value);
    9 
   10 use overload
   11        '+'   => sub {shift->add(@_)},
   12        '-'   => sub {shift->sub(@_)},
   13        '.'   => sub {shift->_dot(@_)},
   14        'x'   => sub {shift->cross(@_)},
   15        '<=>' => sub {shift->compare(@_)},
   16        'cmp' => sub {shift->compare_string(@_)},
   17   'nomethod' => sub {shift->nomethod(@_)},
   18         '""' => sub {shift->stringify(@_)};
   19 
   20 #  Convert a value to a Set.  The value can be
   21 #    a list of numbers, or an reference to an array of numbers
   22 #    a point, vector or set object
   23 #    a matrix if it is  n x 1  or  1 x n
   24 #    a string that evaluates to a point
   25 #
   26 sub new {
   27   my $self = shift; my $class = ref($self) || $self;
   28   my $p = shift; $p = [$p,@_] if (scalar(@_) > 0);
   29   $p = Value::makeValue($p) if (defined($p) && !ref($p));
   30   return $p if (Value::isFormula($p) && $p->type eq Value::class($self));
   31   my $pclass = Value::class($p); my $isFormula = 0;
   32   my @d; @d = $p->dimensions if $pclass eq 'Matrix';
   33   if ($pclass eq 'List' && $p->typeRef->{entryType}{name} eq 'Number') {$p = $p->data}
   34   elsif ($pclass =~ m/Point|Vector|Set/) {$p = $p->data}
   35   elsif ($pclass eq 'Matrix' && scalar(@d) == 1) {$p = [$p->value]}
   36   elsif ($pclass eq 'Matrix' && scalar(@d) == 2 && $d[0] == 1) {$p = ($p->value)[0]}
   37   elsif ($pclass eq 'Matrix' && scalar(@d) == 2 && $d[1] == 1) {$p = ($p->transpose->value)[0]}
   38   else {
   39     $p = [$p] if (defined($p) && ref($p) ne 'ARRAY');
   40     foreach my $x (@{$p}) {
   41       $x = Value::makeValue($x);
   42       $isFormula = 1 if Value::isFormula($x);
   43       Value::Error("An element of a set can't be %s",Value::showClass($x))
   44         unless Value::isRealNumber($x);
   45     }
   46   }
   47   return $self->formula($p) if $isFormula;
   48   my $def = $$Value::context->lists->get('Set');
   49   my $set = bless {data => $p, open => $def->{open}, close => $def->{close}}, $class;
   50   $set = $set->reduce if $self->getFlag('reduceSets');
   51   return $set;
   52 }
   53 
   54 #
   55 #  Set the canBeInterval flag
   56 #
   57 sub make {
   58   my $self = shift;
   59   my $def = $$Value::context->lists->get('Set');
   60   $self = $self->SUPER::make(@_);
   61   $self->{open} = $def->{open}; $self->{close} = $def->{close};
   62   return $self;
   63 }
   64 
   65 sub isOne {0}
   66 sub isZero {0}
   67 
   68 sub canBeInUnion {1}
   69 sub isSetOfReals {1}
   70 
   71 #
   72 #  Try to promote arbitrary data to a set
   73 #
   74 sub promote {
   75   my $x = Value::makeValue(shift);
   76   return $pkg->new($x,@_) if scalar(@_) > 0 || Value::isRealNumber($x);
   77   return $x if ref($x) eq $pkg;
   78   $x = Value::Interval::promote($x) if $x->canBeInUnion;
   79   return $x if $x->isSetOfReals;
   80   return $pkg->new($x->value)
   81     if $x->type eq 'List' && $x->typeRef->{entryType}{name} eq 'Number';
   82   Value::Error("Can't convert %s to a Set",Value::showClass($x));
   83 }
   84 
   85 ############################################
   86 #
   87 #  Operations on sets
   88 #
   89 
   90 #
   91 #  Addition forms additional sets
   92 #
   93 sub add {
   94   my ($l,$r,$flag) = @_;
   95   if ($l->promotePrecedence($r)) {return $r->add($l,!$flag)}
   96   $r = promote($r); if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
   97   Value::Union::form($l,$r);
   98 }
   99 sub dot {my $self = shift; $self->add(@_)}
  100 
  101 #
  102 #  Subtraction removes items from a set
  103 #
  104 sub sub {
  105   my ($l,$r,$flag) = @_;
  106   if ($l->promotePrecedence($r)) {return $r->sub($l,!$flag)}
  107   $r = promote($r); if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
  108   return Value::Union::form(subIntervalSet($l,$r)) if Value::class($l) eq 'Interval';
  109   return Value::Union::form(subSetInterval($l,$r)) if Value::class($r) eq 'Interval';
  110   return Value::Union::form(subSetSet($l,$r));
  111 }
  112 
  113 #
  114 #  Subtract one set from another
  115 #    (return the resulting set or nothing for empty set)
  116 #
  117 sub subSetSet {
  118   my @l = $_[0]->sort->value; my @r = $_[1]->sort->value;
  119   my @entries = ();
  120   while (scalar(@l) && scalar(@r)) {
  121     if ($l[0] < $r[0]) {
  122       push(@entries,shift(@l));
  123     } else {
  124       while ($l[0] == $r[0]) {shift(@l); last if scalar(@l) == 0};
  125       shift(@r);
  126     }
  127   }
  128   push(@entries,@l);
  129   return () unless scalar(@entries);
  130   return $pkg->make(@entries);
  131 }
  132 
  133 #
  134 #  Subtract a set from an interval
  135 #    (returns a collection of intervals)
  136 #
  137 sub subIntervalSet {
  138   my $I = (shift)->copy; my $S = shift;
  139   my @union = (); my ($a,$b) = $I->value;
  140   foreach my $x ($S->reduce->value) {
  141     next if $x < $a;
  142     if ($x == $a) {
  143       return @union if $a == $b;
  144       $I->{open} = '(';
  145     } elsif ($x < $b) {
  146       push(@union,Value::Interval->make($I->{open},$a,$x,')'));
  147       $I->{open} = '('; $I->{data}[0] = $x;
  148     } else {
  149       $I->{close} = ')' if ($x == $b);
  150       last;
  151     }
  152   }
  153   return (@union,$I);
  154 }
  155 
  156 #
  157 #  Subtract an interval from a set
  158 #    (returns the resulting set or nothing for the empty set)
  159 #
  160 sub subSetInterval {
  161   my $S = shift; my $I = shift;
  162   my ($a,$b) = $I->value;
  163   my @entries = ();
  164   foreach my $x ($S->value) {
  165     push(@entries,$x)
  166       if ($x < $a || $x > $b) ||
  167          ($x == $a && $I->{open}  ne '[') ||
  168    ($x == $b && $I->{close} ne ']');
  169   }
  170   return () unless scalar(@entries);
  171   return $pkg->make(@entries);
  172 }
  173 
  174 #
  175 #  Compare two sets lexicographically on their sorted contents
  176 #
  177 sub compare {
  178   my ($l,$r,$flag) = @_;
  179   if ($l->promotePrecedence($r)) {return $r->compare($l,!$flag)}
  180   $r = promote($r);
  181   if ($r->class eq 'Interval') {
  182     return ($flag? 1: -1) if $l->length == 0;
  183     my ($a,$b) = $r->value; my $c = $l->{data}[0];
  184     return (($flag) ? $a <=> $c : $c <=> $a)
  185       if ($l->length == 1 && $a == $b) || $a != $c;
  186     return ($flag? 1: -1);
  187   }
  188   if ($l->getFlag('reduceSetsForComparison')) {$l = $l->reduce; $r = $r->reduce}
  189   if ($flag) {my $tmp = $l; $l = $r; $r = $tmp};
  190   my @l = $l->sort->value; my @r = $r->sort->value;
  191   while (scalar(@l) && scalar(@r)) {
  192     my $cmp = shift(@l) <=> shift(@r);
  193     return $cmp if $cmp;
  194   }
  195   return scalar(@l) - scalar(@r);
  196 }
  197 
  198 ############################################
  199 #
  200 #  Utility routines
  201 #
  202 
  203 #
  204 #  Remove repeated values
  205 #
  206 sub reduce {
  207   my $self = shift;
  208   return $self if $self->{isReduced} || $self->length < 2;
  209   my @data = $self->sort->value; my @set = ();
  210   while (scalar(@data)) {
  211     push(@set,shift(@data));
  212     shift(@data) while (scalar(@data) && $set[-1] == $data[0]);
  213   }
  214   return $self->make(@set)->with(isReduced=>1);
  215 }
  216 
  217 #
  218 #  True if the set is reduced
  219 #
  220 sub isReduced {
  221   my $self = shift;
  222   return 1 if $self->{isReduced} || $self->length < 2;
  223   return $self->reduce->length == $self->length;
  224 }
  225 
  226 #
  227 #  Sort the data for a set
  228 #
  229 sub sort {
  230   my $self = shift;
  231   return $self->make(CORE::sort {$a <=> $b} $self->value);
  232 }
  233 
  234 
  235 #
  236 #  Tests for containment, subsets, etc.
  237 #
  238 
  239 sub contains {
  240   my $self = shift; my $other = promote(shift)->reduce;
  241   return unless $other->type eq 'Set';
  242   return ($other-$self)->isEmpty;
  243 }
  244 
  245 sub isSubsetOf {
  246   my $self = shift; my $other = promote(shift);
  247   return $other->contains($self);
  248 }
  249 
  250 sub isEmpty {(shift)->length == 0}
  251 
  252 sub intersect {
  253   my $self = shift; my $other = shift;
  254   return $self-($self-$other);
  255 }
  256 
  257 sub intersects {
  258   my $self = shift; my $other = shift;
  259   return !$self->intersect($other)->isEmpty;
  260 }
  261 
  262 ###########################################################################
  263 
  264 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9