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