[system] / trunk / pg / lib / Value / Set.pm Repository:
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 5696 - (download) (as text) (annotate)
Sat Jun 14 12:14:21 2008 UTC (11 years, 8 months ago) by dpvc
File size: 7334 byte(s)
Added

	 no strict "refs"

to try to avoid new error checking in Perl 5.10.

    1 ###########################################################################
    2 
    3 package Value::Set;
    4 my $pkg = 'Value::Set';
    5 
    6 use strict; no strict "refs";
    7 our @ISA = qw(Value);
    8 
    9 #  Convert a value to a Set.  The value can be
   10 #    a list of numbers, or an reference to an array of numbers
   11 #    a point, vector or set object
   12 #    a matrix if it is  n x 1  or  1 x n
   13 #    a string that evaluates to a point
   14 #
   15 sub new {
   16   my $self = shift; my $class = ref($self) || $self;
   17   my $context = (Value::isContext($_[0]) ? shift : $self->context);
   18   my $p = shift; $p = [$p,@_] if scalar(@_) > 0;
   19   $p = Value::makeValue($p,context=>$context) if defined($p) && !ref($p);
   20   return $p if Value::isFormula($p) && Value::classMatch($self,$p->type);
   21   my $isFormula = 0; my @d; @d = $p->dimensions if Value::classMatch($p,'Matrix');
   22   if (Value::classMatch($p,'List') && $p->typeRef->{entryType}{name} eq 'Number') {$p = $p->data}
   23   elsif (Value::classMatch($p,'Point','Vector','Set')) {$p = $p->data}
   24   elsif (scalar(@d) == 1) {$p = [$p->value]}
   25   elsif (scalar(@d) == 2 && $d[0] == 1) {$p = ($p->value)[0]}
   26   elsif (scalar(@d) == 2 && $d[1] == 1) {$p = ($p->transpose->value)[0]}
   27   else {
   28     $p = [$p] if defined($p) && ref($p) ne 'ARRAY';
   29     foreach my $x (@{$p}) {
   30       $x = Value::makeValue($x,context=>$context);
   31       $isFormula = 1 if Value::isFormula($x);
   32       Value::Error("An element of a set can't be %s",Value::showClass($x))
   33         unless Value::isRealNumber($x);
   34     }
   35   }
   36   return $self->formula($p) if $isFormula;
   37   my $def = $context->lists->get('Set');
   38   my $set = bless {
   39     data => $p, open => $def->{open}, close => $def->{close},
   40     context => $context,
   41   }, $class;
   42   $set = $set->reduce if $self->getFlag('reduceSets');
   43   return $set;
   44 }
   45 
   46 #
   47 #  Set the canBeInterval flag
   48 #
   49 sub make {
   50   my $self = shift;
   51   my $context = (Value::isContext($_[0]) ? shift : $self->context);
   52   my $def = $context->lists->get('Set');
   53   $self = $self->SUPER::make($context,@_);
   54   $self->{open} = $def->{open}; $self->{close} = $def->{close};
   55   return $self;
   56 }
   57 
   58 sub isOne {0}
   59 sub isZero {0}
   60 
   61 sub canBeInUnion {1}
   62 sub isSetOfReals {1}
   63 
   64 #
   65 #  Try to promote arbitrary data to a set
   66 #
   67 sub promote {
   68   my $self = shift; my $class = ref($self) || $self;
   69   my $context = (Value::isContext($_[0]) ? shift : $self->context);
   70   my $x = (scalar(@_) ? shift : $self);
   71   $x = Value::makeValue($x,context=>$context);
   72   return $self->new($context,$x,@_) if scalar(@_) > 0 || Value::isRealNumber($x);
   73   return $x->inContext($context) if ref($x) eq $class;
   74   $x = $context->Package("Interval")->promote($context,$x) if $x->canBeInUnion;
   75   return $x->inContext($context) if $x->isSetOfReals;
   76   return $self->new($context,$x->value)
   77     if $x->type eq 'List' && $x->typeRef->{entryType}{name} eq 'Number';
   78   Value::Error("Can't convert %s to %s",Value::showClass($x),Value::showClass($self));
   79 }
   80 
   81 ############################################
   82 #
   83 #  Operations on sets
   84 #
   85 
   86 #
   87 #  Addition forms unions (or combines sets)
   88 #
   89 sub add {
   90   my ($self,$l,$r) = Value::checkOpOrderWithPromote(@_);
   91   return $self->make($l->value,$r->value) if $l->type eq 'Set' && $r->type eq 'Set';
   92   Value::Union::form($self->context,$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 ($self,$l,$r) = Value::checkOpOrderWithPromote(@_);
  101   return Value::Union::form($self->context,Value::Union::subUnionUnion([$l],[$r]));
  102 }
  103 
  104 #
  105 #  Subtract one set from another
  106 #    (return the resulting set or nothing for empty set)
  107 #
  108 sub subSetSet {
  109   my ($self,$other) = @_;
  110   my @l = $self->sort->value; my @r = $other->sort->value;
  111   my @entries = ();
  112   while (scalar(@l) && scalar(@r)) {
  113     if ($l[0] < $r[0]) {
  114       push(@entries,shift(@l));
  115     } else {
  116       while ($l[0] == $r[0]) {shift(@l); last if scalar(@l) == 0};
  117       shift(@r);
  118     }
  119   }
  120   push(@entries,@l);
  121   return () unless scalar(@entries);
  122   return $self->make(@entries);
  123 }
  124 
  125 #
  126 #  Subtract a set from an interval
  127 #    (returns a collection of intervals)
  128 #
  129 sub subIntervalSet {
  130   my $self = shift;
  131   my $I = $self->copy; my $S = shift;
  132   my @union = (); my ($a,$b) = $I->value;
  133   foreach my $x ($S->reduce->value) {
  134     next if $x < $a;
  135     if ($x == $a) {
  136       return @union if $a == $b;
  137       $I->{open} = '(';
  138     } elsif ($x < $b) {
  139       my $context = $self->context;
  140       push(@union,$context->Package("Interval")->make($context,$I->{open},$a,$x,')'));
  141       $I->{open} = '('; $I->{data}[0] = $a = $x;
  142     } else {
  143       $I->{close} = ')' if ($x == $b);
  144       last;
  145     }
  146   }
  147   return (@union,$I);
  148 }
  149 
  150 #
  151 #  Subtract an interval from a set
  152 #    (returns the resulting set or nothing for the empty set)
  153 #
  154 sub subSetInterval {
  155   my $S = shift; my $I = shift;
  156   my ($a,$b) = $I->value;
  157   my @entries = ();
  158   foreach my $x ($S->value) {
  159     push(@entries,$x)
  160       if ($x < $a || $x > $b) ||
  161          ($x == $a && $I->{open}  ne '[') ||
  162    ($x == $b && $I->{close} ne ']');
  163   }
  164   return () unless scalar(@entries);
  165   return $S->make(@entries);
  166 }
  167 
  168 #
  169 #  Compare two sets lexicographically on their sorted contents
  170 #
  171 sub compare {
  172   my ($l,$r,$flag) = @_; my $self = $l;
  173   $r = $self->promote($r);
  174   if ($r->classMatch('Interval')) {
  175     return ($flag? 1: -1) if $l->length == 0;
  176     my ($a,$b) = $r->value; my $c = $l->{data}[0];
  177     return (($flag) ? $a <=> $c : $c <=> $a)
  178       if ($l->length == 1 && $a == $b) || $a != $c;
  179     return ($flag? 1: -1);
  180   }
  181   if ($l->getFlag('reduceSetsForComparison')) {$l = $l->reduce; $r = $r->reduce}
  182   if ($flag) {my $tmp = $l; $l = $r; $r = $tmp};
  183   my @l = $l->sort->value; my @r = $r->sort->value;
  184   while (scalar(@l) && scalar(@r)) {
  185     my $cmp = shift(@l) <=> shift(@r);
  186     return $cmp if $cmp;
  187   }
  188   return scalar(@l) - scalar(@r);
  189 }
  190 
  191 ############################################
  192 #
  193 #  Utility routines
  194 #
  195 
  196 #
  197 #  Remove repeated values
  198 #
  199 sub reduce {
  200   my $self = shift;
  201   return $self if $self->{isReduced} || $self->length < 2;
  202   my @data = $self->sort->value; my @set = ();
  203   while (scalar(@data)) {
  204     push(@set,shift(@data));
  205     shift(@data) while (scalar(@data) && $set[-1] == $data[0]);
  206   }
  207   return $self->make(@set)->with(isReduced=>1);
  208 }
  209 
  210 #
  211 #  True if a union is reduced.
  212 #
  213 #  (In scalar context, is a pair whose first entry is true or
  214 #   false, and when true the second value is the reason the
  215 #   set is not reduced.)
  216 #
  217 sub isReduced {
  218   my $self = shift;
  219   return 1 if $self->{isReduced} || $self->length < 2;
  220   my $isReduced = $self->reduce->length == $self->length;
  221   return $isReduced if $isReduced || !wantarray;
  222   return (0,"repeated elements");
  223 }
  224 
  225 #
  226 #  Sort the data for a set
  227 #
  228 sub sort {
  229   my $self = shift;
  230   return $self->make(CORE::sort {$a <=> $b} $self->value);
  231 }
  232 
  233 
  234 #
  235 #  Tests for containment, subsets, etc.
  236 #
  237 
  238 sub contains {
  239   my $self = shift; my $other = $self->promote(@_)->reduce;
  240   return unless $other->type eq 'Set';
  241   return ($other-$self)->isEmpty;
  242 }
  243 
  244 sub isSubsetOf {
  245   my $self = shift; my $other = $self->promote(@_);
  246   return $other->contains($self);
  247 }
  248 
  249 sub isEmpty {(shift)->length == 0}
  250 
  251 sub intersect {
  252   my $self = shift; my $other = $self->promote(@_);
  253   return $self-($self-$other);
  254 }
  255 
  256 sub intersects {
  257   my $self = shift; my $other = $self->promote(@_);
  258   return !$self->intersect($other)->isEmpty;
  259 }
  260 
  261 ###########################################################################
  262 
  263 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9