Parent Directory
| 
Revision Log
Update new() and make() methods to accept a context as the first parameter (making it easier to create objects in a given context without having to resort to a separate call to coerce them to the given context after the fact).
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("Extra arguments for Interval()") if scalar(@params) > 4; 30 return $self->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 bless { 54 data => [$a,$b], open => $open, close => $close, 55 leftInfinite => $nia, rightInfinite => $ib, 56 context => $context, 57 }, $class; 58 } 59 60 # 61 # Similarly for make, but without the error checks 62 # 63 sub make { 64 my $self = shift; my $class = ref($self) || $self; 65 my ($open,$a,$b,$close) = @_; 66 $close = $b, $b = $a unless defined($close); 67 bless { 68 data => [$a,$b], open => $open, close => $close, 69 leftInfinite => isNegativeInfinity($a), rightInfinite => isInfinity($b), 70 context => $self->context, 71 }, $class 72 } 73 74 # 75 # Make a formula out of the data for an interval 76 # 77 sub formula { 78 my $self = shift; 79 my ($open,$a,$b,$close) = @_; 80 my $formula = $self->Package("Formula")->blank($self->context); 81 ($a,$b) = Value::toFormula($formula,$a,$b); 82 $formula->{tree} = $formula->{context}{parser}{List}->new($formula,[$a,$b],0, 83 $formula->{context}{parens}{$open},$Value::Type{number},$open,$close); 84 return $formula; 85 } 86 87 # 88 # Tests for infinities 89 # 90 sub isNumOrInfinity { 91 my $n = shift; 92 return isInfinity($n) || isNegativeInfinity($n) || Value::isNumber($n); 93 } 94 sub isInfinity { 95 my $n = shift; 96 return $n->{tree}{isInfinity} if Value::isFormula($n); 97 $n = Value::makeValue($n); return 0 unless ref($n); 98 return $n->{isInfinite} && !$n->{isNegative}; 99 } 100 sub isNegativeInfinity { 101 my $n = shift; 102 return $n->{tree}{isNegativeInfinity} if Value::isFormula($n); 103 $n = Value::makeValue($n); return 0 unless ref($n); 104 return $n->{isInfinite} && $n->{isNegative}; 105 } 106 107 sub isOne {0} 108 sub isZero {0} 109 110 sub canBeInUnion {1} 111 sub isSetOfReals {1} 112 113 # 114 # Return the open and close parens as well as the endpoints 115 # 116 sub value { 117 my $self = shift; 118 my ($a,$b) = @{$self->data}; 119 return ($a,$b,$self->{open},$self->{close}); 120 } 121 122 # 123 # Return the number of endpoints 124 # 125 sub length { 126 my $self = shift; 127 my ($a,$b) = $self->data; 128 return $a == $b ? 1 : 2; 129 } 130 131 # 132 # Convert points and lists to intervals, when needed 133 # 134 sub promote { 135 my $self = shift; my $x = (scalar(@_) ? shift : $self); 136 $x = Value::makeValue($x,context=>$self->context); 137 return $self->new($x,@_) if scalar(@_) > 0; 138 return $x if $x->isSetOfReals; 139 return $self->Package("Set")->new($self->context,$x) if Value::isReal($x); 140 my $open = $x->{open}; $open = '(' unless defined($open); 141 my $close = $x->{close}; $close = ')' unless defined($close); 142 return $self->new($open,$x->value,$close) if $x->canBeInUnion; 143 Value::Error("Can't convert %s to %s",$x->showClass,$self->showClass); 144 } 145 146 ############################################ 147 # 148 # Operations on intervals 149 # 150 151 # 152 # Addition forms unions 153 # 154 sub add { 155 my ($self,$l,$r) = Value::checkOpOrder(@_); 156 Value::Union::form($self->context,$l,$r); 157 } 158 sub dot {my $self = shift; $self->add(@_)} 159 160 # 161 # Subtraction can split into a union 162 # 163 sub sub { 164 my ($self,$l,$r) = Value::checkOpOrder(@_); 165 Value::Union::form($self->context,subIntervalInterval($l,$r)); 166 } 167 168 # 169 # Subtract an interval from another 170 # (returns the resulting interval(s), set 171 # or nothing for emtpy set) 172 # 173 sub subIntervalInterval { 174 my ($l,$r) = @_; $l = $l->copy; $r = $r->copy; 175 my ($a,$b) = $l->value; my ($c,$d) = $r->value; 176 my $self = $l; my $context = $self->context; 177 my @union = (); 178 if ($d <= $a) { 179 $l->{open} = '(' if $d == $a && $r->{close} eq ']'; 180 push(@union,$l) unless $a == $b && $l->{open} eq '('; 181 } elsif ($c >= $b) { 182 $l->{close} = ')' if $c == $b && $r->{open} eq '['; 183 push(@union,$l) unless $a == $b && $l->{close} eq ')'; 184 } else { 185 if ($a == $c) { 186 push(@union,$self->Package("Set")->make($context,$a)) 187 if $l->{open} eq '[' && $r->{open} eq '('; 188 } elsif ($a < $c) { 189 my $close = ($r->{open} eq '[')? ')': ']'; 190 push(@union,$self->Package("Interval")->make($context,$l->{open},$a,$c,$close)); 191 } 192 if ($d == $b) { 193 push(@union,$self->Package("Set")->make($context,$b)) 194 if $l->{close} eq ']' && $r->{close} eq ')'; 195 } elsif ($d < $b) { 196 my $open = ($r->{close} eq ']') ? '(': '['; 197 push(@union,$self->Package("Interval")->make($context,$open,$d,$b,$l->{close})); 198 } 199 } 200 return @union; 201 } 202 203 # 204 # Lexicographic order, but with type of endpoint included 205 # in the test. 206 # 207 sub compare { 208 my ($self,$l,$r) = Value::checkOpOrder(@_); 209 my ($la,$lb) = $l->value; my ($ra,$rb) = $r->value; 210 my $cmp = $la <=> $ra; return $cmp if $cmp; 211 my $ignoreEndpointTypes = $l->getFlag('ignoreEndpointTypes'); 212 $cmp = $l->{open} cmp $r->{open}; return $cmp if $cmp && !$ignoreEndpointTypes; 213 $cmp = $lb <=> $rb; return $cmp if $cmp || $ignoreEndpointTypes; 214 return $l->{close} cmp $r->{close}; 215 } 216 217 ############################################ 218 # 219 # Utility routines 220 # 221 222 sub reduce {shift} 223 sub isReduced {1} 224 sub sort {shift} 225 226 227 # 228 # Tests for containment, subsets, etc. 229 # 230 231 sub contains { 232 my $self = shift; my $other = $self->promote(shift); 233 return ($other - $self)->isEmpty; 234 } 235 236 sub isSubsetOf { 237 my $self = shift; my $other = $self->promote(shift); 238 return $other->contains($self); 239 } 240 241 sub isEmpty {0} 242 243 sub intersect { 244 my $self = shift; my $other = shift; 245 return $self-($self-$other); 246 } 247 248 sub intersects { 249 my $self = shift; my $other = shift; 250 return !$self->intersect($other)->isEmpty; 251 } 252 253 ########################################################################### 254 255 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |