[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 4979 - (download) (as text) (annotate)
Thu Jun 7 11:59:05 2007 UTC (12 years, 7 months ago) by dpvc
File size: 24564 byte(s)
More updates for marking MathObjects with the context in which they
were created, so they should now work like the Formula objects in that
respect.  As they are combined via overloaded operators, they should
pass on their contexts correctly.

Also normalized the use of getFlag() to obtain flags from the
MathObject's context rather than looking in the context directly.
This allows the math object to override the flag by setting the flag
value in the object's hash (e.g., $f->{tolerance} = .001).  I've also
added the ability to override context flags via the answerHash (e.g.,
$f->cmp(tolerance => .001)), though some filtering may need to be
added to this at some point.  Note that ONLY the context flags can be
overridden, not other parts of the context.

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9