File Coverage

blib/lib/Math/SymbolicX/Inline.pm

Criterion	Covered	Total	%
statement	199	218	91.2
branch	59	84	70.2
condition	8	21	38.1
subroutine	13	13	100.0
pod			n/a
total	279	336	83.0

package Math::SymbolicX::Inline;

use 5.006001;
use strict;
use warnings;
use Carp qw/cluck confess/;
use Math::Symbolic qw/parse_from_string U_P_DERIVATIVE U_T_DERIVATIVE/;
use Math::Symbolic::Custom::Contains;
use Math::Symbolic::Compiler qw/compile_to_code/;

our $VERSION = '1.11';

sub import {

    # Just using the module shouldn't throw a fatal error.
    if ( @_ != 2 ) {
        return ();
    }

    my ( $class, $code ) = @_;
    my ( $pkg, undef ) = caller;

    my %definitions;

    if ( not defined $code ) {
        confess "undef passed to Math::SymbolicX::Inline as source\n"
          . "code. Can't compile undef to something reasonable, can you?";
    }

    my @lines = split /\n+/, $code;
    my $lastsymbol = undef;
    foreach my $line (@lines) {

        # prepare the line, skip empty lines, strip comments...
        chomp $line;
        $line =~ s/\#.*$//;
        next if $line =~ /^\s*$/;
        $line =~ s/^\s+//;
        $line =~ s/\s+$//;

        # new definitions
        if ( $line =~ /^([A-Za-z_][A-Za-z0-9_]*)\s*(\(:?=\)|:?=)(.*)$/ ) {
            my ( $symbol, $type, $codestart ) = ( $1, $2, $3 );
            if ( exists $definitions{$1} ) {
                confess "(Math::SymbolicX::Inline:) Symbol "
                  . "'$symbol' redefined in package '$pkg'.";
            }

            $definitions{$symbol} = {
                code => $codestart,
                type => $type,
            };

            # Check syntax of the finished piece of code here
            _check_syntax( \%definitions, $lastsymbol );

            $lastsymbol = $symbol;
        }
        else {
            if ( not defined $lastsymbol ) {
                confess "Math::SymbolicX::Inline code must "
                  . "start with a symbol.";
            }
            $definitions{$lastsymbol}{code} .= ' ' . $line;
        }
    }

    # Check the syntax of the last piece of code
    _check_syntax( \%definitions, $lastsymbol );

    # Now we start distinguishing between the different operator types.

    my %early;
    my %late;

    foreach my $s ( keys %definitions ) {
        if ( $definitions{$s}{type} eq '=' ) {
            $early{$s} = $definitions{$s};
        }
        elsif ( $definitions{$s}{type} eq ':=' ) {
            $late{$s} = $definitions{$s};
        }
        elsif ( $definitions{$s}{type} eq '(=)' ) {
            $early{$s} = $definitions{$s};
        }
        elsif ( $definitions{$s}{type} eq '(:=)' ) {
            $late{$s} = $definitions{$s};
        }
        else {
            confess "Something went wrong: We parsed an invalid "
              . "operator type '"
              . $definitions{$s}{type}
              . "' for "
              . "symbol '$s'";
        }
    }

    # Implement early replace dependencies
    my @pairs;
    foreach my $s ( keys %early ) {
        my @sig = $early{$s}{parsed}->explicit_signature();
        foreach (@sig) {

            # Exclude the late and external dependencies
            next if not exists $early{$_};
            push @pairs, [ $_, $s ];
        }
    }
    my @sort = _topo_sort( \@pairs );

    # Detect cycles
    if ( @sort == 1 and not defined $sort[0] ) {
        confess "Detected cycle in definitions. Cannot do topological "
          . "sort";
    }

    # actually implement symbolic dependencies of early replaces
    foreach my $sym (@sort) {
        my $f   = $early{$sym}{parsed};
        my @sig = $f->explicit_signature();
        $f->implement(
            map { ( $_ => $early{$_}{parsed}->new() ) }
              grep { exists $early{$_} } @sig
        );

        $early{$sym}{parsed} = $f;
    }

    # apply derivatives
    foreach my $sym ( keys %early ) {
        my $f = $early{$sym}{parsed};
        $f = $f->simplify()->apply_derivatives()->simplify();
        if (   $f->contains_operator(U_P_DERIVATIVE)
            or $f->contains_operator(U_T_DERIVATIVE) )
        {
            confess "Could not apply all derivatives in function '$sym'.";
        }

        $early{$sym}{parsed} = $f;
    }

    # Implement late replace dependencies
    @pairs = ();
    foreach my $s ( keys %late ) {
        my @sig = $late{$s}{parsed}->explicit_signature();
        foreach (@sig) {

            # Die on dependencies on early replaced functions
            confess "Dependency on outer scope function '$_' "
              . "found in function '$s'."
              if exists $early{$_};

            # Exclude the external dependencies
            next if not exists $late{$_};
            push @pairs, [ $_, $s ];
        }
    }

    @sort = _topo_sort( \@pairs );

    # Detect cycles
    if ( @sort == 1 and not defined $sort[0] ) {
        confess "Detected cycle in definitions. Cannot do topological "
          . "sort";
    }

    # actually implement symbolic dependencies of late replaces
    foreach my $sym (@sort) {
        my $f   = $late{$sym}{parsed};
        my @sig = $f->explicit_signature();
        $f->implement(
            map { ( $_ => $late{$_}{parsed}->new() ) }
              grep { exists $late{$_} } @sig
        );
        $f = $f->simplify()->apply_derivatives()->simplify();
        $late{$sym}{parsed} = $f;
    }

    # apply derivatives
    foreach my $sym ( keys %late ) {
        my $f = $late{$sym}{parsed};
        $f = $f->simplify()->apply_derivatives()->simplify();
        if (   $f->contains_operator(U_P_DERIVATIVE)
            or $f->contains_operator(U_T_DERIVATIVE) )
        {
            confess "Could not apply all derivatives in function '$sym'.";
        }

        $late{$sym}{parsed} = $f;
    }

    # implement symbolic dependencies of early replaces on late replaces
    foreach my $s ( keys %early ) {
        $early{$s}{parsed}->implement(
            map { ( $_ => $late{$_}{parsed}->new() ) }
              keys %late
        );
    }

    # external dependencies, compilation and subs
    foreach my $obj (
        ( map { [ $_ => $early{$_} ] } keys %early ),
        ( map { [ $_ => $late{$_} ] } keys %late )
      )
    {
        my ( $sym, $h ) = @$obj;

        # don't compile anything with parens in the operator.
        next if $h->{type} =~ /^\(:?=\)$/;

        # external dependencies
        my @external = $h->{parsed}->explicit_signature();

        # actual arguments
        my @args =
          map  { "arg$_" }
          sort { $a <=> $b }
          map  { /^arg(\d+)$/; $1 }
          grep { /^arg\d+$/ } @external;
        my $highest = $args[-1];
        if ( not defined $highest or $highest eq '' ) {
            $highest = 0;
        }
        else {
            $highest =~ s/^arg(\d+)$/$1/;
        }

        # number of arguments.
        my $num_args = @args==0 ? 0 : $highest+1;

        # external sub calls
        my @real_external     = sort grep { $_ !~ /^arg\d+$/ } @external;
        my $num_real_external = @real_external;

        # This is where it gets really fancy!
        # ... and This is not the Right Way To Do It! FIXME!!!
        my $final_code = "sub {\n";
        $final_code .= "my \@args = \@_;\n" if $num_real_external;

        if (@args) {
          $final_code .= <
if (\@_ < $highest+1) {
	cluck(
		"Warning: Math::SymbolicX::Inline compiled sub "
		."'${pkg}::${sym}'\nrequires $num_args argument(s) "
		."but received only " . scalar(\@_)
	);
}
if (grep {!defined} \@_[0..$highest]) {
	cluck(
		"Warning: Undefined value passed to '${pkg}::${sym}'"
	);
}
HERE
        }

        my $num_argsm1 = $num_args - 1;

        $final_code .= "local \@_[0..$num_argsm1+$num_real_external] = ("
          . join( ', ',
            @args ? ( map { "\$_[$_]" } 0..$highest ) : (),
            ( map { "${pkg}::$_(\@args)" } @real_external ) )
          . ");\n"
          if $num_real_external;

        my $vars = [ @args?(map {"arg$_"} 0..$highest):(), @real_external ];

        my ( $mcode, $trees );
        eval { ( $mcode, $trees ) = compile_to_code( $h->{parsed}, $vars ); };
        if ( $@ or not defined $mcode ) {
            confess "Could not compile Perl code for function " . "'$sym'.";
        }
        if ( defined $trees and @$trees ) {
            confess <
Could not resolve all trees in Math::Symbolic expression. That means, the
compiler encountered operators that could not be compiled to Perl code.
These include derivatives, but those should usually be applied before
compilation. Details can be found in the Math::Symbolic::Compiler man-page.
The expression that should have been compiled is:
---
$code
---
HERE
        }
        $final_code .= $mcode . "\n};\n";

        # DEBUG OUTPUT
        # warn "$sym = $final_code\n\n";

        my $anon_sub = _make_sub($final_code);
        if ($@) {
            confess <
Something went wrong compiling the code for '${pkg}::$sym'.
This was the source:
---
$code
---
And the cluttery generated code is:
---
$final_code
---
HERE
        }

        do {
            no strict;
            *{"${pkg}::${sym}"} = \&$anon_sub;
        };
    }
}

# create an anonymous sub in a clean environment.
sub _make_sub {
    return eval $_[0];
}

# Takes array of pairs as argument (1 pair: ['x', 'y'])
# returns topological sort
# returns undef in case of cycles
sub _topo_sort {
    my $pairs = shift;

    my %pairs;    # all pairs ($l, $r)
    my %npred;    # number of predecessors
    my %succ;     # list of successors

    foreach my $p (@$pairs) {
        my ( $l, $r ) = @$p;
        next if defined $pairs{$l}{$r};
        $pairs{$l}{$r}++;
        $npred{$l} += 0;
        ++$npred{$r};
        push @{ $succ{$l} }, $r;
    }

    # create a list of nodes without predecessors
    my @list = grep { !$npred{$_} } keys %npred;

    my @return;
    while (@list) {
        $_ = pop @list;
        push @return, $_;
        foreach my $child ( @{ $succ{$_} } ) {
            unshift @list, $child unless --$npred{$child};
        }
    }

    return (undef) if grep { $npred{$_} } keys %npred;
    return @return;
}

# Check the syntax of a definition
sub _check_syntax {
    my ( $definitions, $lastsymbol ) = @_;
    if ( defined $lastsymbol ) {
        my $parsed;
        eval {
            $parsed = parse_from_string( $definitions->{$lastsymbol}{code} );
        };
        if ($@) {
            confess "Parsing of Math::SymbolicX::Inline "
              . "section failed. Error:\n$@";
        }
        elsif ( not defined $parsed ) {
            my $t = $definitions->{$lastsymbol}{code};
            confess <
Parsing of Math::SymbolicX::Inline section failed due to an unknown error.
The offending expression (for symbol '$lastsymbol') is:
---
$t
---
HERE
        }
        $definitions->{$lastsymbol}{parsed} = $parsed;
    }
}

1;
__END__