[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 5430 - (download) (as text) (annotate)
Sun Aug 26 12:13:12 2007 UTC (12 years, 5 months ago) by dpvc
File size: 10574 byte(s)
Had the test reversed in isReduced when returning a boolean rather
than an array (Argh!)

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9