[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 5093 - (download) (as text) (annotate)
Sat Jun 30 00:35:17 2007 UTC (12 years, 5 months ago) by dpvc
File size: 8167 byte(s)
Produce a set when the endpoints of the interval are the same.
Fixed an error with the length method.
Make transferFlags only operate on the endpoints, no the parens.
Allow subtraction between intervals and non-intervals.
Promote non-intervals in the set operations.

    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 (1,2) {$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