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

    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;