Parent Directory
| 
Revision Log
Fixed some inconsistencies between handing of matrices within the parser and Value packages. Added a predefined Matrix context.
1 ########################################################################### 2 # 3 # Implements the Formula class. 4 # 5 package Value::Formula; 6 my $pkg = 'Value::Formula'; 7 8 use strict; 9 use vars qw(@ISA); 10 @ISA = qw(Parser Value); 11 12 use overload 13 '+' => \&add, 14 '-' => \&sub, 15 '*' => \&mult, 16 '/' => \&div, 17 '**' => \&power, 18 '.' => \&dot, 19 'x' => \&cross, 20 '<=>' => \&compare, 21 'cmp' => \&Value::cmp, 22 '~' => sub {Parser::Function->call('conj',$_[0])}, 23 'neg' => sub {$_[0]->neg}, 24 'sin' => sub {Parser::Function->call('sin',$_[0])}, 25 'cos' => sub {Parser::Function->call('cos',$_[0])}, 26 'exp' => sub {Parser::Function->call('exp',$_[0])}, 27 'abs' => sub {Parser::Function->call('abs',$_[0])}, 28 'log' => sub {Parser::Function->call('log',$_[0])}, 29 'sqrt' => sub {Parser::Function->call('sqrt',$_[0])}, 30 'atan2' => \&atan2, 31 'nomethod' => \&Value::nomethod, 32 '""' => \&Value::stringify; 33 34 # 35 # Call Parser to make the new item 36 # 37 sub new {shift; $pkg->SUPER::new(@_)} 38 39 # 40 # Create the new parser with no string 41 # (we'll fill in its tree by hand) 42 # 43 sub blank {$pkg->SUPER::new('')} 44 45 # 46 # Get the type from the tree 47 # 48 sub typeRef {(shift)->{tree}->typeRef} 49 50 ############################################ 51 # 52 # Create a BOP from two operands 53 # 54 # Get the context and variables from the left and right operands 55 # if they are formulas 56 # Make them into Value objects if they aren't already. 57 # Convert '+' to union for intervals or unions. 58 # Make a new BOP with the two operands. 59 # Record the variables. 60 # Evaluate the formula if it is constant. 61 # 62 sub bop { 63 my ($l,$r,$flag,$bop) = @_; 64 if ($l->promotePrecedence($r)) {return $r->add($l,!$flag)} 65 if ($flag) {my $tmp = $l; $l = $r; $r = $tmp} 66 my $formula = $pkg->blank; 67 my $vars = {}; 68 if (ref($r) eq $pkg) { 69 $formula->{context} = $r->{context}; 70 $vars = {%{$vars},%{$r->{variables}}}; 71 $r = $r->{tree}->copy($formula); 72 } 73 if (ref($l) eq $pkg) { 74 $formula->{context} = $l->{context}; 75 $vars = {%{$vars},%{$l->{variables}}}; 76 $l = $l->{tree}->copy($formula); 77 } 78 $l = $pkg->new($l) if (!ref($l) && Value::getType($formula,$l) eq "unknown"); 79 $r = $pkg->new($r) if (!ref($r) && Value::getType($formula,$r) eq "unknown"); 80 $l = Parser::Value->new($formula,$l) unless ref($l) =~ m/^Parser::/; 81 $r = Parser::Value->new($formula,$r) unless ref($r) =~ m/^Parser::/; 82 $bop = 'U' if $bop eq '+' && 83 ($l->type =~ m/Interval|Union/ || $r->type =~ m/Interval|Union/); 84 $formula->{tree} = Parser::BOP->new($formula,$bop,$l,$r); 85 $formula->{variables} = {%{$vars}}; 86 return $formula->eval if scalar(%{$vars}) == 0; 87 return $formula; 88 } 89 90 sub add {bop(@_,'+')} 91 sub sub {bop(@_,'-')} 92 sub mult {bop(@_,'*')} 93 sub div {bop(@_,'/')} 94 sub power {bop(@_,'**')} 95 sub cross {bop(@_,'><')} 96 97 # 98 # Make dot work for vector operands 99 # 100 sub dot { 101 my ($l,$r,$flag) = @_; 102 if ($l->promotePrecedence($r)) {return $r->compare($l,!$flag)} 103 return bop(@_,'.') if $l->type eq 'Vector' && 104 Value::isValue($r) && $r->type eq 'Vector'; 105 Value::_dot(@_); 106 } 107 108 ############################################ 109 # 110 # Form the negation of a formula 111 # 112 sub neg { 113 my $self = shift; 114 my $formula = $self->blank; 115 $formula->{context} = $self->{context}; 116 $formula->{variables} = $self->{variables}; 117 $formula->{tree} = Parser::UOP->new($formula,'u-',$self->{tree}->copy($formula)); 118 return $formula->eval if scalar(%{$formula->{variables}}) == 0; 119 return $formula; 120 } 121 122 # 123 # Form the function atan2 function call on two operands 124 # 125 sub atan2 { 126 my ($l,$r,$flag) = @_; 127 if ($l->promotePrecedence($r)) {return $r->compare($l,!$flag)} 128 if ($flag) {my $tmp = $l; $l = $r; $r = $tmp} 129 Parser::Function->call('atan2',$l,$r); 130 } 131 132 ############################################ 133 # 134 # Compare two functions for equality 135 # 136 sub compare { 137 my ($l,$r,$flag) = @_; my $self = $l; 138 if ($l->promotePrecedence($r)) {return $r->compare($l,!$flag)} 139 $r = Value::Formula->new($r) unless Value::isFormula($r); 140 Value::Error("Functions from different contexts can't be compared") 141 unless $l->{context} == $r->{context}; 142 143 # 144 # Get the test points and evaluate the functions at those points 145 # 146 ## FIXME: Check given points for consistency 147 my $points = $l->{test_points} || $r->{test_points} || $l->createRandomPoints; 148 my $lvalues = $l->{test_values} || $l->createPointValues($points,1); 149 my $rvalues = $r->createPointValues($points); 150 # 151 # Note: $l is bigger if $r can't be evaluated at one of the points 152 return 1 unless $rvalues; 153 154 # 155 # Look through the two lists to see if they are equal. 156 # If not, return the comparison of the first unequal value 157 # (not good for < and >, but OK for ==). 158 # 159 my ($i, $cmp); 160 foreach $i (0..scalar(@{$lvalues})-1) { 161 $cmp = $lvalues->[$i] <=> $rvalues->[$i]; 162 return $cmp if $cmp; 163 } 164 return 0; 165 } 166 167 # 168 # Create the value list from a given set of test points 169 # 170 sub createPointValues { 171 my $self = shift; 172 my $points = shift || $self->{test_points} || $self->createRandomPoints; 173 my $showError = shift; 174 my $f = $self->{f}; 175 $f = $self->{f} = $self->perlFunction(undef,[$self->{context}->variables->names]) 176 unless $f; 177 178 my $values = []; my $v; 179 foreach my $p (@{$points}) { 180 $v = eval {&$f(@{$p})}; 181 if (!defined($v)) { 182 return unless $showError; 183 Value::Error("Can't evaluate formula on test point (".join(',',@{$p}).")"); 184 } 185 push @{$values}, Value::makeValue($v); 186 } 187 188 $self->{test_points} = $points; 189 $self->{test_values} = $values; 190 } 191 192 # 193 # Create a list of random points, making sure that the function 194 # is defined at the given points. Error if we can't find enough. 195 # 196 sub createRandomPoints { 197 my $self = shift; 198 my $num_points = @_[0]; 199 $num_points = int($self->getFlag('num_points',5)) unless defined($num_points); 200 $num_points = 1 if $num_points < 1; 201 202 my @vars = $self->{context}->variables->names; 203 my @limits = $self->getVariableLimits(@vars); 204 my @make = $self->getVariableTypes(@vars); 205 my $f = $self->{f}; $f = $self->{f} = $self->perlFunction(undef,[@vars]) unless $f; 206 my $seedRandom = $self->{context}->flag('random_seed')? 'PGseedRandom' : 'seedRandom'; 207 my $getRandom = $self->{context}->flag('random_seed')? 'PGgetRandom' : 'getRandom'; 208 209 $self->$seedRandom; 210 my $points = []; my $values = []; 211 my (@P,@p,$v,$i); my $k = 0; 212 while (scalar(@{$points}) < $num_points && $k < 10) { 213 @P = (); $i = 0; 214 foreach my $limit (@limits) { 215 @p = (); foreach my $I (@{$limit}) {push @p, $self->$getRandom(@{$I})} 216 push @P, $make[$i++]->make(@p); 217 } 218 $v = eval {&$f(@P)}; 219 if (!defined($v)) {$k++} else { 220 push @{$points}, [@P]; 221 push @{$values}, Value::makeValue($v); 222 $k = 0; # reset count when we find a point 223 } 224 } 225 226 Value::Error("Can't generate enough valid points for comparison") if $k; 227 return ($points,$values) if defined(@_[0]); 228 $self->{test_values} = $values; 229 $self->{test_points} = $points; 230 } 231 232 # 233 # Get the array of variable limits 234 # 235 sub getVariableLimits { 236 my $self = shift; 237 my $userlimits = $self->{limits}; 238 if (defined($userlimits)) { 239 $userlimits = [[[-$userlimits,$userlimits]]] unless ref($userlimits) eq 'ARRAY'; 240 $userlimits = [$userlimits] unless ref($userlimits->[0]) eq 'ARRAY'; 241 $userlimits = [$userlimits] if scalar(@_) == 1 && ref($userlimits->[0][0]) ne 'ARRAY'; 242 foreach my $I (@{$userlimits}) {$I = [$I] unless ref($I->[0]) eq 'ARRAY'}; 243 } 244 $userlimits = [] unless $userlimits; my @limits; 245 my $default; $default = $userlimits->[0][0] if defined($userlimits->[0]); 246 my $default = $default || $self->{context}{flags}{limits} || [-2,2]; 247 my $granularity = $self->getFlag('granularity',1000); 248 my $resolution = $self->getFlag('resolution'); 249 my $i = 0; 250 foreach my $x (@_) { 251 my $def = $self->{context}{variables}{$x}; 252 my $limit = $userlimits->[$i++] || $def->{limits} || []; 253 $limit = [$limit] if defined($limit->[0]) && ref($limit->[0]) ne 'ARRAY'; 254 push(@{$limit},$limit->[0] || $default) while (scalar(@{$limit}) < $def->{type}{length}); 255 pop(@{$limit}) while (scalar(@{$limit}) > $def->{type}{length}); 256 push @limits, $self->addGranularity($limit,$def,$granularity,$resolution); 257 } 258 return @limits; 259 } 260 261 # 262 # Add the granularity to the limit intervals 263 # 264 sub addGranularity { 265 my $self = shift; my $limit = shift; my $def = shift; 266 my $granularity = shift; my $resolution = shift; 267 $granularity = $def->{granularity} || $granularity; 268 $resolution = $def->{resolution} || $resolution; 269 foreach my $I (@{$limit}) { 270 my ($a,$b,$n) = @{$I}; $b = -$a unless defined $b; 271 $I = [$a,$b,($n || $resolution || abs($b-$a)/$granularity)]; 272 } 273 return $limit; 274 } 275 276 # 277 # Get the routines to make the coordinates of the points 278 # 279 sub getVariableTypes { 280 my $self = shift; 281 my @make; 282 foreach my $x (@_) { 283 my $type = $self->{context}{variables}{$x}{type}; 284 if ($type->{name} eq 'Number') { 285 push @make,($type->{length} == 1)? 'Value::Formula::number': 'Value::Complex'; 286 } else { 287 push @make, "Value::$type->{name}"; 288 } 289 } 290 return @make; 291 } 292 293 # 294 # Fake object for making reals (rather than use overhead of Value::Real) 295 # 296 sub Value::Formula::number::make {shift; shift} 297 298 ## 299 ## debugging routine 300 ## 301 #sub main::Format { 302 # my $v = scalar(@_) > 1? [@_]: shift; 303 # $v = [%{$v}] if ref($v) eq 'HASH'; 304 # return $v unless ref($v) eq 'ARRAY'; 305 # my @V; foreach my $x (@{$v}) {push @V, main::Format($x)} 306 # return '['.join(",",@V).']'; 307 #} 308 309 # 310 # Random number generator (replaced by Value::WeBWorK.pm) 311 # 312 sub seedRandom {srand} 313 sub getRandom { 314 my $self = shift; 315 my ($m,$M,$n) = @_; $n = 1 unless $n; 316 return $m + $n*int(rand()*(int(($M-$m)/$n)+1)); 317 } 318 319 # 320 # Get the value of a flag from the object itself, 321 # or from the context, or from the default context 322 # or from the given default, whichever is found first. 323 # 324 sub getFlag { 325 my $self = shift; my $name = shift; 326 return $self->{$name} if defined($self->{$name}); 327 return $self->{context}{flags}{$name} if defined($self->{context}{flags}{$name}); 328 return $$Value::context->{flags}{$name} if defined($$Value::context->{flags}{$name}); 329 return shift; 330 } 331 332 ############################################ 333 # 334 # Check if the value of a formula is constant 335 # (could use shift->{tree}{isConstant}, but I don't trust it) 336 # 337 sub isConstant {scalar(%{shift->{variables}}) == 0} 338 339 ########################################################################### 340 341 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |