[system] / trunk / pg / lib / Parser.pm Repository:
ViewVC logotype

Annotation of /trunk/pg/lib/Parser.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2796 - (view) (download) (as text)

1 : sh002i 2558 package Parser;
2 :     my $pkg = "Parser";
3 :     use strict;
4 :    
5 : dpvc 2678 #
6 :     # Map class names to packages (added to Context, and
7 :     # can be overriden to customize the parser)
8 :     #
9 : dpvc 2796 our $class = {Formula => 'Parser::Formula'};
10 : dpvc 2678
11 : dpvc 2796 #
12 :     # Collect the default reduction flags for use in the context
13 :     #
14 :     our $reduce = {};
15 :    
16 : sh002i 2558 ##################################################
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 : dpvc 2660 $string = Value::List->new($string,@_)
26 :     if scalar(@_) > 0 || ref($string) eq 'ARRAY';
27 : sh002i 2558 my $math = bless {
28 :     string => undef,
29 : dpvc 2576 tokens => [], tree => undef,
30 : sh002i 2558 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 : dpvc 2660 } elsif (Value::isValue($string)) {
37 : dpvc 2678 $math->{tree} = $math->{context}{parser}{Value}->new($math,$string);
38 : sh002i 2558 } 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 : dpvc 2592 push(@{$tokens},['error',substr($string,$p0,1),$p0,$p0+1]);
73 : sh002i 2558 $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 : dpvc 2592 /error/ and do {$self->Error("Unexpected character '$ref->[1]'",$ref); last};
106 : sh002i 2558 }
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 : dpvc 2676 # (fix up the reference for spaces or juxtaposition)
151 : sh002i 2558 #
152 :     sub ImplicitMult {
153 :     my $self = shift;
154 : dpvc 2676 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 : dpvc 2657 unless $self->{context}{operators}{' '}{class};
159 : dpvc 2676 $self->Op(' ',$iref);
160 : sh002i 2558 $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 : dpvc 2678 $self->pushOperand($context->{parser}{UOP}->new($self,$name,$top->{value},$ref));
229 : sh002i 2558 } else {
230 :     $name = $context->{operators}{' '}{string}
231 :     if $name eq ' ' or $name eq $context->{operators}{' '}{space};
232 :     $self->pushOperator($name,$op->{precedence});
233 :     }
234 : dpvc 2682 } elsif (($ref && $name ne ' ') || $self->state ne 'fn') {$self->Op($name,$ref)}
235 : sh002i 2558 }
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 : dpvc 2682 # Otherwise if the parens can form Intervals, do so
296 :     # Otherwise report an appropriate error message
297 : sh002i 2558 #
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 : dpvc 2678 my $parser = $self->{context}{parser};
308 : sh002i 2558 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 : dpvc 2678 $self->pushOperand($parser->{List}->new($self,[],1,$paren))
315 : sh002i 2558 }
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 : dpvc 2660 else {$top->{ref}[3]=$ref->[3]; $self->Error("Empty parentheses",$top->{ref})}
319 : sh002i 2558 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 : dpvc 2678 $parser->{List}->new($self,[$top->makeList],$top->{isConstant},$paren,
332 : sh002i 2558 ($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 : dpvc 2678 $parser->{List}->new($self,[$top->makeList],$top->{isConstant},
341 :     $paren,$top->entryType,$open,$type));
342 : sh002i 2558 } 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 : dpvc 2678 $self->pushOperand($context->{parser}{BOP}->new($self,$op->{name},
425 : sh002i 2558 $lop->{value},$rop->{value},$op->{ref}),$op->{reverse});
426 :     }
427 :     } else {
428 :     my $rop = $self->pop; my $op = $self->pop;
429 : dpvc 2678 $self->pushOperand($context->{parser}{UOP}->new
430 : sh002i 2558 ($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 : dpvc 2678 $self->pushOperand($context->{parser}{Function}->new
465 : sh002i 2558 ($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 : dpvc 2650 # Create the number object and check it
474 : sh002i 2558 # Save the number as an operand
475 :     #
476 :     sub Num {
477 :     my $self = shift;
478 :     $self->ImplicitMult() if $self->state eq 'operand';
479 : dpvc 2678 my $num = $self->{context}{parser}{Number}->new($self,shift,$self->{ref});
480 : dpvc 2650 my $check = $self->{context}->flag('NumberCheck');
481 :     &$check($num) if $check;
482 :     $self->pushOperand($num);
483 : sh002i 2558 }
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 : dpvc 2678 my $self = shift; my $ref = $self->{ref}; my $name = shift;
494 :     my $const = $self->{context}{constants}{$name};
495 :     my $parser = $self->{context}{parser};
496 : sh002i 2558 $self->ImplicitMult() if $self->state eq 'operand';
497 :     if (defined($self->{context}{variables}{$name})) {
498 : dpvc 2678 $self->pushOperand($parser->{Variable}->new($self,$name,$ref));
499 : sh002i 2558 } elsif ($const->{keepName}) {
500 : dpvc 2678 $self->pushOperand($parser->{Constant}->new($self,$name,$ref));
501 : sh002i 2558 } else {
502 : dpvc 2678 $self->pushOperand($parser->{Value}->new($self,[$const->{value}],$ref));
503 : sh002i 2558 }
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 : dpvc 2678 $self->pushOperand($self->{context}{parser}{Variable}->new($self,shift,$self->{ref}));
517 : sh002i 2558 }
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 : dpvc 2678 $self->pushOperand($self->{context}{parser}{String}->new($self,shift,$self->{ref}));
543 : sh002i 2558 }
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 :     $self->{tree}->eval;
558 :     }
559 :    
560 :     ##################################################
561 :     #
562 :     # Removes redundent items (like x+-y, 0+x and 1*x, etc)
563 : dpvc 2796 # using the provided flags
564 : sh002i 2558 #
565 :     sub reduce {
566 :     my $self = shift;
567 :     $self = $self->copy($self);
568 : dpvc 2796 my $reduce = $self->{context}{reduction};
569 :     $self->{context}{reduction} = {%{$reduce},@_};
570 : sh002i 2558 $self->{tree} = $self->{tree}->reduce;
571 :     $self->{variables} = $self->{tree}->getVariables;
572 : dpvc 2796 $self->{context}{reduction} = $reduce if $reduce;
573 : sh002i 2558 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 :     $self->{tree}->perl;
617 :     }
618 :    
619 :     ##################################################
620 :     #
621 :     # Produce a perl function
622 :     #
623 :     # (Parameters specify an optional name and an array reference of
624 :     # optional variables. If the name is not included, an anonymous
625 :     # code reference is returned. If the variables are not included,
626 :     # then the variables from the formula are used in sorted order.)
627 :     #
628 :     sub perlFunction {
629 :     my $self = shift; my $name = shift; my $vars = shift;
630 :     $vars = [sort(keys %{$self->{variables}})] unless $vars;
631 :     my $n = scalar(@{$vars}); my $vnames = '';
632 :     if ($n > 0) {
633 :     my @v = (); foreach my $x (@{$vars}) {push(@v,'$'.$x)}
634 :     $vnames = "my (".join(',',@v).") = \@_;";
635 :     }
636 :     my $fn = eval
637 :     "package main;
638 :     sub $name {
639 :     die \"Wrong number of arguments".($name?" to '$name'":'')."\" if scalar(\@_) != $n;
640 :     $vnames
641 :     return ".$self->perl.";
642 :     }";
643 :     $self->Error($@) if $@;
644 :     return $fn;
645 :     }
646 :    
647 :    
648 :     ##################################################
649 :     #
650 :     # Sets the values of variables for evaluation purposes
651 :     #
652 :     sub setValues {
653 :     my $self = shift; my ($value,$type);
654 :     my $variables = $self->{context}{variables};
655 :     $self->{values} = {@_};
656 :     foreach my $x (keys %{$self->{values}}) {
657 :     $self->Error("Undeclared variable '$x'") unless defined $variables->{$x};
658 : dpvc 2605 $value = Value::makeValue($self->{values}{$x});
659 : dpvc 2628 $value = Value::Formula->new($value) unless Value::isValue($value);
660 :     ($value,$type) = Value::getValueType($self,$value);
661 : sh002i 2558 $self->Error("Variable '$x' should be of type $variables->{$x}{type}{name}")
662 : dpvc 2605 unless Parser::Item::typeMatch($type,$variables->{$x}{type});
663 : sh002i 2558 $self->{values}{$x} = $value;
664 :     }
665 :     }
666 :    
667 : dpvc 2576
668 : dpvc 2579 ##################################################
669 :     ##################################################
670 :     #
671 :     # Produce a vector in ijk form
672 :     #
673 :     sub ijk {
674 :     my $self = shift;
675 :     $self->{tree}->ijk;
676 :     }
677 :    
678 : sh002i 2558 #########################################################################
679 :     #########################################################################
680 :     #
681 :     # Load the sub-classes and Value.pm
682 :     #
683 :    
684 :     use Parser::Item;
685 :     use Value;
686 :     use Parser::Context;
687 : dpvc 2579 use Parser::Context::Default;
688 : dpvc 2664 use Parser::Differentiation;
689 : dpvc 2579
690 : dpvc 2576 ###########################################################################
691 : dpvc 2592
692 :     use vars qw($installed);
693 :     $Parser::installed = 1;
694 :    
695 : dpvc 2576 ###########################################################################
696 : dpvc 2592 ###########################################################################
697 : dpvc 2576 #
698 :     # To Do:
699 :     #
700 :     # handle sqrt(-1) and log of negatives (make complexes)
701 :     # do division by zero and log of zero checks in compound functions
702 :     # make reduce have reduce patterns as parameters
703 :     # more reduce patterns
704 :     # make operator strings customizable (reduce, and other places they are used)
705 :     #
706 : sh002i 2558 #########################################################################
707 :    
708 :     1;
709 :    

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9