[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 2678 - (download) (as text) (annotate)
Mon Aug 23 23:55:37 2004 UTC (15 years, 6 months ago) by dpvc
File size: 4555 byte(s)
Modified the parser so that the classes for the various object
constructors are stored in the context table rather than hard-coded
into the parser.  That way, you can override the default classes with
your own.  This gives you even more complete control to modify the
parser.  (You had been able to replace the definitions of operators,
functions and list-like objects, but could not override the behaviour
of numbers, strings, variables, and so on.  Now you can.)

This effects most of the files, but only by changing the name of the
calls that create the various objects.

There are also a couple of other minor fixes.

    1 ###########################################################################
    2 
    3 package Value::Union;
    4 my $pkg = 'Value::Union';
    5 
    6 use strict;
    7 use vars qw(@ISA);
    8 @ISA = qw(Value);
    9 
   10 use overload
   11        '+'   => \&add,
   12        '.'   => \&Value::_dot,
   13        'x'   => \&Value::cross,
   14        '<=>' => \&compare,
   15        'cmp' => \&Value::cmp,
   16   'nomethod' => \&Value::nomethod,
   17         '""' => \&Value::stringify;
   18 
   19 #
   20 #  Convert a value to a union of intervals.  The value must be
   21 #      a list of two or more Interval, Union or Point objects.
   22 #      Points will be converted to intervals if they are length 1 or 2.
   23 #
   24 sub new {
   25   my $self = shift; my $class = ref($self) || $self;
   26   @_ = split("U",@_[0]) if scalar(@_) == 1 && !ref($_[0]);
   27   Value::Error("Unions must be of at least two intervals") unless scalar(@_) > 1;
   28   my @intervals = (); my $isFormula = 0;
   29   foreach my $xx (@_) {
   30     my $x = $xx; $x = Value::Interval->new($x) if !ref($x);
   31     if (Value::isFormula($x)) {
   32       $x->{tree}->typeRef->{name} = 'Interval' if ($x->type eq 'Point' && $x->length == 1);
   33       if ($x->type eq 'Interval') {push(@intervals,$x)}
   34       elsif ($x->type eq 'Union') {push(@intervals,$x->{tree}->makeUnion)}
   35       else {Value::Error("Unions can be taken only for Intervals")}
   36       $isFormula = 1;
   37     } else {
   38       if (Value::class($x) eq 'Point' || Value::class($x) eq 'List') {
   39         if ($x->length == 1) {$x = Value::Interval->new('[',$x->value,$x->value,']')}
   40         elsif ($x->length == 2) {$x = Value::Interval->new($x->{open},$x->value,$x->{close})}
   41       }
   42       if (Value::class($x) eq 'Interval') {push(@intervals,$x)}
   43       elsif (Value::class($x) eq 'Union') {push(@intervals,@{$x->{data}})}
   44       else {Value::Error("Unions can be taken only for Intervals")}
   45     }
   46   }
   47   return $self->formula(@intervals) if $isFormula;
   48   bless {data => [@intervals], canBeInterval => 1}, $class;
   49 }
   50 
   51 #
   52 #  Return the appropriate data.
   53 #
   54 sub length {return scalar(@{shift->{data}})}
   55 sub typeRef {
   56   my $self = shift;
   57   return Value::Type($self->class, $self->length, $self->data->[0]->typeRef);
   58 }
   59 
   60 #
   61 #  Recursively convert the list of intervals to a tree of unions
   62 #
   63 sub formula {
   64   my $selft = shift;
   65   my $formula = Value::Formula->blank;
   66   $formula->{tree} = recursiveUnion($formula,Value::toFormula($formula,@_));
   67 #   return $formula->eval if scalar(%{$formula->{variables}}) == 0;
   68   return $formula
   69 }
   70 sub recursiveUnion {
   71   my $formula = shift; my $right = pop(@_);
   72   return $right if (scalar(@_) == 0);
   73   return $formula->{context}{parser}{BOP}->
   74     new($formula,'U',recursiveUnion($formula,@_),$right);
   75 }
   76 
   77 ############################################
   78 #
   79 #  Operations on unions
   80 #
   81 
   82 #
   83 #  Addition forms additional unions
   84 #
   85 sub add {
   86   my ($l,$r,$flag) = @_;
   87   if ($l->promotePrecedence($r)) {return $r->add($l,!$flag)}
   88   if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
   89   Value::Error("Unions can only be added to Intervals or Unions")
   90     unless Value::class($l) =~ m/Interval|Union/ &&
   91            Value::class($r) =~ m/Interval|Union/;
   92   $l = $pkg->make($l) if ($l->class eq 'Interval');
   93   $r = $pkg->make($r) if ($r->class eq 'Interval');
   94   return $pkg->make(@{$l->data},@{$r->data});
   95 }
   96 sub dot {add(@_)}
   97 
   98 #
   99 #  @@@ Needs work @@@
  100 #
  101 #  Sort the intervals lexicographically, and then
  102 #    compare interval by interval.
  103 #
  104 sub compare {
  105   my ($l,$r,$flag) = @_;
  106   if ($flag) {my $tmp = $l; $l = $r; $r = $tmp};
  107   return  1 if Value::class($r) ne 'Union';
  108   return -1 if Value::class($l) ne 'Union';
  109   my @l = sort(@{$l->data}); my @r = sort(@{$r->data});
  110   return scalar(@l) <=> scalar(@r) unless scalar(@l) == scalar(@r);
  111   my $cmp = 0;
  112   foreach my $i (0..$#l) {
  113     $cmp = $l[$i] <=> $r[$i];
  114     last if $cmp;
  115   }
  116   return $cmp;
  117 }
  118 
  119 # @@@ simplify (combine intervals, if possible) @@@
  120 
  121 ############################################
  122 #
  123 #  Generate the various output formats
  124 #
  125 
  126 sub string {
  127   my $self = shift; my $equation = shift;
  128   my $context = $equation->{context} || $$Value::context;
  129   my $union = $context->{operators}{'U'}{string} || ' U ';
  130   my @intervals = ();
  131   foreach my $x (@{$self->data}) {push(@intervals,$x->string($equation))}
  132   return join($union,@intervals);
  133 }
  134 
  135 sub TeX {
  136   my $self = shift; my $equation = shift;
  137   my $context = $equation->{context} || $$Value::context;
  138   my @intervals = (); my $op = $context->{operators}{'U'};
  139   foreach my $x (@{$self->data}) {push(@intervals,$x->TeX($equation))}
  140   return join($op->{TeX} || $op->{string} || ' U ',@intervals);
  141 }
  142 
  143 ###########################################################################
  144 
  145 1;
  146 

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9