[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 2605 - (view) (download) (as text)

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9