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

View of /trunk/pg/lib/Value/Interval.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: 7819 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 #  Implements the Interval class
    4 #
    5 package Value::Interval;
    6 my $pkg = 'Value::Interval';
    7 
    8 use strict;
    9 use vars qw(@ISA);
   10 @ISA = qw(Value);
   11 
   12 use overload
   13        '+'   => sub {shift->add(@_)},
   14        '-'   => sub {shift->sub(@_)},
   15        '.'   => sub {shift->_dot(@_)},
   16        'x'   => sub {shift->cross(@_)},
   17        '<=>' => sub {shift->compare(@_)},
   18        'cmp' => sub {shift->compare_string(@_)},
   19   'nomethod' => sub {shift->nomethod(@_)},
   20         '""' => sub {shift->stringify(@_)};
   21 
   22 #
   23 #  Convert a value to an interval.  The value consists of
   24 #    an open paren string, one or two real numbers or infinities,
   25 #    and a close paren string.
   26 #
   27 sub new {
   28   my $self = shift; my $class = ref($self) || $self;
   29   if (scalar(@_) == 1 && (!ref($_[0]) || ref($_[0]) eq 'ARRAY')) {
   30     my $x = Value::makeValue($_[0]);
   31     if (Value::isFormula($x)) {
   32       return $x if $x->type eq 'Interval';
   33       Value::Error("Formula does not return an Interval");
   34     }
   35     return promote($x);
   36   }
   37   my @params = @_;
   38   Value::Error("Interval can't be empty") unless scalar(@params) > 0;
   39   Value::Error("Extra arguments for Interval()") if scalar(@params) > 4;
   40   return Value::Set->new(@params) if scalar(@params) == 1;
   41   @params = ('(',@params,')') if (scalar(@params) == 2);
   42   my ($open,$a,$b,$close) = @params;
   43   if (!defined($close)) {$close = $b; $b = $a}
   44   $a = Value::makeValue($a); $b = Value::makeValue($b);
   45   return $self->formula($open,$a,$b,$close) if Value::isFormula($a) || Value::isFormula($b);
   46   Value::Error("Endpoints of intervals must be numbers or infinities") unless
   47     isNumOrInfinity($a) && isNumOrInfinity($b);
   48   my ($ia,$ib) = (isInfinity($a),isInfinity($b));
   49   my ($nia,$nib) = (isNegativeInfinity($a),isNegativeInfinity($b));
   50   Value::Error("Can't make an interval only out of Infinity") if ($ia && $ib) || ($nia && $nib);
   51   Value::Error("Left endpoint must be less than right endpoint")
   52     unless $nia || $ib || ($a <= $b && !$ia && !$nib);
   53   $open  = '(' if $open  eq '[' && $nia; # should be error ?
   54   $close = ')' if $close eq ']' && $ib;  # ditto?
   55   Value::Error("Open parenthesis of interval must be '(' or '['")
   56     unless $open eq '(' || $open eq '[';
   57   Value::Error("Close parenthesis of interval must be ')' or ']'")
   58     unless $close eq ')' || $close eq ']';
   59   return $self->formula($open,$a,$b,$close)
   60     if Value::isFormula($a) || Value::isFormula($b);
   61   Value::Error("Single point intervals must use '[' and ']'")
   62     if $a == $b && ($open ne '[' || $close ne ']');
   63   bless {
   64     data => [$a,$b], open => $open, close => $close,
   65     leftInfinite => $nia, rightInfinite => $ib,
   66   }, $class;
   67 }
   68 
   69 #
   70 #  Similarly for make, but without the error checks
   71 #
   72 sub make {
   73   my $self = shift; my $class = ref($self) || $self;
   74   my ($open,$a,$b,$close) = @_;
   75   $close = $b, $b = $a unless defined($close);
   76   bless {
   77     data => [$a,$b], open => $open, close => $close,
   78     leftInfinite => isNegativeInfinity($a), rightInfinite => isInfinity($b),
   79   }, $class
   80 }
   81 
   82 #
   83 #  Make a formula out of the data for an interval
   84 #
   85 sub formula {
   86   my $self = shift;
   87   my ($open,$a,$b,$close) = @_;
   88   my $formula = Value::Formula->blank;
   89   ($a,$b) = Value::toFormula($formula,$a,$b);
   90   $formula->{tree} = $formula->{context}{parser}{List}->new($formula,[$a,$b],0,
   91      $formula->{context}{parens}{$open},$Value::Type{number},$open,$close);
   92   return $formula;
   93 }
   94 
   95 #
   96 #  Tests for infinities
   97 #
   98 sub isNumOrInfinity {
   99   my $n = shift;
  100   return isInfinity($n) || isNegativeInfinity($n) || Value::isNumber($n);
  101 }
  102 sub isInfinity {
  103   my $n = shift;
  104   return $n->{tree}{isInfinity} if Value::isFormula($n);
  105   $n = Value::makeValue($n); return 0 unless ref($n);
  106   return $n->{isInfinite} && !$n->{isNegative};
  107 }
  108 sub isNegativeInfinity {
  109   my $n = shift;
  110   return $n->{tree}{isNegativeInfinity} if Value::isFormula($n);
  111   $n = Value::makeValue($n); return 0 unless ref($n);
  112   return $n->{isInfinite} && $n->{isNegative};
  113 }
  114 
  115 sub isOne {0}
  116 sub isZero {0}
  117 
  118 sub canBeInUnion {1}
  119 sub isSetOfReals {1}
  120 
  121 #
  122 #  Return the open and close parens as well as the endpoints
  123 #
  124 sub value {
  125   my $self = shift;
  126   my ($a,$b) = @{$self->data};
  127   return ($a,$b,$self->{open},$self->{close});
  128 }
  129 
  130 #
  131 #  Return the number of endpoints
  132 #
  133 sub length {
  134   my $self = shift;
  135   my ($a,$b) = $self->data;
  136   return $a == $b ? 1 : 2;
  137 }
  138 
  139 #
  140 #  Convert points and lists to intervals, when needed
  141 #
  142 sub promote {
  143   my $x = Value::makeValue(shift);
  144   return $pkg->new($x,@_) if scalar(@_) > 0;
  145   return $x if $x->isSetOfReals;
  146   return Value::Set->new($x) if Value::class($x) eq 'Real';
  147   my $open  = $x->{open};  $open  = '(' unless defined($open);
  148   my $close = $x->{close}; $close = ')' unless defined($close);
  149   return $pkg->new($open,$x->value,$close) if $x->canBeInUnion;
  150   Value::Error("Can't convert %s to an Interval",Value::showClass($x));
  151 }
  152 
  153 ############################################
  154 #
  155 #  Operations on intervals
  156 #
  157 
  158 #
  159 #  Addition forms unions
  160 #
  161 sub add {
  162   my ($l,$r,$flag) = @_;
  163   if ($l->promotePrecedence($r)) {return $r->add($l,!$flag)}
  164   $r = promote($r); if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
  165   Value::Union::form($l,$r);
  166 }
  167 sub dot {my $self = shift; $self->add(@_)}
  168 
  169 #
  170 #  Subtraction can split into a union
  171 #
  172 sub sub {
  173   my ($l,$r,$flag) = @_;
  174   if ($l->promotePrecedence($r)) {return $r->sub($l,!$flag)}
  175   $r = promote($r); if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
  176   Value::Union::form(subIntervalInterval($l,$r));
  177 }
  178 
  179 #
  180 #  Subtract an interval from another
  181 #    (returns the resulting interval(s), set
  182 #     or nothing for emtpy set)
  183 #
  184 sub subIntervalInterval {
  185   my ($l,$r) = @_; $l = $l->copy; $r = $r->copy;
  186   my ($a,$b) = $l->value; my ($c,$d) = $r->value;
  187   my @union = ();
  188   if ($d <= $a) {
  189     $l->{open} = '(' if $d == $a && $r->{close} eq ']';
  190     push(@union,$l) unless $a == $b && $l->{open} eq '(';
  191   } elsif ($c >= $b) {
  192     $l->{close} = ')' if $c == $b && $r->{open} eq '[';
  193     push(@union,$l) unless $a == $b && $l->{close} eq ')';
  194   } else {
  195     if ($a == $c) {
  196       push(@union,Value::Set->make($a))
  197   if $l->{open} eq '[' && $r->{open} eq '(';
  198     } elsif ($a < $c) {
  199       my $close = ($r->{open} eq '[')? ')': ']';
  200       push(@union,Value::Interval->make($l->{open},$a,$c,$close));
  201     }
  202     if ($d == $b) {
  203       push(@union,Value::Set->make($b))
  204   if $l->{close} eq ']' && $r->{close} eq ')';
  205     } elsif ($d < $b) {
  206       my $open = ($r->{close} eq ']') ? '(': '[';
  207       push(@union,Value::Interval->make($open,$d,$b,$l->{close}));
  208     }
  209   }
  210   return @union;
  211 }
  212 
  213 #
  214 #  Lexicographic order, but with type of endpoint included
  215 #    in the test.
  216 #
  217 sub compare {
  218   my ($l,$r,$flag) = @_;
  219   if ($l->promotePrecedence($r)) {return $r->compare($l,!$flag)}
  220   $r = promote($r); if ($flag) {my $tmp = $l; $l = $r; $r = $tmp};
  221   my ($la,$lb) = @{$l->data}; my ($ra,$rb) = @{$r->data};
  222   my $cmp = $la <=> $ra; return $cmp if $cmp;
  223   my $ignoreEndpointTypes = $l->getFlag('ignoreEndpointTypes');
  224   $cmp = $l->{open} cmp $r->{open}; return $cmp if $cmp && !$ignoreEndpointTypes;
  225   $cmp = $lb <=> $rb; return $cmp if $cmp || $ignoreEndpointTypes;
  226   return $l->{close} cmp $r->{close};
  227 }
  228 
  229 ############################################
  230 #
  231 #  Utility routines
  232 #
  233 
  234 sub reduce {shift}
  235 sub isReduced {1}
  236 sub sort {shift}
  237 
  238 
  239 #
  240 #  Tests for containment, subsets, etc.
  241 #
  242 
  243 sub contains {
  244   my $self = shift; my $other = promote(shift);
  245   return ($other - $self)->isEmpty;
  246 }
  247 
  248 sub isSubsetOf {
  249   my $self = shift; my $other = promote(shift);
  250   return $other->contains($self);
  251 }
  252 
  253 sub isEmpty {0}
  254 
  255 sub intersect {
  256   my $self = shift; my $other = shift;
  257   return $self-($self-$other);
  258 }
  259 
  260 sub intersects {
  261   my $self = shift; my $other = shift;
  262   return !$self->intersect($other)->isEmpty;
  263 }
  264 
  265 ###########################################################################
  266 
  267 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9