View of /trunk/pg/lib/Value/Set.pm

    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        '-'   => sub {shift->sub(@_)},
   13        '.'   => \&Value::_dot,
   14        'x'   => sub {shift->cross(@_)},
   15        '<=>' => sub {shift->compare(@_)},
   16        'cmp' => sub {shift->compare_string(@_)},
   17   'nomethod' => sub {shift->nomethod(@_)},
   18         '""' => sub {shift->stringify(@_)};
   19 
   20 #  Convert a value to a Set.  The value can be
   21 #    a list of numbers, or an reference to an array of numbers
   22 #    a point, vector or set object
   23 #    a matrix if it is  n x 1  or  1 x n
   24 #    a string that evaluates to a point
   25 #
   26 sub new {
   27   my $self = shift; my $class = ref($self) || $self;
   28   my $p = shift; $p = [$p,@_] if (scalar(@_) > 0);
   29   $p = Value::makeValue($p) if (defined($p) && !ref($p));
   30   return $p if (Value::isFormula($p) && $p->type eq Value::class($self));
   31   my $pclass = Value::class($p); my $isFormula = 0;
   32   my @d; @d = $p->dimensions if $pclass eq 'Matrix';
   33   if ($pclass =~ m/Point|Vector|Set/) {$p = $p->data}
   34   elsif ($pclass eq 'Matrix' && scalar(@d) == 1) {$p = [$p->value]}
   35   elsif ($pclass eq 'Matrix' && scalar(@d) == 2 && $d[0] == 1) {$p = ($p->value)[0]}
   36   elsif ($pclass eq 'Matrix' && scalar(@d) == 2 && $d[1] == 1) {$p = ($p->transpose->value)[0]}
   37   else {
   38     $p = [$p] if (defined($p) && ref($p) ne 'ARRAY');
   39     foreach my $x (@{$p}) {
   40       $x = Value::makeValue($x);
   41       $isFormula = 1 if Value::isFormula($x);
   42       Value::Error("An element of a set can't be %s",Value::showClass($x))
   43         unless Value::isRealNumber($x);
   44     }
   45   }
   46   return $self->formula($p) if $isFormula;
   47   my $def = $$Value::context->lists->get('Set');
   48   my $set = bless {data => $p, canBeInterval => 1,
   49     open => $def->{open}, close => $def->{close}}, $class;
   50   $set = $set->reduce if $self->getFlag('reduceSets');
   51   return $set;
   52 }
   53 
   54 #
   55 #  Set the canBeInterval flag
   56 #
   57 sub make {
   58   my $self = shift;
   59   my $def = $$Value::context->lists->get('Set');
   60   $self = $self->SUPER::make(@_);
   61   $self->{canBeInterval} = 1;
   62   $self->{open} = $def->{open}; $self->{close} = $def->{close};
   63   return $self;
   64 }
   65 
   66 sub isOne {0}
   67 sub isZero {0}
   68 
   69 #
   70 #  Try to promote arbitrary data to a set
   71 #
   72 sub promote {
   73   my $x = shift;
   74   return $pkg->new($x,@_)
   75     if scalar(@_) > 0 || ref($x) eq 'ARRAY' || Value::isRealNumber($x);
   76   return $x if Value::class($x) =~ m/Interval|Union|Set/;
   77   Value::Error("Can't convert %s to a Set",Value::showClass($x));
   78 }
   79 
   80 ############################################
   81 #
   82 #  Operations on sets
   83 #
   84 
   85 #
   86 #  Addition forms additional sets
   87 #
   88 sub add {
   89   my ($l,$r,$flag) = @_;
   90   if ($l->promotePrecedence($r)) {return $r->add($l,!$flag)}
   91   $r = promote($r); if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
   92   Value::Union::form($l,$r);
   93 }
   94 sub dot {my $self = shift; $self->add(@_)}
   95 
   96 #
   97 #  Subtraction removes items from a set
   98 #
   99 sub sub {
  100   my ($l,$r,$flag) = @_;
  101   if ($l->promotePrecedence($r)) {return $r->sub($l,!$flag)}
  102   $r = promote($r); if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
  103   return Value::Union::form(subIntervalSet($l,$r)) if Value::class($l) eq 'Interval';
  104   return Value::Union::form(subSetInterval($l,$r)) if Value::class($r) eq 'Interval';
  105   return Value::Union::form(subSetSet($l,$r));
  106 }
  107 
  108 #
  109 #  Subtract one set from another
  110 #    (return the resulting set or nothing for empty set)
  111 #
  112 sub subSetSet {
  113   my @l = $_[0]->sort->value; my @r = $_[1]->sort->value;
  114   my @entries = ();
  115   while (scalar(@l) && scalar(@r)) {
  116     if ($l[0] < $r[0]) {push(@entries,shift(@l))}
  117       else {while ($l[0] == $r[0]) {shift(@l)}; shift(@r)}
  118   }
  119   push(@entries,@l);
  120   return () unless scalar(@entries);
  121   return $pkg->make(@entries);
  122 }
  123 
  124 #
  125 #  Subtract a set from an interval
  126 #    (returns a collection of intervals)
  127 #
  128 sub subIntervalSet {
  129   my $I = shift; my $S = shift;
  130   my @union = (); my ($a,$b) = $I->value;
  131   foreach my $x ($S->value) {
  132     next if $x < $a;
  133     if ($x == $a) {
  134       return @union if $a == $b;
  135       $I->{open} = '(';
  136     } elsif ($x < $b) {
  137       push(@union,Value::Interval->new($I->{open},$a,$x,')'));
  138       $I->{open} = '('; $I->{data}[0] = $x;
  139     } else {
  140       $I->{close} = ')' if ($x == $b);
  141       last;
  142     }
  143   }
  144   return (@union,$I);
  145 }
  146 
  147 #
  148 #  Subtract an interval from a set
  149 #    (returns the resulting set or nothing for the empty set)
  150 #
  151 sub subSetInterval {
  152   my $S = shift; my $I = shift;
  153   my ($a,$b) = $I->value;
  154   my @entries = ();
  155   foreach my $x ($S->value) {
  156     push(@entries,$x)
  157       if ($x < $a || $x > $b) ||
  158          ($x == $a && $I->{open}  ne '[') ||
  159    ($x == $b && $I->{close} ne ']');
  160   }
  161   return () unless scalar(@entries);
  162   return $pkg->make(@entries);
  163 }
  164 
  165 #
  166 #  Compare two sets lexicographically on their sorted contents
  167 #
  168 sub compare {
  169   my ($l,$r,$flag) = @_;
  170   if ($l->promotePrecedence($r)) {return $r->compare($l,!$flag)}
  171   $r = promote($r);
  172   if ($r->class eq 'Interval') {
  173     return ($flag? 1: -1) if $l->length == 0;
  174     my ($a,$b) = $r->value; my $c = $l->{data}[0];
  175     return (($flag) ? $a <=> $c : $c <=> $a)
  176       if ($l->length == 1 && $a == $b) || $a != $c;
  177     return ($flag? 1: -1);
  178   }
  179   if ($l->getFlag('reduceSetsForComparison')) {$l = $l->reduce; $r = $r->reduce}
  180   if ($flag) {my $tmp = $l; $l = $r; $r = $tmp};
  181   my @l = $l->sort->value; my @r = $r->sort->value;
  182   while (scalar(@l) && scalar(@r)) {
  183     my $cmp = shift(@l) <=> shift(@r);
  184     return $cmp if $cmp;
  185   }
  186   return scalar(@l) - scalar(@r);
  187 }
  188 
  189 #
  190 #  Remove redundant values
  191 #
  192 sub reduce {
  193   my $self = shift;
  194   return $self if $self->{isReduced} || $self->length < 2;
  195   my @data = $self->sort->value; my @set = ();
  196   while (scalar(@data)) {
  197     push(@set,shift(@data));
  198     shift(@data) while (scalar(@data) && $set[-1] == $data[0]);
  199   }
  200   return $self->make(@set)->with(isReduced=>1);
  201 }
  202 
  203 #
  204 #  Sort the data for a set
  205 #
  206 sub sort {
  207   my $self = shift;
  208   return $self->make(sort {$a <=> $b} $self->value);
  209 }
  210 
  211 ###########################################################################
  212 
  213 1;