[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 5016 - (download) (as text) (annotate)
Fri Jun 22 02:39:24 2007 UTC (12 years, 8 months ago) by dpvc
File size: 25018 byte(s)
Handle ans_array() correctly again (context issues, and allow parser
to create a formula from an existing subtree).

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9