[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 2798 - (download) (as text) (annotate)
Sun Sep 19 11:29:06 2004 UTC (15 years, 2 months ago) by dpvc
File size: 24131 byte(s)
Make Formula()->eval return a Real (ie, aValue::Real object) rather
than a perl number.  That way, you can use $f->eval->cmp rather than
needing Real($f->eval)->cmp, and so on.

Also make Formula()->perl do the same, for consistency.

(This could have been accomplished by having the Parser::Number class
evaluate to a Real, but for efficiency during computation, we put
off making the Real object until the end.  It probably doesn't make
that big a difference, but every little bit helps.)

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9