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

Diff of /trunk/pg/lib/Value.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

Revision 2576 Revision 2579
1package Value; 1package Value;
2my $pkg = 'Value'; 2my $pkg = 'Value';
3use vars qw(%precedence %parens %Type); 3use vars qw($context $defaultContext %Type);
4use strict; 4use strict;
5 5
6#############################################################
6# 7#
7# Pattern for a generic real number 8# Initialize the context
8# 9#
9my $numPattern = '-?(\d+(\.\d*)?|\.\d+)(E[-+]?\d+)?'; 10
11use Value::Context;
12
13$defaultContext = Value::Context->new(
14 lists => {
15 'Point' => {open => '(', close => ')'},
16 'Vector' => {open => '<', close => '>'},
17 'Matrix' => {open => '[', close => ']'},
18 'List' => {open => '(', close => ')'},
19 },
20 flags => {
21 #
22 # For vectors:
23 #
24 ijk => 0, # print vectors as <...>
25 #
26 # For fuzzy reals:
27 #
28 useFuzzyReals => 1,
29 tolerance => 1E-6,
30 tolType => 'relative',
31 zeroLevel => 1E-14,
32 zeroLevelTol => 1E-12,
33 },
34);
35
36$context = \$defaultContext;
37
10 38
11# 39#
12# Precedence of the various types 40# Precedence of the various types
13# (They will be promoted upward automatically when needed) 41# (They will be promoted upward automatically when needed)
14# 42#
15%precedence = ( 43$$context->{precedence} = {
16 'Number' => 0, 44 'Number' => 0,
45 'Real' => 1,
17 'Complex' => 1, 46 'Complex' => 2,
18 'Point' => 2, 47 'Point' => 3,
19 'Vector' => 3, 48 'Vector' => 4,
20 'Matrix' => 4, 49 'Matrix' => 5,
21 'List' => 5, 50 'List' => 6,
22 'Interval' => 6, 51 'Interval' => 7,
23 'Union' => 7, 52 'Union' => 8,
24 'Formula' => 8, 53 'Formula' => 9,
25); 54};
26 55
27# 56#
28# Binding of perl operator to class method 57# Binding of perl operator to class method
29# 58#
30my %method = ( 59$$context->{method} = {
31 '+' => 'add', 60 '+' => 'add',
32 '-' => 'sub', 61 '-' => 'sub',
33 '*' => 'mult', 62 '*' => 'mult',
34 '/' => 'div', 63 '/' => 'div',
35 '**' => 'power', 64 '**' => 'power',
36 '.' => '_dot', # see _dot below 65 '.' => '_dot', # see _dot below
37 'x' => 'cross', 66 'x' => 'cross',
38 '<=>' => 'compare', 67 '<=>' => 'compare',
39); 68};
40 69
41# 70push(@{$$context->{data}{values}},'method','precedence');
42# The type of paren used in printing a value 71
43# 72#############################################################
44%parens = (
45 'Point' => {open => '(', close => ')'},
46 'Vector' => {open => '<', close => '>'},
47 'Matrix' => {open => '[', close => ']'},
48 'List' => {open => '(', close => ')'},
49);
50 73
51# 74#
52# Check if a value is a number, complex, etc. 75# Check if a value is a number, complex, etc.
53# 76#
54sub matchNumber {my $n = shift; $n =~ m/^$numPattern$/oi} 77sub matchNumber {my $n = shift; $n =~ m/^$$context->{pattern}{signedNumber}$/i}
78sub isReal {class(shift) eq 'Real'}
55sub isComplex {my $n = shift; class($n) eq 'Complex'} 79sub isComplex {class(shift) eq 'Complex'}
56sub isFormula {my $value = shift; class($value) eq 'Formula'} 80sub isFormula {class(shift) eq 'Formula'}
57sub isValue {my $value = shift; ref($value) =~ m/^Value::/} 81sub isValue {ref(shift) =~ m/^Value::/}
58 82
59sub isNumber { 83sub isNumber {
60 my $n = shift; 84 my $n = shift;
61 return 1 if matchNumber($n) || isComplex($n); 85 return $n->{tree}->isNumber if isFormula($n);
62 return (isFormula($n) && $n->{tree}->isNumber); 86 return isReal($n) || isComplex($n) || matchNumber($n);
63} 87}
64 88
65sub isRealNumber { 89sub isRealNumber {
66 my $n = shift; 90 my $n = shift;
91 return $n->{tree}->isRealNumber if isFormula($n);
67 return 1 if matchNumber($n); 92 return isReal($n) || matchNumber($n);
68 return (isFormula($n) && $n->{tree}->isRealNumber);
69} 93}
70 94
71# 95#
72# Get a printable version of the class of an object 96# Get a printable version of the class of an object
73# 97#
165# the parens. If the formula is constant, evaluate it. 189# the parens. If the formula is constant, evaluate it.
166# 190#
167sub formula { 191sub formula {
168 my $self = shift; my $values = shift; 192 my $self = shift; my $values = shift;
169 my $class = $self->class; 193 my $class = $self->class;
170 my $open = $Value::parens{$class}{'open'}; 194 my $list = $$context->lists->get($class);
171 my $close = $Value::parens{$class}{'close'}; 195 my $open = $list->{'open'};
196 my $close = $list->{'close'};
172 my $formula = Value::Formula->blank; 197 my $formula = Value::Formula->blank;
173 my @coords = Value::toFormula($formula,@{$values}); 198 my @coords = Value::toFormula($formula,@{$values});
174 $formula->{tree} = Parser::List->new($formula,[@coords],0, 199 $formula->{tree} = Parser::List->new($formula,[@coords],0,
175 $formula->{context}{parens}{$open},$coords[0]->typeRef,$open,$close); 200 $formula->{context}{parens}{$open},$coords[0]->typeRef,$open,$close);
176 return $formula->eval if scalar(%{$formula->{variables}}) == 0; 201# return $formula->eval if scalar(%{$formula->{variables}}) == 0;
177 return $formula; 202 return $formula;
178} 203}
179 204
180# 205#
181# A shortcut for new() that creates an instance of the object, 206# A shortcut for new() that creates an instance of the object,
251# 276#
252# Promote an operand to the same precedence as the current object 277# Promote an operand to the same precedence as the current object
253# 278#
254sub promotePrecedence { 279sub promotePrecedence {
255 my $self = shift; my $other = shift; 280 my $self = shift; my $other = shift;
256 my $sprec = $precedence{class($self)}; 281 my $sprec = $$context->{precedence}{class($self)};
257 my $oprec = $precedence{class($other)}; 282 my $oprec = $$context->{precedence}{class($other)};
258 return defined($oprec) && $sprec < $oprec; 283 return defined($oprec) && $sprec < $oprec;
259} 284}
260 285
261# 286#
262# Default stub to call when no function is defined for an operation 287# Default stub to call when no function is defined for an operation
263# 288#
264sub nomethod { 289sub nomethod {
265 my ($l,$r,$flag,$op) = @_; 290 my ($l,$r,$flag,$op) = @_;
266 my $call = $method{$op}; 291 my $call = $$context->{method}{$op};
267 if (defined($call) && $l->promotePrecedence($r)) {return $r->$call($l,!$flag)} 292 if (defined($call) && $l->promotePrecedence($r)) {return $r->$call($l,!$flag)}
268 my $error = "Can't use '$op' with ".$l->class."-valued operands"; 293 my $error = "Can't use '$op' with ".$l->class."-valued operands";
269 $error .= " (use '**' for exponentiation)" if $op eq '^'; 294 $error .= " (use '**' for exponentiation)" if $op eq '^';
270 Value::Error($error); 295 Value::Error($error);
271} 296}
286# If the right operand is also a Value object, we do the object's 311# If the right operand is also a Value object, we do the object's
287# dot method to combine the two objects of the same class. 312# dot method to combine the two objects of the same class.
288# 313#
289# Otherwise, since . is used for string concatenation, we want to retain 314# Otherwise, since . is used for string concatenation, we want to retain
290# that. Since the resulting string is often used in Formula and will be 315# that. Since the resulting string is often used in Formula and will be
291# parsed again, we put parentheses around the values to guearantee that 316# parsed again, we put parentheses around the values to guarantee that
292# the values will be treated as one mathematical unit. For example, if 317# the values will be treated as one mathematical unit. For example, if
293# $f = Formula("1+x") and $g = Formula("y") then Formula("$f/$g") will be 318# $f = Formula("1+x") and $g = Formula("y") then Formula("$f/$g") will be
294# (1+x)/y not 1+(x/y), as it would be without the implicit parentheses. 319# (1+x)/y not 1+(x/y), as it would be without the implicit parentheses.
295# 320#
296sub _dot { 321sub _dot {
349# Stubs for when called by Parser 374# Stubs for when called by Parser
350# 375#
351sub eval {shift} 376sub eval {shift}
352sub reduce {shift} 377sub reduce {shift}
353 378
379sub ijk {
380 Value::Error("Can't use method 'ijk' with objects of type '".(shift)->class."'");
381}
382
383use carp;
354# 384#
355# Report an error 385# Report an error
356# 386#
357sub Error { 387sub Error {
358 my $message = shift; 388 my $message = shift;
359 my $context = $Parser::Context::contextTable->{current}; 389 $$context->setError($message,'');
360 $context->setError($message,'') if (defined($context));
361 die $message . Value::getCaller(); 390 die $message . Value::getCaller();
362} 391}
363 392
364# 393#
365# Try to locate the line and file where the error occurred 394# Try to locate the line and file where the error occurred
372 $subname =~ m/^(Value|Parser).*(new|call)$/; 401 $subname =~ m/^(Value|Parser).*(new|call)$/;
373 } 402 }
374 return ""; 403 return "";
375} 404}
376 405
406#
407# For debugging
408#
409sub traceback {
410 my $frame = 2;
411 my $trace = '';
412 while (my ($pkg,$file,$line,$subname) = caller($frame++))
413 {$trace .= " in $subname at line $line of $file\n"}
414 return $trace;
415}
416
377########################################################################### 417###########################################################################
378# 418#
379# Load the sub-classes. 419# Load the sub-classes.
380# 420#
381 421
422use Value::Real;
382use Value::Complex; 423use Value::Complex;
383use Value::Point; 424use Value::Point;
384use Value::Vector; 425use Value::Vector;
385use Value::Matrix; 426use Value::Matrix;
386use Value::List; 427use Value::List;
390 431
391########################################################################### 432###########################################################################
392# 433#
393# To Do: 434# To Do:
394# 435#
395# Make a Real class that does fuzzy comparisons for <, <=, ==, >=, >, !=.
396# Make a class for infinity? 436# Make a class for infinity?
397# Allow printing of ijk format for vectors 437# Make Complex class include more of Complex1.pm
398# 438# Make better interval comparison
399# Share more items between Value and Parser::Context?
400# (In fact, make a Value::Context and have Parser::Context extend that)
401# 439#
402########################################################################### 440###########################################################################
403 441
4041; 4421;

Legend:
Removed from v.2576  
changed lines
  Added in v.2579

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9