[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 5961 - (download) (as text) (annotate)
Sun Jan 11 19:51:51 2009 UTC (11 years ago) by dpvc
File size: 26862 byte(s)
When a parentheses have been removed, mark the enclosed item so that
we can tell later, if we need to know about the missing parens.

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9