[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 5696 - (download) (as text) (annotate)
Sat Jun 14 12:14:21 2008 UTC (11 years, 8 months ago) by dpvc
File size: 8402 byte(s)
Added

	 no strict "refs"

to try to avoid new error checking in Perl 5.10.

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9