[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 5239 - (download) (as text) (annotate)
Tue Aug 7 04:32:33 2007 UTC (12 years, 4 months ago) by dpvc
File size: 8167 byte(s)
Use corret indices for the left and right endpoints.  (The paren types
are not stared in the data, only the endpoints, so use entries 0
and 1, not 1 and 2).

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9