1package Math::SymbolicX::Inline; 2 3use 5.006001; 4use strict; 5use warnings; 6use Carp qw/cluck confess/; 7use Math::Symbolic qw/parse_from_string U_P_DERIVATIVE U_T_DERIVATIVE/; 8use Math::Symbolic::Custom::Contains; 9use Math::Symbolic::Compiler qw/compile_to_code/; 10 11our $VERSION = '1.11'; 12 13sub import { 14 15 # Just using the module shouldn't throw a fatal error. 16 if ( @_ != 2 ) { 17 return (); 18 } 19 20 my ( $class, $code ) = @_; 21 my ( $pkg, undef ) = caller; 22 23 my %definitions; 24 25 if ( not defined $code ) { 26 confess "undef passed to Math::SymbolicX::Inline as source\n" 27 . "code. Can't compile undef to something reasonable, can you?"; 28 } 29 30 my @lines = split /\n+/, $code; 31 my $lastsymbol = undef; 32 foreach my $line (@lines) { 33 34 # prepare the line, skip empty lines, strip comments... 35 chomp $line; 36 $line =~ s/\#.*$//; 37 next if $line =~ /^\s*$/; 38 $line =~ s/^\s+//; 39 $line =~ s/\s+$//; 40 41 # new definitions 42 if ( $line =~ /^([A-Za-z_][A-Za-z0-9_]*)\s*(\(:?=\)|:?=)(.*)$/ ) { 43 my ( $symbol, $type, $codestart ) = ( $1, $2, $3 ); 44 if ( exists $definitions{$1} ) { 45 confess "(Math::SymbolicX::Inline:) Symbol " 46 . "'$symbol' redefined in package '$pkg'."; 47 } 48 49 $definitions{$symbol} = { 50 code => $codestart, 51 type => $type, 52 }; 53 54 # Check syntax of the finished piece of code here 55 _check_syntax( \%definitions, $lastsymbol ); 56 57 $lastsymbol = $symbol; 58 } 59 else { 60 if ( not defined $lastsymbol ) { 61 confess "Math::SymbolicX::Inline code must " 62 . "start with a symbol."; 63 } 64 $definitions{$lastsymbol}{code} .= ' ' . $line; 65 } 66 } 67 68 # Check the syntax of the last piece of code 69 _check_syntax( \%definitions, $lastsymbol ); 70 71 # Now we start distinguishing between the different operator types. 72 73 my %early; 74 my %late; 75 76 foreach my $s ( keys %definitions ) { 77 if ( $definitions{$s}{type} eq '=' ) { 78 $early{$s} = $definitions{$s}; 79 } 80 elsif ( $definitions{$s}{type} eq ':=' ) { 81 $late{$s} = $definitions{$s}; 82 } 83 elsif ( $definitions{$s}{type} eq '(=)' ) { 84 $early{$s} = $definitions{$s}; 85 } 86 elsif ( $definitions{$s}{type} eq '(:=)' ) { 87 $late{$s} = $definitions{$s}; 88 } 89 else { 90 confess "Something went wrong: We parsed an invalid " 91 . "operator type '" 92 . $definitions{$s}{type} 93 . "' for " 94 . "symbol '$s'"; 95 } 96 } 97 98 # Implement early replace dependencies 99 my @pairs; 100 foreach my $s ( keys %early ) { 101 my @sig = $early{$s}{parsed}->explicit_signature(); 102 foreach (@sig) { 103 104 # Exclude the late and external dependencies 105 next if not exists $early{$_}; 106 push @pairs, [ $_, $s ]; 107 } 108 } 109 my @sort = _topo_sort( \@pairs ); 110 111 # Detect cycles 112 if ( @sort == 1 and not defined $sort[0] ) { 113 confess "Detected cycle in definitions. Cannot do topological " 114 . "sort"; 115 } 116 117 # actually implement symbolic dependencies of early replaces 118 foreach my $sym (@sort) { 119 my $f = $early{$sym}{parsed}; 120 my @sig = $f->explicit_signature(); 121 $f->implement( 122 map { ( $_ => $early{$_}{parsed}->new() ) } 123 grep { exists $early{$_} } @sig 124 ); 125 126 $early{$sym}{parsed} = $f; 127 } 128 129 # apply derivatives 130 foreach my $sym ( keys %early ) { 131 my $f = $early{$sym}{parsed}; 132 $f = $f->simplify()->apply_derivatives()->simplify(); 133 if ( $f->contains_operator(U_P_DERIVATIVE) 134 or $f->contains_operator(U_T_DERIVATIVE) ) 135 { 136 confess "Could not apply all derivatives in function '$sym'."; 137 } 138 139 $early{$sym}{parsed} = $f; 140 } 141 142 # Implement late replace dependencies 143 @pairs = (); 144 foreach my $s ( keys %late ) { 145 my @sig = $late{$s}{parsed}->explicit_signature(); 146 foreach (@sig) { 147 148 # Die on dependencies on early replaced functions 149 confess "Dependency on outer scope function '$_' " 150 . "found in function '$s'." 151 if exists $early{$_}; 152 153 # Exclude the external dependencies 154 next if not exists $late{$_}; 155 push @pairs, [ $_, $s ]; 156 } 157 } 158 159 @sort = _topo_sort( \@pairs ); 160 161 # Detect cycles 162 if ( @sort == 1 and not defined $sort[0] ) { 163 confess "Detected cycle in definitions. Cannot do topological " 164 . "sort"; 165 } 166 167 # actually implement symbolic dependencies of late replaces 168 foreach my $sym (@sort) { 169 my $f = $late{$sym}{parsed}; 170 my @sig = $f->explicit_signature(); 171 $f->implement( 172 map { ( $_ => $late{$_}{parsed}->new() ) } 173 grep { exists $late{$_} } @sig 174 ); 175 $f = $f->simplify()->apply_derivatives()->simplify(); 176 $late{$sym}{parsed} = $f; 177 } 178 179 # apply derivatives 180 foreach my $sym ( keys %late ) { 181 my $f = $late{$sym}{parsed}; 182 $f = $f->simplify()->apply_derivatives()->simplify(); 183 if ( $f->contains_operator(U_P_DERIVATIVE) 184 or $f->contains_operator(U_T_DERIVATIVE) ) 185 { 186 confess "Could not apply all derivatives in function '$sym'."; 187 } 188 189 $late{$sym}{parsed} = $f; 190 } 191 192 # implement symbolic dependencies of early replaces on late replaces 193 foreach my $s ( keys %early ) { 194 $early{$s}{parsed}->implement( 195 map { ( $_ => $late{$_}{parsed}->new() ) } 196 keys %late 197 ); 198 } 199 200 # external dependencies, compilation and subs 201 foreach my $obj ( 202 ( map { [ $_ => $early{$_} ] } keys %early ), 203 ( map { [ $_ => $late{$_} ] } keys %late ) 204 ) 205 { 206 my ( $sym, $h ) = @$obj; 207 208 # don't compile anything with parens in the operator. 209 next if $h->{type} =~ /^\(:?=\)$/; 210 211 # external dependencies 212 my @external = $h->{parsed}->explicit_signature(); 213 214 # actual arguments 215 my @args = 216 map { "arg$_" } 217 sort { $a <=> $b } 218 map { /^arg(\d+)$/; $1 } 219 grep { /^arg\d+$/ } @external; 220 my $highest = $args[-1]; 221 if ( not defined $highest or $highest eq '' ) { 222 $highest = 0; 223 } 224 else { 225 $highest =~ s/^arg(\d+)$/$1/; 226 } 227 228 # number of arguments. 229 my $num_args = @args==0 ? 0 : $highest+1; 230 231 # external sub calls 232 my @real_external = sort grep { $_ !~ /^arg\d+$/ } @external; 233 my $num_real_external = @real_external; 234 235 # This is where it gets really fancy! 236 # ... and This is not the Right Way To Do It! FIXME!!! 237 my $final_code = "sub {\n"; 238 $final_code .= "my \@args = \@_;\n" if $num_real_external; 239 240 if (@args) { 241 $final_code .= <<HERE; 242if (\@_ < $highest+1) { 243 cluck( 244 "Warning: Math::SymbolicX::Inline compiled sub " 245 ."'${pkg}::${sym}'\nrequires $num_args argument(s) " 246 ."but received only " . scalar(\@_) 247 ); 248} 249if (grep {!defined} \@_[0..$highest]) { 250 cluck( 251 "Warning: Undefined value passed to '${pkg}::${sym}'" 252 ); 253} 254HERE 255 } 256 257 my $num_argsm1 = $num_args - 1; 258 259 $final_code .= "local \@_[0..$num_argsm1+$num_real_external] = (" 260 . join( ', ', 261 @args ? ( map { "\$_[$_]" } 0..$highest ) : (), 262 ( map { "${pkg}::$_(\@args)" } @real_external ) ) 263 . ");\n" 264 if $num_real_external; 265 266 my $vars = [ @args?(map {"arg$_"} 0..$highest):(), @real_external ]; 267 268 my ( $mcode, $trees ); 269 eval { ( $mcode, $trees ) = compile_to_code( $h->{parsed}, $vars ); }; 270 if ( $@ or not defined $mcode ) { 271 confess "Could not compile Perl code for function " . "'$sym'."; 272 } 273 if ( defined $trees and @$trees ) { 274 confess <<HERE; 275Could not resolve all trees in Math::Symbolic expression. That means, the 276compiler encountered operators that could not be compiled to Perl code. 277These include derivatives, but those should usually be applied before 278compilation. Details can be found in the Math::Symbolic::Compiler man-page. 279The expression that should have been compiled is: 280--- 281$code 282--- 283HERE 284 } 285 $final_code .= $mcode . "\n};\n"; 286 287 # DEBUG OUTPUT 288 # warn "$sym = $final_code\n\n"; 289 290 my $anon_sub = _make_sub($final_code); 291 if ($@) { 292 confess <<HERE; 293Something went wrong compiling the code for '${pkg}::$sym'. 294This was the source: 295--- 296$code 297--- 298And the cluttery generated code is: 299--- 300$final_code 301--- 302HERE 303 } 304 305 do { 306 no strict; 307 *{"${pkg}::${sym}"} = \&$anon_sub; 308 }; 309 } 310} 311 312# create an anonymous sub in a clean environment. 313sub _make_sub { 314 return eval $_[0]; 315} 316 317# Takes array of pairs as argument (1 pair: ['x', 'y']) 318# returns topological sort 319# returns undef in case of cycles 320sub _topo_sort { 321 my $pairs = shift; 322 323 my %pairs; # all pairs ($l, $r) 324 my %npred; # number of predecessors 325 my %succ; # list of successors 326 327 foreach my $p (@$pairs) { 328 my ( $l, $r ) = @$p; 329 next if defined $pairs{$l}{$r}; 330 $pairs{$l}{$r}++; 331 $npred{$l} += 0; 332 ++$npred{$r}; 333 push @{ $succ{$l} }, $r; 334 } 335 336 # create a list of nodes without predecessors 337 my @list = grep { !$npred{$_} } keys %npred; 338 339 my @return; 340 while (@list) { 341 $_ = pop @list; 342 push @return, $_; 343 foreach my $child ( @{ $succ{$_} } ) { 344 unshift @list, $child unless --$npred{$child}; 345 } 346 } 347 348 return (undef) if grep { $npred{$_} } keys %npred; 349 return @return; 350} 351 352# Check the syntax of a definition 353sub _check_syntax { 354 my ( $definitions, $lastsymbol ) = @_; 355 if ( defined $lastsymbol ) { 356 my $parsed; 357 eval { 358 $parsed = parse_from_string( $definitions->{$lastsymbol}{code} ); 359 }; 360 if ($@) { 361 confess "Parsing of Math::SymbolicX::Inline " 362 . "section failed. Error:\n$@"; 363 } 364 elsif ( not defined $parsed ) { 365 my $t = $definitions->{$lastsymbol}{code}; 366 confess <<HERE; 367Parsing of Math::SymbolicX::Inline section failed due to an unknown error. 368The offending expression (for symbol '$lastsymbol') is: 369--- 370$t 371--- 372HERE 373 } 374 $definitions->{$lastsymbol}{parsed} = $parsed; 375 } 376} 377 3781; 379__END__ 380 381=head1 NAME 382 383Math::SymbolicX::Inline - Inlined Math::Symbolic functions 384 385=head1 SYNOPSIS 386 387 use Math::SymbolicX::Inline <<'END'; 388 foo = x * bar 389 bar = partial_derivative(x^2, x) 390 x (:=) arg0 + 1 391 END 392 393 print bar(3); 394 # prints '8' which is 2*(3+1)... 395 396 print foo(3); 397 # prints '32' which is 2*(3+1)*(3+1) 398 399 print x(3); 400 # Throws an error because the parenthesis around the operator make 401 # the declaration of x private. 402 403=head1 DESCRIPTION 404 405This module is an extension to the Math::Symbolic module. A basic 406familiarity with that module is required. 407 408Math::SymbolicX::Inline allows easy creation of Perl functions from 409symbolic expressions in the context of Math::Symbolic. That means 410you can define arbitrary Math::Symbolic trees (including derivatives) 411and let this module compile them to package subroutines. 412 413There are relatively few syntax elements that aren't standard in 414Math::Symbolic expressions, but those that exist are easier to 415explain using examples. Thus, please refer to the discussion of 416a simple example below. 417 418=head2 EXPORT 419 420This module does not export any functions, but its intended usage is 421to create functions in the current namespace for you. 422 423=head2 A SIMPLE EXAMPLE 424 425A contrived sample usage would be to create a function that computes 426the derivative of the square of the sine. You could do the math 427yourself and find that the x-derivative of C<sin(x)*sin(x)> is 428C<2*sin(x)*cos(x)>. On the other hand, you might want to change the 429source function later or the derivative is very complicated or you 430are just too lazy to do the math. Then you can write the following 431code to do allow of this for you: 432 433 use Math::SymbolicX::Inline <<'HERE'; 434 myfunction = partial_derivative( sin(arg0) * sin(arg0), arg0 ) 435 HERE 436 437After that, you can use your appropriately named function from Perl. 438This has almost no performance penalty compared to the version you 439would write by hand since Math::Symbolic can compile trees to Perl 440code. (You could, if you were crazy enough, compile it to C using 441L<Math::Symbolic::Custom::CCompiler>.) 442 443 print myfunction(2); 444 445That would print C<-0.756802495307928>. 446 447=head2 EXTENDED USAGE 448 449You will have noticed the usage of the C<arg0> variable in the above 450example. Rather unspectacularily, C<argX> refers to the X+1th argument 451to the function. Thus, C<arg19> refers to the twentieth argument. 452 453But it is atypical to use C<arg0> as a variable in a mathematical 454expression. We want to use the names C<x> and C<y> to compute 455the x-derivative of C<sin(x*y)*sin(x*y)>. Furthermore, 456we want the sine to be exchangeable with a cosine with as little 457effort as possible. That is rather simple to implement: 458 459 my $function = 'sin'; 460 461 use Math::SymbolicX::Inline <<HERE; 462 463 # Our function: 464 myfunction = partial_derivative(inner, x) 465 466 # Supportive declarations: 467 inner (=) $function(x*y)^2 468 x (:=) arg0 469 y (:=) arg1 470 HERE 471 472This short piece of code adds three symbolic declarations. All of 473these new declarations have their assignment operators enclosed in 474parenthesis to signify that they are not to be exported. That means 475you will not be able to call C<inner(2, 3)> afterwards. But you will 476be able to call C<myfunction(2, 3)>. The variable $function is 477interpolated into the HERE document. The manual pages that come with 478Perl will tell you all the details about this kind of quoted string. 479 480The declarations are relatively whitespace insensitive. All you need 481to do is put a new declaration with the assignment operator on a new 482line. It does not matter how man lines a single equation takes. 483This is valid: 484 485 myfunction = 486 partial_derivative( 487 inner, x 488 ) 489 inner (=) $function(x*y)^2 490 ... 491 492Whereas this is not: 493 494 myfunction 495 = partial_derivative(inner, x) 496 ... 497 498It is relevant to note that the order of the declarations is 499irrelevant. You could have written 500 501 x (:=) arg0 502 ... 503 myfunction = partial_derivative(inner, x) 504 505instead and you would have gotten the same result. 506 507You can also remove any of the parenthesis around the assignment 508operators to make the declared function accessible from your 509Perl code. 510 511You may have wondered about the C<:=> operator used in the 512declaration of C<x> and C<y>. This operator is interesting 513in the context of derivatives only. Say, you want to compute 514the partial x-derivative of a function C<inner>. If you want to 515be really correct about it, that derivative is C<0>! That's because 516The term you are deriving (C<inner>) is - strictly speaking - 517not dependent on C<x>. You have to put the function definition 518of C<inner> into place before deriving to get a sensible result. 519 520Therefore, in general, you want to replace any usage of a function 521with its definition in order to be able to derive it. 522 523Now, this brings up another problem. If we do the same for C<x>, we 524will have C<arg0> in its place and can't derive either. That's 525where the C<:=> operator comes in. It replaces the function 526B<after> the applying all derivatives. 527 528The consequence of this is that you cannot reference a normal 529function like C<inner> in the definitions for late-replace 530functions like C<x>. 531 532=head2 THE LAST BITS 533 534All calls to functions that don't exist in the block of declarations 535passed to Math::SymbolicX::Inline will be resolved to subroutine 536calls in the current package. If the subroutines don't exist, 537the module will throw an error with a stack backtrace. 538 539=head1 SEE ALSO 540 541New versions of this module can be found on http://steffen-mueller.net or CPAN. 542 543L<Math::Symbolic> 544 545L<Math::Symbolic::Compiler>, L<Math::Symbolic::Custom::CCompiler> 546 547This module does not use the Inline module an thus is not in the 548Inline:: hierarchy of modules. Nonetheless, similar modules usually 549can be found in that hierarchy: L<Inline> 550 551=head1 AUTHOR 552 553Steffen M�ller, E<lt>symbolic-module at steffen-mueller dot net<gt> 554 555=head1 COPYRIGHT AND LICENSE 556 557Copyright (C) 2005 by Steffen M�ller 558 559This library is free software; you can redistribute it and/or modify 560it under the same terms as Perl itself, either Perl version 5.8.4 or, 561at your option, any later version of Perl 5 you may have available. 562 563 564=cut 565