Parent Directory
| 
Revision Log
Added new Set object class to the Parser. It implements a finite set
of real numbers, for use with unions and intervals. E.g., (1,2) U {3}
or (1,2) U {3,4,5}. You can created Set objects in your perl code via
the Set() command, e.g, Set(3,4,5) or Set("{1,2,3}"). You should set
the Context to Context("Interval") if you plan to use Set objects, as
this defined the braces to form sets (rather than using them as
parentheses, which is the default WW behavior). Note that in Interval
context, you can NOT use braces as parentheses.
Current, Set objects are only allowed to be sets of numbers. It would
be possible to extend that in the future.
1 ########################################################################### 2 3 package Value::Set; 4 my $pkg = 'Value::Set'; 5 6 use strict; 7 use vars qw(@ISA); 8 @ISA = qw(Value); 9 10 use overload 11 '+' => sub {shift->add(@_)}, 12 '.' => \&Value::_dot, 13 'x' => sub {shift->cross(@_)}, 14 '<=>' => sub {shift->compare(@_)}, 15 'cmp' => sub {shift->compare_string(@_)}, 16 'nomethod' => sub {shift->nomethod(@_)}, 17 '""' => sub {shift->stringify(@_)}; 18 19 # Convert a value to a Set. The value can be 20 # a list of numbers, or an reference to an array of numbers 21 # a point, vector or set object 22 # a matrix if it is n x 1 or 1 x n 23 # a string that evaluates to a point 24 # 25 sub new { 26 my $self = shift; my $class = ref($self) || $self; 27 my $p = shift; $p = [$p,@_] if (scalar(@_) > 0); 28 $p = Value::makeValue($p) if (defined($p) && !ref($p)); 29 return $p if (Value::isFormula($p) && $p->type eq Value::class($self)); 30 my $pclass = Value::class($p); my $isFormula = 0; 31 my @d; @d = $p->dimensions if $pclass eq 'Matrix'; 32 if ($pclass =~ m/Point|Vector|Set/) {$p = $p->data} 33 elsif ($pclass eq 'Matrix' && scalar(@d) == 1) {$p = [$p->value]} 34 elsif ($pclass eq 'Matrix' && scalar(@d) == 2 && $d[0] == 1) {$p = ($p->value)[0]} 35 elsif ($pclass eq 'Matrix' && scalar(@d) == 2 && $d[1] == 1) {$p = ($p->transpose->value)[0]} 36 else { 37 $p = [$p] if (defined($p) && ref($p) ne 'ARRAY'); 38 foreach my $x (@{$p}) { 39 $x = Value::makeValue($x); 40 $isFormula = 1 if Value::isFormula($x); 41 Value::Error("An element of sets can't be %s",Value::showClass($x)) 42 unless Value::isRealNumber($x); 43 } 44 } 45 return $self->formula($p) if $isFormula; 46 my $def = $$Value::context->lists->get('Set'); 47 bless { 48 data => $p, canBeInterval => 1, 49 open => $def->{open}, close => $def->{close} 50 }, $class; 51 } 52 53 # 54 # Set the canBeInterval flag 55 # 56 sub make { 57 my $self = shift; my $def = $$Value::context->lists->get('Set'); 58 $self = $self->SUPER::make(@_); 59 $self->{canBeInterval} = 1; 60 $self->{open} = $def->{open}; $self->{close} = $def->{close}; 61 return $self; 62 } 63 64 sub isOne {0} 65 sub isZero {0} 66 67 # 68 # Try to promote arbitrary data to a set 69 # 70 sub promote { 71 my $x = shift; 72 return $pkg->new($x,@_) 73 if scalar(@_) > 0 || ref($x) eq 'ARRAY' || Value::isRealNumber($x); 74 return $x if Value::class($x) =~ m/Interval|Union|Set/; 75 Value::Error("Can't convert %s to a Set",Value::showClass($x)); 76 } 77 78 ############################################ 79 # 80 # Operations on sets 81 # 82 83 # 84 # Addition forms additional sets 85 # 86 sub add { 87 my ($l,$r,$flag) = @_; 88 if ($l->promotePrecedence($r)) {return $r->add($l,!$flag)} 89 $r = promote($r); 90 if ($flag) {my $tmp = $l; $l = $r; $r = $tmp} 91 Value::Error("Sets can only be added to Intervals, Sets or Unions") 92 unless Value::class($l) =~ m/Interval|Union|Set/ && 93 Value::class($r) =~ m/Interval|Union|Set/; 94 return Value::Union->new($l,$r) 95 unless Value::class($l) eq 'Set' && Value::class($r) eq 'Set'; 96 my @combined = (sort {$a <=> $b} (@{$l->data},@{$r->data})); 97 my @entries = (); 98 while (scalar(@combined)) { 99 push(@entries,shift(@combined)); 100 shift(@combined) while (scalar(@combined) && $entries[-1] == $combined[0]); 101 } 102 return $pkg->make(@entries); 103 } 104 sub dot {my $self = shift; $self->add(@_)} 105 106 sub compare { 107 my ($l,$r,$flag) = @_; 108 if ($l->promotePrecedence($r)) {return $r->compare($l,!$flag)} 109 $r = promote($r); 110 if ($r->class eq 'Interval') { 111 return ($flag? 1: -1) if $l->length == 0; 112 my ($a,$b) = $r->value; my $c = $l->{data}[0]; 113 return (($flag) ? $a <=> $c : $c <=> $a) 114 if ($l->length == 1 && $a == $b) || $a != $c; 115 return ($flag? 1: -1); 116 } 117 if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}; 118 my @l = sort {$a <=> $b} @{$l->data}; my @r = sort {$a <=> $b} @{$r->data}; 119 while (scalar(@l) && scalar(@r)) { 120 my $cmp = shift(@l) <=> shift(@r); 121 return $cmp if $cmp; 122 } 123 return scalar(@l) - scalar(@r); 124 } 125 126 ########################################################################### 127 128 1; 129
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |