[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 3652 - (download) (as text) (annotate)
Sat Sep 24 00:47:30 2005 UTC (14 years, 4 months ago) by dpvc
File size: 24762 byte(s)
Added ability to have answers that are empty strings.  String("") now
will produce a valid string object regardless of the Context's defined
string values.  (You can prevent this using

       Context()->flags->set(allowEmptyStrings=>0);

if you wish).  String("")->cmp will produce an answer checker for an
empty string (it removes the blank checker that WW installs).

    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   Value::makeValue($self->{tree}->eval);
  574 }
  575 
  576 ##################################################
  577 #
  578 #  Removes redundent items (like x+-y, 0+x and 1*x, etc)
  579 #  using the provided flags
  580 #
  581 sub reduce {
  582   my $self = shift;
  583   $self = $self->copy($self);
  584   my $reduce = $self->{context}{reduction};
  585   $self->{context}{reduction} = {%{$reduce},@_};
  586   $self->{tree} = $self->{tree}->reduce;
  587   $self->{variables} = $self->{tree}->getVariables;
  588   $self->{context}{reduction} = $reduce if $reduce;
  589   return $self;
  590 }
  591 
  592 ##################################################
  593 #
  594 #  Substitute values for one or more variables
  595 #
  596 sub substitute {
  597   my $self = shift;
  598   $self = $self->copy($self);
  599   $self->setValues(@_);
  600   foreach my $x (keys %{$self->{values}}) {delete $self->{variables}{$x}}
  601   $self->{tree} = $self->{tree}->substitute;
  602   return $self;
  603 }
  604 
  605 ##################################################
  606 #
  607 #  Produces a printable string (substituting the given values).
  608 #
  609 sub string {
  610   my $self = shift;
  611   $self->setValues(@_);
  612   $self->{tree}->string;
  613 }
  614 
  615 ##################################################
  616 #
  617 #  Produces a TeX string (substituting the given values).
  618 #
  619 sub TeX {
  620   my $self = shift;
  621   $self->setValues(@_);
  622   $self->{tree}->TeX;
  623 }
  624 
  625 ##################################################
  626 #
  627 #  Produces a perl eval string (substituting the given values).
  628 #
  629 sub perl {
  630   my $self = shift;
  631   $self->setValues(@_);
  632   my $perl = $self->{tree}->perl;
  633   $perl = 'new Value::Real('.$perl.')' if $self->isRealNumber;
  634   return $perl;
  635 }
  636 
  637 ##################################################
  638 #
  639 #  Produce a perl function
  640 #
  641 #  (Parameters specify an optional name and an array reference of
  642 #   optional variables. If the name is not included, an anonymous
  643 #   code reference is returned.  If the variables are not included,
  644 #   then the variables from the formula are used in sorted order.)
  645 #
  646 sub perlFunction {
  647   my $self = shift; my $name = shift || ''; my $vars = shift;
  648   $vars = [sort(keys %{$self->{variables}})] unless $vars;
  649   my $n = scalar(@{$vars}); my $vnames = '';
  650   if ($n > 0) {
  651     my @v = (); foreach my $x (@{$vars}) {CORE::push(@v,'$'.$x)}
  652     $vnames = "my (".join(',',@v).") = \@_;";
  653   }
  654   my $fn = eval
  655    "package main;
  656     sub $name {
  657       die \"Wrong number of arguments".($name?" to '$name'":'')."\" if scalar(\@_) != $n;
  658       $vnames
  659       return ".$self->perl.";
  660     }";
  661   $self->Error($@) if $@;
  662   return $fn;
  663 }
  664 
  665 
  666 ##################################################
  667 #
  668 #  Sets the values of variables for evaluation purposes
  669 #
  670 sub setValues {
  671   my $self = shift; my ($value,$type);
  672   my $variables = $self->{context}{variables};
  673   $self->{values} = {@_};
  674   foreach my $x (keys %{$self->{values}}) {
  675     $self->Error(["Undeclared variable '%s'",$x]) unless defined $variables->{$x};
  676     $value = Value::makeValue($self->{values}{$x});
  677     $value = Value::Formula->new($value) unless Value::isValue($value);
  678     ($value,$type) = Value::getValueType($self,$value);
  679     $self->Error(["Variable '%s' should be of type %s",$x,$variables->{$x}{type}{name}])
  680       unless Parser::Item::typeMatch($type,$variables->{$x}{type});
  681     $self->{values}{$x} = $value;
  682   }
  683 }
  684 
  685 
  686 ##################################################
  687 ##################################################
  688 #
  689 #  Produce a vector in ijk form
  690 #
  691 sub ijk {
  692   my $self = shift;
  693   $self->{tree}->ijk;
  694 }
  695 
  696 #########################################################################
  697 #########################################################################
  698 #
  699 #  Load the sub-classes and Value.pm
  700 #
  701 
  702 use Parser::Item;
  703 use Value;
  704 use Parser::Context;
  705 use Parser::Context::Default;
  706 use Parser::Differentiation;
  707 
  708 ###########################################################################
  709 
  710 use vars qw($installed);
  711 $Parser::installed = 1;
  712 
  713 ###########################################################################
  714 ###########################################################################
  715 #
  716 #   To Do:
  717 #
  718 # handle sqrt(-1) and log of negatives (make complexes)
  719 # do division by zero and log of zero checks in compound functions
  720 # make reduce have reduce patterns as parameters
  721 # more reduce patterns
  722 # make operator strings customizable (reduce, and other places they are used)
  723 #
  724 #########################################################################
  725 
  726 1;
  727 

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9