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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 5701 - (download) (as text) (annotate)
Sun Jun 15 12:25:41 2008 UTC (11 years, 8 months ago) by dpvc
File size: 26545 byte(s)
Remove cached perlFunction when a substitution or reduction is made.

    1 package Parser;
    2 my $pkg = "Parser";
    3 use strict; no strict "refs";
    4 
    5 BEGIN {
    6   #
    7   #  Map class names to packages (added to Context, and
    8   #  can be overriden to customize the parser)
    9   #
   10   our $class = {Formula => 'Value::Formula'};
   11 
   12   #
   13   #  Collect the default reduction flags for use in the context
   14   #
   15   our $reduce = {};
   16 }
   17 
   18 ##################################################
   19 #
   20 #  Parse a string and create a new Parser object
   21 #  If the string is already a parsed object then copy the parse tree
   22 #  If it is a Value, make an appropriate tree for it.
   23 #
   24 sub new {
   25   my $self = shift;
   26   my $context = (Value::isContext($_[0]) ? shift : $self->context);
   27   my $class = $self->Item("Formula",$context);
   28   my $string = shift;
   29   $string = $context->Package("List")->new($context,$string,@_) if scalar(@_) > 0;
   30   $string = $context->Package("List")->new($context,$string)->with(open=>'[',close=>']')
   31     if ref($string) eq 'ARRAY';
   32   my $math = bless {
   33     string => undef,
   34     tokens => [], tree => undef,
   35     variables => {}, values => {},
   36     context => $context,
   37   }, $class;
   38   if (Value::isParser($string) || Value::isFormula($string)) {
   39     my $tree = $string; $tree = $tree->{tree} if defined $tree->{tree};
   40     $math->{tree} = $tree->copy($math);
   41     $math->{variables} = $math->{tree}->getVariables;
   42   } elsif (Value::isValue($string)) {
   43     $math->{tree} = $math->Item("Value")->new($math,$string);
   44   } elsif ($string eq '' && $context->{flags}{allowEmptyStrings}) {
   45     $math->{string} = "";
   46     $math->{tree} = $math->Item("Value")->new($math,"");
   47   } else {
   48     $math->{string} = $string;
   49     $math->tokenize;
   50     $math->parse;
   51   }
   52   return $math;
   53 }
   54 
   55 #
   56 #  Get the object's context, or the default one
   57 #
   58 sub context {
   59   my $self = shift;
   60   return $self->{context} if Value::isHash($self) && $self->{context};
   61   Parser::Context->current;
   62 }
   63 
   64 #
   65 #  Get the package for a parser item
   66 #
   67 sub Item {Parser::Item::Item(@_)}
   68 
   69 #
   70 #  Make a copy of a formula
   71 #
   72 sub copy {
   73   my $self = shift;
   74   my $copy  = bless {%{$self}}, ref($self);
   75   $copy->{tree} = $self->{tree}->copy($copy);
   76   foreach my $id (keys %{$self}) {
   77     $copy->{$id} = {%{$self->{$id}}} if ref($self->{$id}) eq 'HASH';
   78     $copy->{$id} = [@{$self->{$id}}] if ref($self->{$id}) eq 'ARRAY';
   79   }
   80   return $copy;
   81 }
   82 
   83 ##################################################
   84 #
   85 #  Break the string into tokens based on the patterns for the various
   86 #  types of objects.
   87 #
   88 sub tokenize {
   89   my $self = shift; my $space; my @match;
   90   my $tokens = $self->{tokens}; my $string = $self->{string};
   91   my $tokenPattern = $self->{context}{pattern}{token};
   92   my $tokenType = $self->{context}{pattern}{tokenType};
   93   my @patternType = @{$self->{context}{pattern}{type}};
   94   @{$tokens} = (); $self->{error} = 0;
   95   $string =~ m/^\s*/gc; my $p0; my $p1;
   96   while (pos($string) < length($string)) {
   97     $p0 = pos($string);
   98     if (@match = ($string =~ m/\G$tokenPattern/)) {
   99       foreach my $i (0..$#patternType) {
  100   if (defined($match[$i])) {
  101     $p1 = pos($string) = pos($string) + length($match[$i]);
  102     push(@{$tokens},[($patternType[$i]||$tokenType->{$match[$i]}),$match[$i],$p0,$p1,$space]);
  103     last;
  104   }
  105       }
  106     } else {
  107       push(@{$tokens},['error',substr($string,$p0,1),$p0,$p0+1]);
  108       $self->{error} = 1;
  109       last;
  110     }
  111     $space = ($string =~ m/\G\s+/gc);
  112   }
  113 }
  114 
  115 ##################################################
  116 #
  117 #  Parse the token list to produce the expression tree.  This does syntax checks
  118 #  and reports "compile-time" errors.
  119 #
  120 #  Start with a stack that has a single entry (an OPEN object for the expression)
  121 #  For each token, try to add that token to the tree.
  122 #  After all tokens have been finished, add a CLOSE object for the initial OPEN
  123 #    and save the complete tree
  124 #
  125 sub parse {
  126   my $self = shift;
  127   $self->{tree} = undef; $self->{error} = 0;
  128   $self->{stack} = [{type => 'open', value => 'start'}];
  129   foreach my $ref (@{$self->{tokens}}) {
  130     $self->{ref} = $ref; $self->{space} = $ref->[4];
  131     for ($ref->[0]) {
  132       /open/  and do {$self->Open($ref->[1]); last};
  133       /close/ and do {$self->Close($ref->[1],$ref); last};
  134       /op/    and do {$self->Op($ref->[1],$ref); last};
  135       /num/   and do {$self->Num($ref->[1]); last};
  136       /const/ and do {$self->Const($ref->[1]); last};
  137       /var/   and do {$self->Var($ref->[1]); last};
  138       /fn/    and do {$self->Fn($ref->[1]); last};
  139       /str/   and do {$self->Str($ref->[1]); last};
  140       /error/ and do {$self->Error(["Unexpected character '%s'",$ref->[1]],$ref); last};
  141     }
  142     return if ($self->{error});
  143   }
  144   $self->Close('start'); return if ($self->{error});
  145   $self->{tree} = $self->{stack}[0]{value};
  146 }
  147 
  148 
  149 #  Get the top or previous item of the stack
  150 #
  151 sub top {
  152   my $self = shift; my $i = shift || 0;
  153   return $self->{stack}[$i-1];
  154 }
  155 sub prev {(shift)->top(-1)}
  156 
  157 #
  158 #  Push or pop the top of the stack
  159 #
  160 sub pop {pop(@{(shift)->{stack}})}
  161 sub push {push(@{(shift)->{stack}},@_)}
  162 
  163 #
  164 #  Return the type of the top item
  165 #
  166 sub state {(shift)->top->{type}}
  167 
  168 #
  169 #  Report an error at a given possition (if possible)
  170 #
  171 sub Error {
  172   my $self = shift; my $context = $self->context;
  173   my $message = shift; my $ref = shift;
  174   my $string; my $more = "";
  175   if ($ref) {
  176     $more = "; see position %d of formula";
  177     $string = $self->{string};
  178     $ref = [$ref->[2],$ref->[3]];
  179   }
  180   $context->setError($message,$string,$ref,$more);
  181   die $context->{error}{message} . Value::getCaller();
  182 }
  183 
  184 #
  185 #  Insert an implicit multiplication
  186 #  (fix up the reference for spaces or juxtaposition)
  187 #
  188 sub ImplicitMult {
  189   my $self = shift;
  190   my $ref = $self->{ref}; my $iref = [@{$ref}];
  191   $iref->[2]--; $iref->[3] = $iref->[2]+1;
  192   $iref->[3]++ unless substr($self->{string},$iref->[2],1) eq ' ';
  193   $self->Error("Can't perform implied multiplication in this context",$iref)
  194     unless $self->{context}{operators}{' '}{class};
  195   $self->Op(' ',$iref);
  196   $self->{ref} = $ref;
  197 }
  198 
  199 #
  200 #  Push an operator onto the expression stack.
  201 #  We save the operator symbol, the precedence, etc.
  202 #
  203 sub pushOperator {
  204   my $self = shift;
  205   my ($op,$precedence,$reverse) = @_;
  206   $self->push({
  207     type => 'operator', ref => $self->{ref},
  208     name => $op, precedence => $precedence, reverse => $reverse
  209   });
  210 }
  211 
  212 #
  213 #  Push an operand onto the expression stack.
  214 #
  215 sub pushOperand {
  216   my $self = shift; my $value = shift;
  217   $self->push({type => 'operand', ref => $self->{ref}, value => $value});
  218 }
  219 
  220 #
  221 #  Push a blank operand (just as a place-holder)
  222 #
  223 sub pushBlankOperand {
  224   my $self = shift;
  225   $self->pushOperand($self->Item("Constant")->new($self,"_blank_",$self->{ref}));
  226 }
  227 
  228 ##################################################
  229 #
  230 #  Handle an operator token
  231 #
  232 #  Get the operator data from the context
  233 #  If the top of the stack is an operand
  234 #    If the operator is a left-associative unary operator
  235 #      Insert an implicit multiplication and save the operator
  236 #    Otherwise
  237 #      Complete any pending operations of higher precedence
  238 #      If the top item is still an operand
  239 #        If we have a (right associative) unary operator
  240 #          Apply it to the top operand
  241 #        Otherwise (binary operator)
  242 #          Convert the space operator to explicit multiplication
  243 #          Save the opertor on the stack
  244 #      Otherwise, (top is not an operand)
  245 #        If the operator is an explicit one or the top is a function
  246 #          Call Op again to report the error, or to apply
  247 #            the operator to the function (this happens when
  248 #            there is a function to a power, for example)
  249 #  Otherwise (top is not an operand)
  250 #    If this is a left-associative unary operator, save it on the stack
  251 #    Otherwise, if it is a left-associative operator that CAN be unary
  252 #      Save the unary version of the operator on the stack
  253 #    Otherwise, if the top item is a function
  254 #      If the operator can be applied to functions, save it on the stack
  255 #      Otherwise, report that the function is missing its inputs
  256 #    Otherwise, report the missing operand for this operator
  257 #
  258 sub Op {
  259   my $self = shift; my $name = shift;
  260   my $ref = $self->{ref} = shift;
  261   my $context = $self->{context}; my $op = $context->{operators}{$name};
  262   $op = $context->{operators}{$op->{space}} if $self->{space} && defined($op->{space});
  263   if ($self->state eq 'operand') {
  264     if ($op->{type} eq 'unary' && $op->{associativity} eq 'left') {
  265       $self->ImplicitMult();
  266       $self->pushOperator($name,$op->{precedence});
  267     } else {
  268       $self->Precedence($op->{precedence});
  269       if ($self->state eq 'operand') {
  270         if ($op->{type} eq 'unary') {
  271           my $top = $self->pop;
  272           $self->pushOperand($self->Item("UOP")->new($self,$name,$top->{value},$ref));
  273         } else {
  274           $name = $context->{operators}{' '}{string}
  275             if $name eq ' ' or $name eq $context->{operators}{' '}{space};
  276           $self->pushOperator($name,$op->{precedence});
  277         }
  278       } elsif (($ref && $name ne ' ') || $self->state ne 'fn') {$self->Op($name,$ref)}
  279     }
  280   } else {
  281     $name = 'u'.$name, $op = $context->{operators}{$name}
  282       if ($op->{type} eq 'both' && defined $context->{operators}{'u'.$name});
  283     if ($op->{type} eq 'unary' && $op->{associativity} eq 'left') {
  284       $self->pushOperator($name,$op->{precedence});
  285     } elsif ($self->state eq 'fn') {
  286       if ($op->{leftf}) {
  287         $self->pushOperator($name,$op->{precedence},1);
  288       } elsif ($self->{context}->flag("allowMissingFunctionInputs")) {
  289   $self->pushBlankOperand;
  290   $self->CloseFn;
  291   $self->pushOperator($name,$op->{precedence});
  292       } else {
  293         my $top = $self->top;
  294         $self->Error(["Function '%s' is missing its input(s)",$top->{name}],$top->{ref});
  295       }
  296     } elsif ($self->{context}->flag("allowMissingOperands")) {
  297       $self->pushBlankOperand;
  298       $self->Op($name,$ref);
  299     } else {$self->Error(["Missing operand before '%s'",$name],$ref)}
  300   }
  301 }
  302 
  303 ##################################################
  304 #
  305 #  Handle an open parenthesis
  306 #
  307 #  If the top of the stack is an operand
  308 #    Check if the open paren is really a close paren (for when the open
  309 #      and close symbol are the same)
  310 #    Otherwise insert an implicit multiplication
  311 #  Save the open object on the stack
  312 #
  313 sub Open {
  314   my $self = shift; my $type = shift;
  315   my $paren = $self->{context}{parens}{$type};
  316   if ($self->state eq 'operand') {
  317     if ($type eq $paren->{close}) {
  318       my $stack = $self->{stack}; my $i = scalar(@{$stack})-1;
  319       while ($i >= 0 && $stack->[$i]{type} ne "open") {$i--}
  320       if ($i >= 0 && $stack->[$i]{value} eq $type) {
  321   $self->Close($type,$self->{ref});
  322   return;
  323       }
  324     }
  325     $self->ImplicitMult();
  326   }
  327   $self->push({type => 'open', value => $type, ref => $self->{ref}});
  328 }
  329 
  330 ##################################################
  331 #
  332 #  Handle a close parenthesis
  333 #
  334 #  When the top stack object is
  335 #    An open parenthesis (that is empty):
  336 #      Get the data for the type of parentheses
  337 #      If the parentheses can be empty and the parentheses match
  338 #        Save the empty list
  339 #      Otherwise report a message appropriate to the type of parentheses
  340 #
  341 #    An operand:
  342 #      Complete any pending operations, and stop if there was an error
  343 #      If the top is no longer an operand
  344 #        Call Close to report the error and return
  345 #      Get the item before the operand (an OPEN object), and its parenthesis type
  346 #      If the parens match
  347 #        Pop the operand off the stack
  348 #        If the parens can't be removed, or if the operand is a list
  349 #          Make the operand into a list object
  350 #        Replace the paren object with the operand
  351 #        If the parentheses are used for function calls and the
  352 #          previous stack object is a function call, do the function apply
  353 #      Otherwise if the parens can form Intervals, do so
  354 #      Otherwise report an appropriate error message
  355 #
  356 #    A function:
  357 #      Report an error message about missing inputs
  358 #
  359 #    An operator:
  360 #      Report the missing operation
  361 #
  362 sub Close {
  363   my $self = shift; my $type = shift;
  364   my $ref = $self->{ref} = shift;
  365   my $parens = $self->{context}{parens};
  366 
  367   for ($self->state) {
  368     /open/ and do {
  369       my $top = $self->pop; my $paren = $parens->{$top->{value}};
  370       if ($paren->{emptyOK} && $paren->{close} eq $type) {
  371         $self->pushOperand($self->Item("List")->new($self,[],1,$paren,undef,$top->{value},$paren->{close}))
  372       }
  373       elsif ($type eq 'start') {$self->Error(["Missing close parenthesis for '%s'",$top->{value}],$top->{ref})}
  374       elsif ($top->{value} eq 'start') {$self->Error(["Extra close parenthesis '%s'",$type],$ref)}
  375       else {$top->{ref}[3]=$ref->[3]; $self->Error("Empty parentheses",$top->{ref})}
  376       last;
  377     };
  378 
  379     /operand/ and do {
  380       $self->Precedence(-1); return if ($self->{error});
  381       if ($self->state ne 'operand') {$self->Close($type,$ref); return}
  382       my $paren = $parens->{$self->prev->{value}};
  383       if ($paren->{close} eq $type) {
  384         my $top = $self->pop;
  385         if (!$paren->{removable} || ($top->{value}->type eq "Comma")) {
  386           $top = $top->{value};
  387           $top = {type => 'operand', value =>
  388             $self->Item("List")->new($self,[$top->makeList],$top->{isConstant},$paren,
  389                     ($top->type eq 'Comma') ? $top->entryType : $top->typeRef,
  390                     ($type ne 'start') ? ($self->top->{value},$type) : () )};
  391         }
  392         $self->pop; $self->push($top);
  393         $self->CloseFn() if ($paren->{function} && $self->prev->{type} eq 'fn');
  394       } elsif ($paren->{formInterval} eq $type && $self->top->{value}->length == 2) {
  395         my $top = $self->pop->{value}; my $open = $self->pop->{value};
  396         $self->pushOperand(
  397            $self->Item("List")->new($self,[$top->makeList],$top->{isConstant},
  398              $paren,$top->entryType,$open,$type));
  399       } else {
  400         my $prev = $self->prev;
  401         if ($type eq "start") {$self->Error(["Missing close parenthesis for '%s'",$prev->{value}],$prev->{ref})}
  402         elsif ($prev->{value} eq "start") {$self->Error(["Extra close parenthesis '%s'",$type],$ref)}
  403         else {$self->Error(["Mismatched parentheses: '%s' and '%s'",$prev->{value},$type],$ref)}
  404         return;
  405       }
  406       last;
  407     };
  408 
  409     /fn/ and do {
  410       if ($self->{context}->flag("allowMissingFunctionInputs")) {
  411   $self->pushBlankOperand;
  412   $self->Close($type,$ref);
  413       } else {
  414         my $top = $self->top;
  415         $self->Error(["Function '%s' is missing its input(s)",$top->{name}],$top->{ref});
  416       }
  417       return;
  418     };
  419 
  420     /operator/ and do {
  421       if ($self->{context}->flag("allowMissingOperands")) {
  422   $self->pushBlankOperand;
  423   $self->Close($type,$ref);
  424       } else {
  425         my $top = $self->top(); my $name = $top->{name}; $name =~ s/^u//;
  426         $self->Error(["Missing operand after '%s'",$name],$top->{ref});
  427       }
  428       return;
  429     };
  430   }
  431 }
  432 
  433 ##################################################
  434 #
  435 #  Handle any pending operations of higher precedence
  436 #
  437 #  While the top stack item is an operand:
  438 #    When the preceding item is:
  439 #      An pending operator:
  440 #        Get the precedence of the operator (use the special right-hand prrecedence
  441 #          of there is one, otherwise use the general precedence)
  442 #        Stop processing if the current operator precedence is higher
  443 #        If the stacked operator is binary or if it is reversed (for function operators)
  444 #          Stop processing if the precedence is equal and we are right associative
  445 #          If the operand for the stacked operator is a function
  446 #            If the operation is ^(-1) (for inverses)
  447 #              Push the inverse function name
  448 #            Otherwise
  449 #              Reverse the order of the stack, so that the function can be applied
  450 #                to the next operand (it will be unreversed later)
  451 #          Otherwise (not a function, so an operand)
  452 #            Get the operands and binary operator off the stack
  453 #            If it is reversed (for functions), get the order right
  454 #            Save the result of the binary operation as an operand on the stack
  455 #        Otherwise (the stack contains a unary operator)
  456 #          Get the operator and operand off the stack
  457 #          Push the result of the unary operator as an operand on the stack
  458 #
  459 #      A pending function call:
  460 #        Keep working if the precedence of the operator is higher than a function call
  461 #        Otherwise apply the function to the operator and continue
  462 #
  463 #      Anything else:
  464 #        Return (no more pending operations)
  465 #
  466 #    If there was an error, stop processing
  467 #
  468 sub Precedence {
  469   my $self = shift; my $precedence = shift;
  470   my $context = $self->{context};
  471   while ($self->state eq 'operand') {
  472     my $prev = $self->prev;
  473     for ($prev->{type}) {
  474 
  475       /operator/ and do {
  476         my $prev_prec = $context->{operators}{$prev->{name}}{rprecedence};
  477         $prev_prec = $prev->{precedence} unless $prev_prec;
  478         return if ($precedence > $prev_prec);
  479         if ($self->top(-2)->{type} eq 'operand' || $prev->{reverse}) {
  480           return if ($precedence == $prev_prec &&
  481               $context->{operators}{$prev->{name}}{associativity} eq 'right');
  482           if ($self->top(-2)->{type} eq 'fn') {
  483             my $top = $self->pop; my $op = $self->pop; my $fun = $self->pop;
  484             if (Parser::Function::checkInverse($self,$fun,$op,$top)) {
  485               $fun->{name} = $context->{functions}{$fun->{name}}{inverse};
  486               $self->push($fun);
  487             } else {$self->push($top,$op,$fun)}
  488           } else {
  489             my $rop = $self->pop; my $op = $self->pop; my $lop = $self->pop;
  490             if ($op->{reverse}) {my $tmp = $rop; $rop = $lop; $lop = $tmp}
  491             $self->pushOperand($self->Item("BOP")->new($self,$op->{name},
  492                  $lop->{value},$rop->{value},$op->{ref}),$op->{reverse});
  493           }
  494         } else {
  495           my $rop = $self->pop; my $op = $self->pop;
  496           $self->pushOperand($self->Item("UOP")->new
  497          ($self,$op->{name},$rop->{value},$op->{ref}),$op->{reverse});
  498         }
  499         last;
  500       };
  501 
  502       /fn/ and do {
  503         return if ($precedence > $context->{operators}{fn}{precedence});
  504         $self->CloseFn();
  505         last;
  506       };
  507 
  508       return;
  509 
  510     }
  511     return if ($self->{error});
  512   }
  513 }
  514 
  515 ##################################################
  516 #
  517 #  Apply a function to its parameters
  518 #
  519 #  If the operand is a list and the parens are those for function calls
  520 #    Use the list items as the parameters, otherwise use the top item
  521 #  Pop the function object, and push the result of the function call
  522 #
  523 sub CloseFn {
  524   my $self = shift; my $context = $self->{context};
  525   my $top = $self->pop->{value}; my $fn = $self->pop;
  526   my $constant = $top->{isConstant};
  527   if ($top->{open} && $context->{parens}{$top->{open}}{function} &&
  528       $context->{parens}{$top->{open}}{close} eq $top->{close} &&
  529       !$context->{functions}{$fn->{name}}{vectorInput})
  530          {$top = $top->coords} else {$top = [$top]}
  531   $self->pushOperand($self->Item("Function")->new($self,$fn->{name},$top,$constant,$fn->{ref}));
  532 }
  533 
  534 ##################################################
  535 #
  536 #  Handle a numeric token
  537 #
  538 #  Add an implicit multiplication, if needed
  539 #  Create the number object and check it
  540 #  Save the number as an operand
  541 #
  542 sub Num {
  543   my $self = shift;
  544   $self->ImplicitMult() if $self->state eq 'operand';
  545   my $num = $self->Item("Number")->new($self,shift,$self->{ref});
  546   my $check = $self->{context}->flag('NumberCheck');
  547   &$check($num) if $check;
  548   $self->pushOperand($num);
  549 }
  550 
  551 ##################################################
  552 #
  553 #  Handle a constant token
  554 #
  555 #  Add an implicit multiplication, if needed
  556 #  Save the number as an operand
  557 #
  558 sub Const {
  559   my $self = shift; my $ref = $self->{ref}; my $name = shift;
  560   my $const = $self->{context}{constants}{$name};
  561   $self->ImplicitMult() if $self->state eq 'operand';
  562   if (defined($self->{context}{variables}{$name})) {
  563     $self->pushOperand($self->Item("Variable")->new($self,$name,$ref));
  564   } elsif ($const->{keepName}) {
  565     $self->pushOperand($self->Item("Constant")->new($self,$name,$ref));
  566   } else {
  567     $self->pushOperand($self->Item("Value")->new($self,[$const->{value}],$ref));
  568   }
  569 }
  570 
  571 ##################################################
  572 #
  573 #  Handle a variable token
  574 #
  575 #  Add an implicit multiplication, if needed
  576 #  Save the variable as an operand
  577 #
  578 sub Var {
  579   my $self = shift;
  580   $self->ImplicitMult() if $self->state eq 'operand';
  581   $self->pushOperand($self->Item("Variable")->new($self,shift,$self->{ref}));
  582 }
  583 
  584 ##################################################
  585 #
  586 #  Handle a function token
  587 #
  588 #  Add an implicit multiplication, if needed
  589 #  Save the function object on the stack
  590 #
  591 sub Fn {
  592   my $self = shift;
  593   $self->ImplicitMult() if $self->state eq 'operand';
  594   $self->push({type => 'fn', name => shift, ref => $self->{ref}});
  595 }
  596 
  597 ##################################################
  598 #
  599 #  Handle a string constant
  600 #
  601 #  Add an implicit multiplication, if needed (will report an error)
  602 #  Save the string object on the stack
  603 #
  604 sub Str {
  605   my $self = shift;
  606   $self->ImplicitMult() if $self->state eq 'operand';
  607   $self->pushOperand($self->Item("String")->new($self,shift,$self->{ref}));
  608 }
  609 
  610 ##################################################
  611 ##################################################
  612 #
  613 #  Evaluate the equation using the given values
  614 #
  615 sub eval {
  616   my $self = shift;
  617   $self->setValues(@_);
  618   foreach my $x (keys %{$self->{values}}) {
  619     $self->Error(["The value of '%s' can't be a formula",$x])
  620       if Value::isFormula($self->{values}{$x});
  621   }
  622   my $value = Value::makeValue($self->{tree}->eval,context=>$self->context)->with(equation=>$self);
  623   $value->transferFlags("equation");
  624   $self->unsetValues;
  625   return $value;
  626 }
  627 
  628 ##################################################
  629 #
  630 #  Removes redundent items (like x+-y, 0+x and 1*x, etc)
  631 #  using the provided flags
  632 #
  633 sub reduce {
  634   my $self = shift;
  635   $self = $self->copy($self);
  636   my $reduce = $self->{context}{reduction};
  637   $self->{context}{reduction} = {%{$reduce},@_};
  638   $self->{tree} = $self->{tree}->reduce;
  639   $self->{variables} = $self->{tree}->getVariables;
  640   $self->{context}{reduction} = $reduce if $reduce;
  641   delete $self->{f};
  642   return $self;
  643 }
  644 
  645 ##################################################
  646 #
  647 #  Substitute values for one or more variables
  648 #
  649 sub substitute {
  650   my $self = shift;
  651   $self = $self->copy($self);
  652   $self->setValues(@_);
  653   foreach my $x (keys %{$self->{values}}) {delete $self->{variables}{$x}}
  654   $self->{tree} = $self->{tree}->substitute;
  655   $self->unsetValues;
  656   delete $self->{f};
  657   return $self;
  658 }
  659 
  660 ##################################################
  661 #
  662 #  Produces a printable string (substituting the given values).
  663 #
  664 sub string {
  665   my $self = shift;
  666   $self->setValues(@_);
  667   my $string = $self->{tree}->string;
  668   $self->unsetValues;
  669   return $string;
  670 }
  671 
  672 ##################################################
  673 #
  674 #  Produces a TeX string (substituting the given values).
  675 #
  676 sub TeX {
  677   my $self = shift;
  678   $self->setValues(@_);
  679   my $tex = $self->{tree}->TeX;
  680   $self->unsetValues;
  681   return $tex;
  682 }
  683 
  684 ##################################################
  685 #
  686 #  Produces a perl eval string (substituting the given values).
  687 #
  688 sub perl {
  689   my $self = shift;
  690   $self->setValues(@_);
  691   my $perl = $self->{tree}->perl;
  692   $perl = $self->Package("Real").'->new('.$perl.')' if $self->isRealNumber;
  693   $self->unsetValues;
  694   return $perl;
  695 }
  696 
  697 ##################################################
  698 #
  699 #  Produce a perl function
  700 #
  701 #  (Parameters specify an optional name and an array reference of
  702 #   optional variables. If the name is not included, an anonymous
  703 #   code reference is returned.  If the variables are not included,
  704 #   then the variables from the formula are used in sorted order.)
  705 #
  706 sub perlFunction {
  707   my $self = shift; my $name = shift || ''; my $vars = shift;
  708   $vars = [sort(keys %{$self->{variables}})] unless $vars;
  709   my $n = scalar(@{$vars}); my $vnames = '';
  710   if ($n > 0) {
  711     my @v = (); foreach my $x (@{$vars}) {CORE::push(@v,"\$".$x)}
  712     $vnames = "my (".join(',',@v).") = \@_;";
  713   }
  714   my $context = $self->context;
  715   my $fn = eval
  716    "package main;
  717     sub $name {
  718       die \"Wrong number of arguments".($name?" to '$name'":'')."\" if scalar(\@_) != $n;
  719       $vnames
  720       my \$oldContext = \$\$Value::context; \$\$Value::context = \$context;
  721       my \@result = ".$self->perl.";
  722       \$\$Value::context = \$oldContext;
  723       return (wantarray ? \@result : \$result[0]);
  724     }";
  725   $self->Error($@) if $@;
  726   return $fn;
  727 }
  728 
  729 
  730 ##################################################
  731 #
  732 #  Sets the values of variables for evaluation purposes
  733 #
  734 sub setValues {
  735   my $self = shift; my ($xref,$value,$type);
  736   my $context = $self->context;
  737   my $variables = $context->{variables};
  738   while (scalar(@_)) {
  739     $xref = shift; $value = shift;
  740     if (ref($xref) eq "ARRAY") {
  741       $value = Value::makeValue($value,context=>$context) unless ref($value);
  742       $value = [$value->value] if Value::isValue($value);
  743       $value = @{$value}[0,1] if Value::classMatch("Interval");
  744       $value = [$value] unless ref($value) eq 'ARRAY';
  745     } else {
  746       $xref = [$xref]; $value = [$value];
  747     }
  748     foreach my $i (0..scalar(@$xref)-1) {
  749       my $x = $xref->[$i]; my $v = $value->[$i];
  750       $self->Error(["Null value can't be assigned to variable '%s'",$x]) unless defined $v;
  751       $self->Error(["Undeclared variable '%s'",$x]) unless defined $variables->{$x};
  752       $v = Value::makeValue($v,context=>$context);
  753       ($v,$type) = Value::getValueType($self,$v);
  754       $self->Error(["Variable '%s' should be of type %s",$x,$variables->{$x}{type}{name}])
  755   unless Parser::Item::typeMatch($type,$variables->{$x}{type});
  756       $v->inContext($self->context) if $v->context != $self->context;
  757       $self->{values}{$x} = $v;
  758     }
  759   }
  760 }
  761 
  762 sub unsetValues {
  763   my $self = shift;
  764   delete $self->{values};
  765 }
  766 
  767 
  768 ##################################################
  769 ##################################################
  770 #
  771 #  Produce a vector in ijk form
  772 #
  773 sub ijk {
  774   my $self = shift;
  775   $self->{tree}->ijk;
  776 }
  777 
  778 #########################################################################
  779 #########################################################################
  780 #
  781 #  Load the sub-classes and Value.pm
  782 #
  783 
  784 END {
  785   use Parser::Item;
  786   use Value;
  787   use Parser::Context;
  788   use Parser::Context::Default;
  789   use Parser::Differentiation;
  790 }
  791 
  792 ###########################################################################
  793 
  794 our $installed = 1;
  795 
  796 ###########################################################################
  797 
  798 1;
  799 

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9