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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 5042 - (download) (as text) (annotate)
Thu Jun 28 01:31:09 2007 UTC (12 years, 7 months ago) by dpvc
File size: 9452 byte(s)
Recent changes to automatically do promotion in the Value methods was
a mistake.  I put it back into the subclass methods again.

    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 = $context->Package("Interval")->new($context,$x->{open},$x->value,$x->{close})}
   40       if ($x->classMatch('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 $context->Package("Set")->new($context) if scalar(@_) == 0;
   60   my $union = $context->Package("Union")->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->Item("BOP")->new($formula,'U',recursiveUnion($formula,@_),$right);
   92 }
   93 
   94 #
   95 #  Try to promote arbitrary data to a set
   96 #
   97 sub promote {
   98   my $self = shift;
   99   my $context = (Value::isContext($_[0]) ? shift : $self->context);
  100   my $x = (scalar(@_) ? shift : $self);
  101   $x = Value::makeValue($x,context=>$context);
  102   return $context->Package("Set")->new($context,$x,@_) if scalar(@_) > 0 || Value::isRealNumber($x);
  103   return $x->inContext($context) if ref($x) eq $pkg;
  104   $x = $context->Package("Interval")->promote($context,$x) if $x->canBeInUnion;
  105   return $self->make($context,$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->getFlag('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