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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9