[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 5977 - (download) (as text) (annotate)
Tue Jan 20 18:54:56 2009 UTC (11 years ago) by dpvc
File size: 9675 byte(s)
Fixed incorrect parentheses being added when $showparens eq "same"

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9