[system] / trunk / pg / lib / Parser / Function.pm Repository:
ViewVC logotype

View of /trunk/pg/lib/Parser/Function.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2915 - (download) (as text) (annotate)
Wed Oct 13 03:31:17 2004 UTC (15 years, 2 months ago) by dpvc
File size: 8926 byte(s)
Trap errors in functions that are not native perl functions (like
acos() and csc(), etc.).  In the past, if an error occurred within the
definition of a function, the error message that was reported was the
internal error within the definition of the function.  For example
csc(0) would report "illegal division by zero", while acos(-2) would
report "can't take sqrt of -3".  Now the errors will be "can't take
csc of 0" and "can't take acos of -2".

    1 #########################################################################
    2 #
    3 #  Implements function calls
    4 #
    5 
    6 package Parser::Function;
    7 use strict; use vars qw(@ISA);
    8 @ISA = qw(Parser::Item);
    9 
   10 $Parser::class->{Function} = 'Parser::Function';
   11 
   12 sub new {
   13   my $self = shift; my $class = ref($self) || $self;
   14   my $equation = shift; my $context = $equation->{context};
   15   my ($name,$params,$constant,$ref) = @_;
   16   my $def = $context->{functions}{$name};
   17   $name = $def->{alias}, $def = $context->{functions}{$name} if defined $def->{alias};
   18   my $fn = bless {
   19     name => $name, params => $params,
   20     def => $def, ref => $ref, equation => $equation,
   21   }, $def->{class};
   22   $fn->_check;
   23   $fn = $context->{parser}{Value}->new($equation,[$fn->eval])
   24     if $constant && $context->flag('reduceConstantFunctions');
   25   return $fn;
   26 }
   27 
   28 #
   29 #  Stub to check if arguments are OK.
   30 #  (Implemented in sub-classes.)
   31 #
   32 sub _check {}
   33 
   34 ##################################################
   35 
   36 #
   37 #  Evaluate all the arguments and then perform the function
   38 #
   39 sub eval {
   40   my $self = shift; my @params = ();
   41   foreach my $x (@{$self->{params}}) {push(@params,$x->eval)}
   42   my $result = eval {$self->_eval(@params)};
   43   return $result unless $@;
   44   $self->Error("Can't take $self->{name} of ".join(',',@params));
   45 }
   46 #
   47 #  Stub for sub-classes
   48 #
   49 sub _eval {shift; return @_}
   50 
   51 #
   52 #  Reduce all the arguments and compute the function if they are
   53 #    all constant.
   54 #  Otherwise, let the sub-classes reduce it.
   55 #
   56 sub reduce {
   57   my $self = shift;
   58   my $constant = 1;
   59   foreach my $x (@{$self->{params}})
   60     {$x = $x->reduce; $constant = 0 unless $x->{isConstant}}
   61   return $self->{equation}{context}{parser}{Value}->
   62     new($self->{equation},[$self->eval]) if $constant;
   63   $self->_reduce;
   64 }
   65 #
   66 #  Stub for sub-classes.
   67 #
   68 sub _reduce {shift}
   69 
   70 #
   71 #  Substitute in each argument.
   72 #
   73 sub substitute {
   74   my $self = shift;
   75   my @params = (); my $constant = 1;
   76   my $equation = $self->{equation}; my $context = $equation->{context};
   77   foreach my $x (@{$self->{params}})
   78     {$x = $x->substitute; $constant = 0 unless $x->{isConstant}}
   79   return $context->{parser}{Value}->new($equation,[$self->eval])
   80     if $constant && $context->flag('reduceConstantFunctions');
   81   return $self;
   82 }
   83 
   84 #
   85 #  Copy the arguments as well as the function object
   86 #
   87 sub copy {
   88   my $self = shift; my $equation = shift;
   89   my $new = $self->SUPER::copy($equation);
   90   $new->{params} = [];
   91   foreach my $x (@{$self->{params}}) {push(@{$new->{params}},$x->copy($equation))}
   92   return $new;
   93 }
   94 
   95 #
   96 #  Create a new formula if the function's arguments are formulas
   97 #  Otherwise evaluate the function call.
   98 #
   99 #  (This is used to "overload" function calls so that they will
  100 #   work in Value.pm to produce formulas when called on formulas.)
  101 #
  102 sub call {
  103   my $self = shift; my $name = shift;
  104   my $context = Parser::Context->current;
  105   my $fn = $context->{functions}{$name};
  106   Value::Error("No definition for function '$name'") unless defined($fn);
  107   my $isFormula = 0;
  108   foreach my $x (@_) {return $self->formula($name,@_) if Value::isFormula($x)}
  109   my $class = $fn->{class};
  110   my $result = eval {$class->_call($name,@_)};
  111   return $result unless $@;
  112   Value::Error("Can't take $name of ".join(',',@_));
  113 }
  114 #
  115 #  Stub for sub-classes.
  116 #  (Default is return the argument)
  117 #
  118 sub _call {shift; shift; shift}
  119 
  120 #
  121 #  Create a formula that consists of a function call on the
  122 #    given arguments.  They are converted to formulas as well.
  123 #
  124 sub formula {
  125   my $self = shift; my $name = shift;
  126   my $formula = Value::Formula->blank;
  127   my @args = Value::toFormula($formula,@_);
  128   $formula->{tree} = $formula->{context}{parser}{Function}->new($formula,$name,[@args]);
  129 #  return $formula->eval if scalar(%{$formula->{variables}}) == 0;
  130   return $formula;
  131 }
  132 
  133 ##################################################
  134 #
  135 #  Service routines for checking the arguments
  136 #
  137 
  138 #
  139 #  Check that the function has a single numeric argument
  140 #    and check if it is allowed to be complex.
  141 #
  142 sub checkNumeric {
  143   my $self = shift;
  144   return if ($self->checkArgCount(1));
  145   my $arg = $self->{params}->[0];
  146   if ($arg->isComplex) {
  147     if (!($self->{def}{nocomplex})) {$self->{type} = $Value::Type{complex}}
  148     else {$self->Error("Function '$self->{name}' doesn't accept Complex inputs")}
  149   } elsif ($arg->isNumber) {
  150     $self->{type} = $Value::Type{number};
  151   } else {$self->Error("The input for '$self->{name}' must be a number")}
  152 }
  153 
  154 #
  155 #  Error if the argument is not a single vector
  156 #
  157 sub checkVector {
  158   my $self = shift;
  159   return if ($self->checkArgCount(1));
  160   if ($self->{params}->[0]->type =~ m/Point|Vector/) {
  161     $self->{type} = $Value::Type{number};
  162   } else {$self->Error("Function '$self->{name}' requires a Vector input")}
  163 }
  164 
  165 #
  166 #  Error if the argument isn't a single complex number
  167 #    and return a real.
  168 #
  169 sub checkReal {
  170   my $self = shift;
  171   return if ($self->checkArgCount(1));
  172   if ($self->{params}->[0]->isNumber) {
  173     $self->{type} = $Value::Type{number};
  174   } else {$self->Error("Function '$self->{name}' requires a Complex input")}
  175 }
  176 
  177 #
  178 #  Error if the argument isn't a singe complex number
  179 #    and return a complex.
  180 #
  181 sub checkComplex {
  182   my $self = shift;
  183   return if ($self->checkArgCount(1));
  184   if ($self->{params}->[0]->isNumber) {
  185     $self->{type} = $Value::Type{complex};
  186   } else {$self->Error("Function '$self->{name}' requires a Complex input")}
  187 }
  188 
  189 ##################################################
  190 #
  191 #  Service routines for arguments
  192 #
  193 
  194 #
  195 #  Check if the function's inverse can be written f^{-1}
  196 #
  197 sub checkInverse {
  198   my $equation = shift;
  199   my $fn = shift; my $op = shift; my $rop = shift;
  200   $op = $equation->{context}{operators}{$op->{name}};
  201   $fn = $equation->{context}{functions}{$fn->{name}};
  202   return ($fn->{inverse} && $op->{isInverse} && $rop->{value}->string eq "-1");
  203 }
  204 
  205 #
  206 #  Check that there are the right number of arguments
  207 #
  208 sub checkArgCount {
  209   my $self = shift; my $count = shift;
  210   my $name = $self->{name};
  211   my $args = scalar(@{$self->{params}});
  212   if ($args == $count) {
  213     return 0 if ($count == 0 || $self->{params}->[0]->length > 0);
  214     $self->Error("Function '$name' requires a non-empty input list");
  215   } elsif ($args < $count) {
  216     $self->Error("Function '$name' has too few inputs");
  217   } else {
  218     $self->Error("Function '$name' has too many inputs");
  219   }
  220   return 1;
  221 }
  222 
  223 #
  224 #  Find all the variables used in the arguments
  225 #
  226 sub getVariables {
  227   my $self = shift; my $vars = {};
  228   foreach my $x (@{$self->{params}}) {$vars = {%{$vars},%{$x->getVariables}}}
  229   return $vars;
  230 }
  231 
  232 ##################################################
  233 #
  234 #  Generate the different output formats
  235 #
  236 
  237 #
  238 #  Produce the string form.
  239 #
  240 #  Put parentheses around the funciton call if
  241 #    the function call is on the left of the parent operation
  242 #    and the precedence of the parent is higher than function call
  243 #    (e.g., powers, etc.)
  244 #
  245 sub string {
  246   my ($self,$precedence,$showparens,$position,$outerRight,$power) = @_;
  247   my $string; my $fn = $self->{equation}{context}{operators}{'fn'};
  248   my @pstr = (); my $fn_precedence = $fn->{precedence};
  249   $fn_precedence = $fn->{parenPrecedence}
  250     if ($position && $position eq 'right' && $fn->{parenPrecedence});
  251   foreach my $x (@{$self->{params}}) {push(@pstr,$x->string)}
  252   $string = ($self->{def}{string} || $self->{name})."$power".'('.join(',',@pstr).')';
  253   $string = $self->addParens($string)
  254     if (defined($precedence) and $precedence > $fn_precedence);
  255   return $string;
  256 }
  257 
  258 #
  259 #  Produce the TeX form.
  260 #
  261 sub TeX {
  262   my ($self,$precedence,$showparens,$position,$outerRight,$power) = @_;
  263   my $TeX; my $fn = $self->{equation}{context}{operators}{'fn'};
  264   my @pstr = (); my $fn_precedence = $fn->{precedence};
  265   $fn_precedence = $fn->{parenPrecedence}
  266     if ($position && $position eq 'right' && $fn->{parenPrecedence});
  267   $fn = $self->{def};
  268   my $name = '\mathop{\rm '.$self->{name}.'}';
  269   $name = $fn->{TeX} if defined($fn->{TeX});
  270   foreach my $x (@{$self->{params}}) {push(@pstr,$x->TeX)}
  271   if ($fn->{braceTeX}) {$TeX = $name.'{'.join(',',@pstr).'}'}
  272     else {$TeX = $name."$power".'\!\left('.join(',',@pstr).'\right)'}
  273   $TeX = '\left('.$TeX.'\right)'
  274     if (defined($precedence) and $precedence > $fn_precedence);
  275   return $TeX;
  276 }
  277 
  278 #
  279 #  Produce the perl form.
  280 #
  281 sub perl {
  282   my $self = shift; my $parens = shift;
  283   my $fn = $self->{def}; my @p = ();
  284   foreach my $x (@{$self->{params}}) {push(@p,$x->perl)}
  285   my $perl = ($fn->{perl}? $fn->{perl} : $self->{name}).'('.join(',',@p).')';
  286   $perl = '('.$perl.')' if $parens == 1;
  287   return $perl;
  288 }
  289 
  290 #########################################################################
  291 #
  292 #  Load the subclasses.
  293 #
  294 
  295 use Parser::Function::undefined;
  296 use Parser::Function::trig;
  297 use Parser::Function::hyperbolic;
  298 use Parser::Function::numeric;
  299 use Parser::Function::numeric2;
  300 use Parser::Function::complex;
  301 use Parser::Function::vector;
  302 
  303 #########################################################################
  304 
  305 1;
  306 

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9