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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2625 - (download) (as text) (annotate)
Mon Aug 16 18:35:12 2004 UTC (15 years, 3 months ago) by dpvc
File size: 8351 byte(s)
Added string comparison to all Value object classes (to compare the
string value of an object to another string).

Overloaded perl '.' operator to do dot product when the operands are
formulas returning vectors.  (Part of the auto-generation of
formulas).

A few improvements to real and complex class output results.

Made Union class slightly more robust and removed need for makeUnion
method other than in the Union itself.

    1 ###########################################################################
    2 #
    3 #  Implements the Formula class.
    4 #
    5 package Value::Formula;
    6 my $pkg = 'Value::Formula';
    7 
    8 use strict;
    9 use vars qw(@ISA);
   10 @ISA = qw(Parser Value);
   11 
   12 use overload
   13        '+'    => \&add,
   14        '-'    => \&sub,
   15        '*'    => \&mult,
   16        '/'    => \&div,
   17        '**'   => \&power,
   18        '.'    => \&dot,
   19        'x'    => \&cross,
   20        '<=>'  => \&compare,
   21        'cmp'  => \&Value::cmp,
   22        '~'    => sub {Parser::Function->call('conj',$_[0])},
   23        'neg'  => sub {$_[0]->neg},
   24        'sin'  => sub {Parser::Function->call('sin',$_[0])},
   25        'cos'  => sub {Parser::Function->call('cos',$_[0])},
   26        'exp'  => sub {Parser::Function->call('exp',$_[0])},
   27        'abs'  => sub {Parser::Function->call('abs',$_[0])},
   28        'log'  => sub {Parser::Function->call('log',$_[0])},
   29        'sqrt' => sub {Parser::Function->call('sqrt',$_[0])},
   30       'atan2' => \&atan2,
   31    'nomethod' => \&Value::nomethod,
   32          '""' => \&Value::stringify;
   33 
   34 #
   35 #  Call Parser to make the new item
   36 #
   37 sub new {shift; $pkg->SUPER::new(@_)}
   38 
   39 #
   40 #  Create the new parser with no string
   41 #    (we'll fill in its tree by hand)
   42 #
   43 sub blank {$pkg->SUPER::new('')}
   44 
   45 #
   46 #  Get the type from the tree
   47 #
   48 sub typeRef {(shift)->{tree}->typeRef}
   49 
   50 ############################################
   51 #
   52 #  Create a BOP from two operands
   53 #
   54 #  Get the context and variables from the left and right operands
   55 #    if they are formulas
   56 #  Make them into Value objects if they aren't already.
   57 #  Convert '+' to union for intervals or unions.
   58 #  Make a new BOP with the two operands.
   59 #  Record the variables.
   60 #  Evaluate the formula if it is constant.
   61 #
   62 sub bop {
   63   my ($l,$r,$flag,$bop) = @_;
   64   if ($l->promotePrecedence($r)) {return $r->add($l,!$flag)}
   65   if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
   66   my $formula = $pkg->blank;
   67   my $vars = {};
   68   if (ref($r) eq $pkg) {
   69     $formula->{context} = $r->{context};
   70     $vars = {%{$vars},%{$r->{variables}}};
   71     $r = $r->{tree}->copy($formula);
   72   }
   73   if (ref($l) eq $pkg) {
   74     $formula->{context} = $l->{context};
   75     $vars = {%{$vars},%{$l->{variables}}};
   76     $l = $l->{tree}->copy($formula);
   77   }
   78   $l = $pkg->new($l) if (!ref($l) && Value::getType($formula,$l) eq "unknown");
   79   $r = $pkg->new($r) if (!ref($r) && Value::getType($formula,$r) eq "unknown");
   80   $l = Parser::Value->new($formula,$l) unless ref($l) =~ m/^Parser::/;
   81   $r = Parser::Value->new($formula,$r) unless ref($r) =~ m/^Parser::/;
   82   $bop = 'U' if $bop eq '+' &&
   83     ($l->type =~ m/Interval|Union/ || $r->type =~ m/Interval|Union/);
   84   $formula->{tree} = Parser::BOP->new($formula,$bop,$l,$r);
   85   $formula->{variables} = {%{$vars}};
   86   return $formula->eval if scalar(%{$vars}) == 0;
   87   return $formula;
   88 }
   89 
   90 sub add   {bop(@_,'+')}
   91 sub sub   {bop(@_,'-')}
   92 sub mult  {bop(@_,'*')}
   93 sub div   {bop(@_,'/')}
   94 sub power {bop(@_,'**')}
   95 sub cross {bop(@_,'><')}
   96 
   97 #
   98 #  Make dot work for vector operands
   99 #
  100 sub dot   {
  101   my ($l,$r,$flag) = @_;
  102   if ($l->promotePrecedence($r)) {return $r->compare($l,!$flag)}
  103   return bop(@_,'.') if $l->type eq 'Vector' &&
  104      Value::isValue($r) && $r->type eq 'Vector';
  105   Value::_dot(@_);
  106 }
  107 
  108 ############################################
  109 #
  110 #  Form the negation of a formula
  111 #
  112 sub neg {
  113   my $self = shift;
  114   my $formula = $self->blank;
  115   $formula->{context} = $self->{context};
  116   $formula->{variables} = $self->{variables};
  117   $formula->{tree} = Parser::UOP->new($formula,'u-',$self->{tree}->copy($formula));
  118   return $formula->eval if scalar(%{$formula->{variables}}) == 0;
  119   return $formula;
  120 }
  121 
  122 #
  123 #  Form the function atan2 function call on two operands
  124 #
  125 sub atan2 {
  126   my ($l,$r,$flag) = @_;
  127   if ($l->promotePrecedence($r)) {return $r->compare($l,!$flag)}
  128   if ($flag) {my $tmp = $l; $l = $r; $r = $tmp}
  129   Parser::Function->call('atan2',$l,$r);
  130 }
  131 
  132 ############################################
  133 #
  134 #  Compare two functions for equality
  135 #
  136 sub compare {
  137   my ($l,$r,$flag) = @_; my $self = $l;
  138   if ($l->promotePrecedence($r)) {return $r->compare($l,!$flag)}
  139   $r = Value::Formula->new($r) unless Value::isFormula($r);
  140   Value::Error("Functions from different contexts can't be compared")
  141     unless $l->{context} == $r->{context};
  142 
  143   #
  144   #  Get the test points and evaluate the functions at those points
  145   #
  146   ##  FIXME: Check given points for consistency
  147   my $points = $l->{test_points} || $r->{test_points} || $l->createRandomPoints;
  148   my $lvalues = $l->{test_values} || $l->createPointValues($points,1);
  149   my $rvalues = $r->createPointValues($points);
  150   #
  151   # Note: $l is bigger if $r can't be evaluated at one of the points
  152   return 1 unless $rvalues;
  153 
  154   #
  155   #  Look through the two lists to see if they are equal.
  156   #  If not, return the comparison of the first unequal value
  157   #    (not good for < and >, but OK for ==).
  158   #
  159   my ($i, $cmp);
  160   foreach $i (0..scalar(@{$lvalues})) {
  161     $cmp = $lvalues->[$i] <=> $rvalues->[$i];
  162     return $cmp if $cmp;
  163   }
  164   return 0;
  165 }
  166 
  167 #
  168 #  Create the value list from a given set of test points
  169 #
  170 sub createPointValues {
  171   my $self = shift;
  172   my $points = shift || $self->{test_points} || $self->createRandomPoints;
  173   my $showError = shift;
  174   my $f = $self->{f};
  175   $f = $self->{f} = $self->perlFunction(undef,[$self->{context}->variables->names])
  176      unless $f;
  177 
  178   my $values = []; my $v;
  179   foreach my $p (@{$points}) {
  180     $v = eval {&$f(@{$p})};
  181     if (!defined($v)) {
  182       return unless $showError;
  183       Value::Error("Can't evaluate formula on test point (".join(',',@{$p}).")");
  184     }
  185     push @{$values}, Value::makeValue($v);
  186   }
  187 
  188   $self->{test_points} = $points;
  189   $self->{test_values} = $values;
  190 }
  191 
  192 #
  193 #  Create a list of random points, making sure that the function
  194 #  is defined at the given points.  Error if we can't find enough.
  195 #
  196 sub createRandomPoints {
  197   my $self = shift;
  198   my $num_points = @_[0];
  199   $num_points = int($self->getFlag('num_points',5)) unless defined($num_points);
  200   $num_points = 1 if $num_points < 1;
  201 
  202   ## FIXME:  deal with variables of type complex, etc.
  203   my @vars = $self->{context}->variables->names;
  204   my @limits = $self->getVariableLimits(@vars);
  205   foreach my $limit (@limits) {$limit->[2] = abs($limit->[1]-$limit->[0])/1000}
  206   my $f = $self->{f}; $f = $self->{f} = $self->perlFunction(undef,[@vars]) unless $f;
  207   my $seedRandom = $self->{context}->flag('random_seed')? 'PGseedRandom' : 'seedRandom';
  208   my $getRandom  = $self->{context}->flag('random_seed')? 'PGgetRandom'  : 'getRandom';
  209 
  210   $self->$seedRandom;
  211   my $points = []; my $values = [];
  212   my (@P,$v); my $k = 0;
  213   while (scalar(@{$points}) < $num_points && $k < 10) {
  214     @P = (); foreach my $limit (@limits) {push @P, $self->$getRandom(@{$limit})}
  215     $v = eval {&$f(@P)};
  216     if (!defined($v)) {$k++} else {
  217       push @{$points}, [@P];
  218       push @{$values}, Value::makeValue($v);
  219       $k = 0; # reset count when we find a point
  220     }
  221   }
  222 
  223   Value::Error("Can't generate enough valid points for comparison") if $k;
  224   return ($points,$values) if defined(@_[0]);
  225   $self->{test_values} = $values;
  226   $self->{test_points} = $points;
  227 }
  228 
  229 #
  230 #  Get the array of variable limits
  231 #
  232 sub getVariableLimits {
  233   my $self = shift;
  234   ## FIXME: check for consistency with @vars
  235   return $self->{limits} if defined($self->{limits});
  236   my @limits; my $default = $self->getFlag('limits',[-2,2]);
  237   foreach my $x (@_) {
  238     my $def = $self->{context}->variables->get($x);
  239     push @limits, $def->{limits} || $default;
  240   }
  241   return @limits;
  242 }
  243 
  244 sub seedRandom {srand}
  245 sub getRandom {
  246   my $self = shift;
  247   my ($m,$M,$n) = @_; $n = 1 unless $n;
  248   return $m + $n*int(rand()*(int(($M-$m)/$n)+1));
  249 }
  250 
  251 #
  252 #  Get the value of a flag from the object itself,
  253 #  or from the context, or from the default context
  254 #  or from the given default, whichever is found first.
  255 #
  256 sub getFlag {
  257   my $self = shift; my $name = shift;
  258   return $self->{$name} if defined($self->{$name});
  259   return $self->{context}{flags}{$name} if defined($self->{context}{flags}{$name});
  260   return $$Value::context->{flags}{$name} if defined($$Value::context->{flags}{$name});
  261   return shift;
  262 }
  263 
  264 ############################################
  265 #
  266 #  Check if the value of a formula is constant
  267 #    (could use shift->{tree}{isConstant}, but I don't trust it)
  268 #
  269 sub isConstant {scalar(%{shift->{variables}}) == 0}
  270 
  271 ###########################################################################
  272 
  273 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9