[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 3374 - (download) (as text) (annotate)
Wed Jul 13 01:46:49 2005 UTC (14 years, 5 months ago) by dpvc
File size: 24487 byte(s)
Wrong correction in the previous commit.  Use CODE::push

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9