[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 6126 - (download) (as text) (annotate)
Thu Oct 1 22:06:11 2009 UTC (10 years, 4 months ago) by dpvc
File size: 27492 byte(s)
Handle arbitrary variable names

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9