Parent Directory
| 
Revision Log
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 |