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

View of /trunk/pg/lib/Value/Union.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, 2 months ago) by dpvc
File size: 9579 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::Union;
    4 my $pkg = 'Value::Union';
    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 #
   21 #  Convert a value to a union of intervals.  The value must be
   22 #      a list of two or more Interval, Union or Point objects.
   23 #      Points will be converted to intervals if they are length 1 or 2.
   24 #
   25 sub new {
   26   my $self = shift; my $class = ref($self) || $self;
   27   if (scalar(@_) == 1 && !ref($_[0])) {
   28     my $x = Value::makeValue($_[0]);
   29     if (Value::isFormula($x)) {
   30       return $x if $x->type =~ m/Interval|Union|Set/;
   31       Value::Error("Formula does not return an Interval, Set or Union");
   32     }
   33     $x = promote($x); $x = $pkg->make($x) unless $x->type eq 'Union';
   34     return $x;
   35   }
   36   my @intervals = (); my $isFormula = 0;
   37   foreach my $xx (@_) {
   38     next if $xx eq ''; my $x = Value::makeValue($xx);
   39     if ($x->isFormula) {
   40       $x->{tree}->typeRef->{name} = 'Interval'
   41   if ($x->type =~ m/Point|List/ && $x->length == 2 &&
   42       $x->typeRef->{entryType}{name} eq 'Number');
   43       if ($x->type eq 'Union') {push(@intervals,$x->{tree}->makeUnion)}
   44       elsif ($x->isSetOfReals) {push(@intervals,$x)}
   45       else {Value::Error("Unions can be taken only for Intervals and Sets")}
   46       $isFormula = 1;
   47     } else {
   48       if ($x->type ne 'Interval' && $x->canBeInUnion)
   49         {$x = Value::Interval->new($x->{open},$x->value,$x->{close})}
   50       if ($x->class eq 'Union') {push(@intervals,$x->value)}
   51       elsif ($x->isSetOfReals) {push(@intervals,$x)}
   52       else {Value::Error("Unions can be taken only for Intervals or Sets")}
   53     }
   54   }
   55   Value::Error("Empty unions are not allowed") if scalar(@intervals) == 0;
   56   return $self->formula(@intervals) if $isFormula;
   57   my $union = form(@intervals);
   58   $union = $self->make($union) unless $union->type eq 'Union';
   59   return $union;
   60 }
   61 
   62 #
   63 #  Make a union or interval or set, depending on how
   64 #  many there are in the union, and mark the
   65 #
   66 #
   67 sub form {
   68   return $_[0] if scalar(@_) == 1;
   69   return Value::Set->new() if scalar(@_) == 0;
   70   my $union = $pkg->make(@_);
   71   $union = $union->reduce if $union->getFlag('reduceUnions');
   72   return $union;
   73 }
   74 
   75 #
   76 #  Return the appropriate data.
   77 #
   78 sub typeRef {
   79   my $self = shift;
   80   return Value::Type($self->class, $self->length, $self->data->[0]->typeRef);
   81 }
   82 
   83 sub isOne {0}
   84 sub isZero {0}
   85 
   86 sub canBeInUnion {1}
   87 sub isSetOfReals {1}
   88 
   89 #
   90 #  Recursively convert the list of intervals to a tree of unions
   91 #
   92 sub formula {
   93   my $selft = shift;
   94   my $formula = Value::Formula->blank;
   95   $formula->{tree} = recursiveUnion($formula,Value::toFormula($formula,@_));
   96   return $formula
   97 }
   98 sub recursiveUnion {
   99   my $formula = shift; my $right = pop(@_);
  100   return $right if (scalar(@_) == 0);
  101   return $formula->{context}{parser}{BOP}->
  102     new($formula,'U',recursiveUnion($formula,@_),$right);
  103 }
  104 
  105 #
  106 #  Try to promote arbitrary data to a set
  107 #
  108 sub promote {
  109   my $x = Value::makeValue(shift);
  110   return Value::Set->new($x,@_) if scalar(@_) > 0 || Value::isRealNumber($x);
  111   return $x if ref($x) eq $pkg;
  112   $x = Value::Interval::promote($x) if $x->canBeInUnion;
  113   return $pkg->make($x) if Value::isValue($x) && $x->isSetOfReals;
  114   Value::Error("Can't convert %s to an Interval, Set or Union",Value::showClass($x));
  115 }
  116 
  117 ############################################
  118 #
  119 #  Operations on unions
  120 #
  121 
  122 #
  123 #  Addition forms unions
  124 #
  125 sub add {
  126   my ($l,$r,$flag) = @_;
  127   if ($l->promotePrecedence($r)) {return $r->add($l,!$flag)}
  128   $r = promote($r); if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
  129   form($l->value,$r->value);
  130 }
  131 sub dot {my $self = shift; $self->add(@_)}
  132 
  133 #
  134 #  Subtraction can split intervals into unions
  135 #
  136 sub sub {
  137   my ($l,$r,$flag) = @_;
  138   if ($l->promotePrecedence($r)) {return $r->sub($l,!$flag)}
  139   $r = promote($r); if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
  140   $l = $l->reduce; $l = $pkg->make($l) unless $l->type eq 'Union';
  141   $r = $r->reduce; $r = $pkg->make($r) unless $r->type eq 'Union';
  142   form(subUnionUnion($l->data,$r->data));
  143 }
  144 
  145 #
  146 #  Which routines to call for the various combinations
  147 #    of sets and intervals to do subtraction
  148 #
  149 my %subCall = (
  150   SetSet => \&Value::Set::subSetSet,
  151   SetInterval => \&Value::Set::subSetInterval,
  152   IntervalSet => \&Value::Set::subIntervalSet,
  153   IntervalInterval => \&Value::Interval::subIntervalInterval,
  154 );
  155 
  156 #
  157 #  Subtract a union from another by running through both lists
  158 #  and subtracting everything in the second list from everything
  159 #  in the first.
  160 #
  161 sub subUnionUnion {
  162   my ($l,$r) = @_;
  163   my @union = (@{$l});
  164   foreach my $J (@{$r}) {
  165     my @newUnion = ();
  166     foreach my $I (@union)
  167       {push(@newUnion,&{$subCall{$I->type.$J->type}}($I,$J))}
  168     @union = @newUnion;
  169   }
  170   return @union;
  171 }
  172 
  173 #
  174 #  Sort the intervals lexicographically, and then
  175 #    compare interval by interval.
  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 ($l->getFlag('reduceUnionsForComparison')) {
  182     $l = $l->reduce; $l = $pkg->make($l) unless $l->type eq 'Union';
  183     $r = $r->reduce; $r = $pkg->make($r) unless $r->type eq 'Union';
  184   }
  185   if ($flag) {my $tmp = $l; $l = $r; $r = $tmp};
  186   my @l = $l->sort->value; my @r = $r->sort->value;
  187   while (scalar(@l) && scalar(@r)) {
  188     my $cmp = shift(@l) <=> shift(@r);
  189     return $cmp if $cmp;
  190   }
  191   return scalar(@l) - scalar(@r);
  192 }
  193 
  194 ############################################
  195 #
  196 #  Utility routines
  197 #
  198 
  199 #
  200 #  Reduce unions to simplest form
  201 #
  202 sub reduce {
  203   my $self = shift;
  204   return $self if $self->{isReduced};
  205   my @singletons = (); my @intervals = ();
  206   foreach my $x ($self->value) {
  207     if ($x->type eq 'Set') {push(@singletons,$x->value)}
  208     elsif ($x->{data}[0] == $x->{data}[1]) {push(@singletons,$x->{data}[0])}
  209     else {push(@intervals,$x->copy)}
  210   }
  211   my @union = (); my @set = (); my $prevX;
  212   @intervals = (CORE::sort {$a <=> $b} @intervals);
  213   ELEMENT: foreach my $x (sort {$a <=> $b} @singletons) {
  214     next if defined($prevX) && $prevX == $x; $prevX = $x;
  215     foreach my $I (@intervals) {
  216       my ($a,$b) = $I->value;
  217       last if $x < $a;
  218       if ($x > $a && $x < $b) {next ELEMENT}
  219       elsif ($x == $a) {$I->{open} = '['; next ELEMENT}
  220       elsif ($x == $b) {$I->{close} = ']'; next ELEMENT}
  221     }
  222     push(@set,$x);
  223   }
  224   while (scalar(@intervals) > 1) {
  225     my $I = shift(@intervals); my $J = $intervals[0];
  226     my ($a,$b) = $I->value; my ($c,$d) = $J->value;
  227     if ($b < $c || ($b == $c && $I->{close} eq ')' && $J->{open} eq '(')) {
  228       push(@union,$I);
  229     } else {
  230       if ($a < $c) {$J->{data}[0] = $a; $J->{open} = $I->{open}}
  231               else {$J->{open} = '[' if $I->{open} eq '['}
  232       if ($b > $d) {$J->{data}[1] = $b; $J->{close} = $I->{close}}
  233               else {$J->{close} = ']' if $b == $d && $I->{close} eq ']'}
  234     }
  235   }
  236   push(@union,@intervals);
  237   push(@union,Value::Set->make(@set)) unless scalar(@set) == 0;
  238   return Value::Set->new() if scalar(@union) == 0;
  239   return $union[0] if scalar(@union) == 1;
  240   return $pkg->make(@union)->with(isReduced=>1);
  241 }
  242 
  243 #
  244 #  True if a union is reduced
  245 #
  246 sub isReduced {
  247   my $self = shift;
  248   return 1 if $self->{isReduced};
  249   my $reduced = $self->reduce;
  250   return unless $reduced->type eq 'Union' && $reduced->length == $self->length;
  251   my @R = $reduced->sort->value; my @S = $self->sort->value;
  252   foreach my $i (0..$#R) {
  253     return unless $R[$i] == $S[$i] && $R[$i]->length == $S[$i]->length;
  254   }
  255   return 1;
  256 }
  257 
  258 #
  259 #  Sort a union lexicographically
  260 #
  261 sub sort {
  262   my $self = shift;
  263   $self->make(CORE::sort {$a <=> $b} $self->value);
  264 }
  265 
  266 
  267 #
  268 #  Tests for containment, subsets, etc.
  269 #
  270 
  271 sub contains {
  272   my $self = shift; my $other = promote(shift);
  273   return ($other - $self)->isEmpty;
  274 }
  275 
  276 sub isSubsetOf {
  277   my $self = shift; my $other = promote(shift);
  278   return $other->contains($self);
  279 }
  280 
  281 sub isEmpty {
  282   my $self = (shift)->reduce;
  283   $self->type eq 'Set' && $self->isEmpty;
  284 }
  285 
  286 sub intersect {
  287   my $self = shift; my $other = shift;
  288   return $self-($self-$other);
  289 }
  290 
  291 sub intersects {
  292   my $self = shift; my $other = shift;
  293   return !$self->intersect($other)->isEmpty;
  294 }
  295 
  296 ############################################
  297 #
  298 #  Generate the various output formats
  299 #
  300 
  301 sub pdot {'('.(shift->stringify).')'}
  302 
  303 sub stringify {
  304   my $self = shift;
  305   return $self->TeX if $$Value::context->flag('StringifyAsTeX');
  306   $self->string;
  307 }
  308 
  309 sub string {
  310   my $self = shift; my $equation = shift; shift; shift; my $prec = shift;
  311   my $op = ($equation->{context} || $$Value::context)->{operators}{'U'};
  312   my @intervals = ();
  313   foreach my $x (@{$self->data}) {push(@intervals,$x->string($equation))}
  314   my $string = join($op->{string} || ' U ',@intervals);
  315   $string = '('.$string.')' if $prec > ($op->{precedence} || 1.5);
  316   return $string;
  317 }
  318 
  319 sub TeX {
  320   my $self = shift; my $equation = shift; shift; shift; my $prec = shift;
  321   my $op = ($equation->{context} || $$Value::context)->{operators}{'U'};
  322   my @intervals = ();
  323   foreach my $x (@{$self->data}) {push(@intervals,$x->TeX($equation))}
  324   my $TeX = join($op->{TeX} || $op->{string} || ' U ',@intervals);
  325   $TeX = '\left('.$TeX.'\right)' if $prec > ($op->{precedence} || 1.5);
  326   return $TeX;
  327 }
  328 
  329 ###########################################################################
  330 
  331 1;
  332 

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9