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 package Value::Union; 4 my $pkg = 'Value::Union'; 5 6 use strict; 7 our @ISA = qw(Value); 8 9 # 10 # Convert a value to a union of intervals. The value must be 11 # a list of two or more Interval, Union or Point objects. 12 # Points will be converted to intervals if they are length 1 or 2. 13 # 14 sub new { 15 my $self = shift; my $class = ref($self) || $self; 16 my $context = (Value::isContext($_[0]) ? shift : $self->context); 17 if (scalar(@_) == 1 && !ref($_[0])) { 18 my $x = Value::makeValue($_[0],context=>$context); 19 if (Value::isFormula($x)) { 20 return $x if $x->type =~ m/Interval|Union|Set/; 21 Value::Error("Formula does not return an Interval, Set or Union"); 22 } 23 $x = $self->promote($x); $x = $self->make($x) unless $x->type eq 'Union'; 24 return $x; 25 } 26 my @intervals = (); my $isFormula = 0; 27 foreach my $xx (@_) { 28 next if $xx eq ''; my $x = Value::makeValue($xx,context=>$context); 29 if ($x->isFormula) { 30 $x->{tree}->typeRef->{name} = 'Interval' 31 if ($x->type =~ m/Point|List/ && $x->length == 2 && 32 $x->typeRef->{entryType}{name} eq 'Number'); 33 if ($x->type eq 'Union') {push(@intervals,$x->{tree}->makeUnion)} 34 elsif ($x->isSetOfReals) {push(@intervals,$x)} 35 else {Value::Error("Unions can be taken only for Intervals and Sets")} 36 $isFormula = 1; 37 } else { 38 if ($x->type ne 'Interval' && $x->canBeInUnion) 39 {$x = $self->Package("Interval")->new($x->{open},$x->value,$x->{close})} 40 if ($x->class eq 'Union') {push(@intervals,$x->value)} 41 elsif ($x->isSetOfReals) {push(@intervals,$x)} 42 else {Value::Error("Unions can be taken only for Intervals or Sets")} 43 } 44 } 45 Value::Error("Empty unions are not allowed") if scalar(@intervals) == 0; 46 return $self->formula(@intervals) if $isFormula; 47 my $union = form($self->context,@intervals); 48 $union = $self->make($union) unless $union->type eq 'Union'; 49 return $union; 50 } 51 52 # 53 # Make a union or interval or set, depending on how 54 # many there are in the union, and mark the 55 # 56 sub form { 57 my $context = shift; 58 return $_[0] if scalar(@_) == 1; 59 return Value->Package("Set",$context)->new($context) if scalar(@_) == 0; 60 my $union = $pkg->make($context,@_); 61 $union = $union->reduce if $union->getFlag('reduceUnions'); 62 return $union; 63 } 64 65 # 66 # Return the appropriate data. 67 # 68 sub typeRef { 69 my $self = shift; 70 return Value::Type($self->class, $self->length, $self->data->[0]->typeRef); 71 } 72 73 sub isOne {0} 74 sub isZero {0} 75 76 sub canBeInUnion {1} 77 sub isSetOfReals {1} 78 79 # 80 # Recursively convert the list of intervals to a tree of unions 81 # 82 sub formula { 83 my $self = shift; 84 my $formula = $self->Package("Formula")->blank($self->context); 85 $formula->{tree} = recursiveUnion($formula,Value::toFormula($formula,@_)); 86 return $formula 87 } 88 sub recursiveUnion { 89 my $formula = shift; my $right = pop(@_); 90 return $right if (scalar(@_) == 0); 91 return $formula->{context}{parser}{BOP}-> 92 new($formula,'U',recursiveUnion($formula,@_),$right); 93 } 94 95 # 96 # Try to promote arbitrary data to a set 97 # 98 sub promote { 99 my $self = shift; my $context = $self->context; 100 my $x = (scalar(@_) ? shift : $self); 101 $x = Value::makeValue($x,context=>$context); 102 return $self->Package("Set")->new($context,$x,@_) if scalar(@_) > 0 || Value::isRealNumber($x); 103 return $x if ref($x) eq $pkg; 104 $x = $self->Package("Interval")->promote($x) if $x->canBeInUnion; 105 return $self->make($x) if Value::isValue($x) && $x->isSetOfReals; 106 Value::Error("Can't convert %s to an Interval, Set or Union",Value::showClass($x)); 107 } 108 109 ############################################ 110 # 111 # Operations on unions 112 # 113 114 # 115 # Addition forms unions 116 # 117 sub add { 118 my ($self,$l,$r) = Value::checkOpOrder(@_); 119 form($self->contest,$l->value,$r->value); 120 } 121 sub dot {my $self = shift; $self->add(@_)} 122 123 # 124 # Subtraction can split intervals into unions 125 # 126 sub sub { 127 my ($self,$l,$r) = Value::checkOpOrder(@_); 128 $l = $l->reduce; $l = $self->make($l) unless $l->type eq 'Union'; 129 $r = $r->reduce; $r = $self->make($r) unless $r->type eq 'Union'; 130 form($self->context,subUnionUnion($l->data,$r->data)); 131 } 132 133 # 134 # Which routines to call for the various combinations 135 # of sets and intervals to do subtraction 136 # 137 my %subCall = ( 138 SetSet => \&Value::Set::subSetSet, 139 SetInterval => \&Value::Set::subSetInterval, 140 IntervalSet => \&Value::Set::subIntervalSet, 141 IntervalInterval => \&Value::Interval::subIntervalInterval, 142 ); 143 144 # 145 # Subtract a union from another by running through both lists 146 # and subtracting everything in the second list from everything 147 # in the first. 148 # 149 sub subUnionUnion { 150 my ($l,$r) = @_; 151 my @union = (@{$l}); 152 foreach my $J (@{$r}) { 153 my @newUnion = (); 154 foreach my $I (@union) 155 {push(@newUnion,&{$subCall{$I->type.$J->type}}($I,$J))} 156 @union = @newUnion; 157 } 158 return @union; 159 } 160 161 # 162 # Sort the intervals lexicographically, and then 163 # compare interval by interval. 164 # 165 sub compare { 166 my ($self,$l,$r) = Value::checkOpOrder(@_); 167 if ($self->getFlag('reduceUnionsForComparison')) { 168 $l = $l->reduce; $l = $self->make($l) unless $l->type eq 'Union'; 169 $r = $r->reduce; $r = $self->make($r) unless $r->type eq 'Union'; 170 } 171 my @l = $l->sort->value; my @r = $r->sort->value; 172 while (scalar(@l) && scalar(@r)) { 173 my $cmp = shift(@l) <=> shift(@r); 174 return $cmp if $cmp; 175 } 176 return scalar(@l) - scalar(@r); 177 } 178 179 ############################################ 180 # 181 # Utility routines 182 # 183 184 # 185 # Reduce unions to simplest form 186 # 187 sub reduce { 188 my $self = shift; 189 return $self if $self->{isReduced}; 190 my @singletons = (); my @intervals = (); 191 foreach my $x ($self->value) { 192 if ($x->type eq 'Set') {push(@singletons,$x->value)} 193 elsif ($x->{data}[0] == $x->{data}[1]) {push(@singletons,$x->{data}[0])} 194 else {push(@intervals,$x->copy)} 195 } 196 my @union = (); my @set = (); my $prevX; 197 @intervals = (CORE::sort {$a <=> $b} @intervals); 198 ELEMENT: foreach my $x (sort {$a <=> $b} @singletons) { 199 next if defined($prevX) && $prevX == $x; $prevX = $x; 200 foreach my $I (@intervals) { 201 my ($a,$b) = $I->value; 202 last if $x < $a; 203 if ($x > $a && $x < $b) {next ELEMENT} 204 elsif ($x == $a) {$I->{open} = '['; next ELEMENT} 205 elsif ($x == $b) {$I->{close} = ']'; next ELEMENT} 206 } 207 push(@set,$x); 208 } 209 while (scalar(@intervals) > 1) { 210 my $I = shift(@intervals); my $J = $intervals[0]; 211 my ($a,$b) = $I->value; my ($c,$d) = $J->value; 212 if ($b < $c || ($b == $c && $I->{close} eq ')' && $J->{open} eq '(')) { 213 push(@union,$I); 214 } else { 215 if ($a < $c) {$J->{data}[0] = $a; $J->{open} = $I->{open}} 216 else {$J->{open} = '[' if $I->{open} eq '['} 217 if ($b > $d) {$J->{data}[1] = $b; $J->{close} = $I->{close}} 218 else {$J->{close} = ']' if $b == $d && $I->{close} eq ']'} 219 } 220 } 221 my $context = $self->context; 222 push(@union,@intervals); 223 push(@union,$self->Package("Set")->make($context,@set)) unless scalar(@set) == 0; 224 return $self->Package("Set")->new($context) if scalar(@union) == 0; 225 return $union[0] if scalar(@union) == 1; 226 return $self->make(@union)->with(isReduced=>1); 227 } 228 229 # 230 # True if a union is reduced 231 # 232 sub isReduced { 233 my $self = shift; 234 return 1 if $self->{isReduced}; 235 my $reduced = $self->reduce; 236 return unless $reduced->type eq 'Union' && $reduced->length == $self->length; 237 my @R = $reduced->sort->value; my @S = $self->sort->value; 238 foreach my $i (0..$#R) { 239 return unless $R[$i] == $S[$i] && $R[$i]->length == $S[$i]->length; 240 } 241 return 1; 242 } 243 244 # 245 # Sort a union lexicographically 246 # 247 sub sort { 248 my $self = shift; 249 $self->make(CORE::sort {$a <=> $b} $self->value); 250 } 251 252 253 # 254 # Tests for containment, subsets, etc. 255 # 256 257 sub contains { 258 my $self = shift; my $other = $self->promote(shift); 259 return ($other - $self)->isEmpty; 260 } 261 262 sub isSubsetOf { 263 my $self = shift; my $other = $self->promote(shift); 264 return $other->contains($self); 265 } 266 267 sub isEmpty { 268 my $self = (shift)->reduce; 269 $self->type eq 'Set' && $self->isEmpty; 270 } 271 272 sub intersect { 273 my $self = shift; my $other = shift; 274 return $self-($self-$other); 275 } 276 277 sub intersects { 278 my $self = shift; my $other = shift; 279 return !$self->intersect($other)->isEmpty; 280 } 281 282 ############################################ 283 # 284 # Generate the various output formats 285 # 286 287 sub pdot {'('.(shift->stringify).')'} 288 289 sub stringify { 290 my $self = shift; 291 return $self->TeX if $self->Glag('StringifyAsTeX'); 292 $self->string; 293 } 294 295 sub string { 296 my $self = shift; my $equation = shift; shift; shift; my $prec = shift; 297 my $op = ($equation->{context} || $self->context)->{operators}{'U'}; 298 my @intervals = (); 299 foreach my $x (@{$self->data}) {push(@intervals,$x->string($equation))} 300 my $string = join($op->{string} || ' U ',@intervals); 301 $string = '('.$string.')' if $prec > ($op->{precedence} || 1.5); 302 return $string; 303 } 304 305 sub TeX { 306 my $self = shift; my $equation = shift; shift; shift; my $prec = shift; 307 my $op = ($equation->{context} || $self->context)->{operators}{'U'}; 308 my @intervals = (); 309 foreach my $x (@{$self->data}) {push(@intervals,$x->TeX($equation))} 310 my $TeX = join($op->{TeX} || $op->{string} || ' U ',@intervals); 311 $TeX = '\left('.$TeX.'\right)' if $prec > ($op->{precedence} || 1.5); 312 return $TeX; 313 } 314 315 ########################################################################### 316 317 1; 318
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |