use 5.006;
no warnings 'recursion';
our $VERSION = '0.613';
BEGIN { *import = \&Math::Symbolic::Custom::Base::aggregate_import }
our $Aggregate_Export = [
qw/
is_one
is_zero
is_zero_or_one
is_sum
is_constant
is_simple_constant
is_integer
is_identical
is_identical_base
test_num_equiv
/
];
sub is_zero {
my $tree = shift;
return 0 unless $tree->term_type() == T_CONSTANT;
return 1 if $tree->{value} == 0;
return 0;
}
sub is_one {
my $tree = shift;
return 0 unless $tree->term_type() == T_CONSTANT;
return 1 if $tree->{value} == 1;
return 0;
}
sub is_zero_or_one {
my $tree = shift;
return 0 unless $tree->term_type() == T_CONSTANT;
return 1 if $tree->{value} == 1;
return "0E0" if $tree->{value} == 0;
return 0;
}
sub is_integer {
my $tree = shift;
return 0 unless $tree->term_type() == T_CONSTANT;
my $value = $tree->value();
return ( int($value) == $value );
}
sub is_simple_constant {
my $tree = shift;
my $return = 1;
$tree->descend(
in_place => 1,
before => sub {
my $tree = shift;
my $ttype = $tree->term_type();
if ( $ttype == T_CONSTANT ) {
return undef;
}
elsif ( $ttype == T_VARIABLE ) {
$return = 0;
return undef;
}
elsif ( $ttype == T_OPERATOR ) {
return ();
}
else {
croak "is_simple_constant called on " . "invalid tree type.";
}
},
);
return $return;
}
sub is_constant {
my $tree = shift;
my $return = 1;
$tree->descend(
in_place => 1,
before => sub {
my $tree = shift;
my $ttype = $tree->term_type();
if ( $ttype == T_CONSTANT ) {
return undef;
}
elsif ( $ttype == T_VARIABLE ) {
$return = 0;
return undef;
}
elsif ( $ttype == T_OPERATOR ) {
my $tree = $tree->apply_derivatives();
$ttype = $tree->term_type();
return undef if $ttype == T_CONSTANT;
( $return = 0 ), return undef
if $ttype == T_VARIABLE;
return { descend_into => [ @{ $tree->{operands} } ], };
}
else {
croak "is_constant called on " . "invalid tree type.";
}
},
);
return $return;
}
sub is_identical {
my $tree1 = shift;
my $tree2 = shift;
$tree2 = Math::Symbolic::parse_from_string($tree2)
if not ref($tree2) =~ /^Math::Symbolic/;
my $tt1 = $tree1->term_type();
my $tt2 = $tree2->term_type();
if ( $tt1 != $tt2 ) {
return 0;
}
else {
if ( $tt1 == T_VARIABLE ) {
return 0 if $tree1->name() ne $tree2->name();
my @sig1 = $tree1->signature();
my @sig2 = $tree2->signature();
return 0 if scalar(@sig1) != scalar(@sig2);
for ( my $i = 0 ; $i < @sig1 ; $i++ ) {
return 0 if $sig1[$i] ne $sig2[$i];
}
return 1;
}
elsif ( $tt1 == T_CONSTANT ) {
my $sp1 = $tree1->special();
my $sp2 = $tree2->special();
if ( defined $sp1
and defined $sp2
and $sp1 eq $sp2
and $sp1 ne ''
and $sp1 =~ /\S/ )
{
return 1;
}
return 1 if $tree1->value() == $tree2->value();
return 0;
}
elsif ( $tt1 == T_OPERATOR ) {
my $t1 = $tree1->type();
my $t2 = $tree2->type();
return 0 if $t1 != $t2;
return 0
if @{ $tree1->{operands} } != @{ $tree2->{operands} };
my $i = 0;
foreach ( @{ $tree1->{operands} } ) {
return 0
unless is_identical( $_, $tree2->{operands}[ $i++ ] );
}
return 1;
}
else {
croak "is_identical() called on invalid term type.";
}
die "Sanity check in is_identical(). Should not be reached.";
}
}
sub is_identical_base {
my $o1 = shift;
my $o2 = shift;
$o2 = Math::Symbolic::parse_from_string($o2)
if ref($o2) !~ /^Math::Symbolic/;
my $tt1 = $o1->term_type();
my $tt2 = $o2->term_type();
my $so1 =
( $tt1 == T_OPERATOR and $o1->type() == B_EXP ) ? $o1->op1() : $o1;
my $so2 =
( $tt2 == T_OPERATOR and $o2->type() == B_EXP ) ? $o2->op1() : $o2;
return Math::Symbolic::Custom::is_identical( $so1, $so2 );
}
sub is_sum {
my $tree = shift;
my $return = 1;
$tree->descend(
in_place => 1,
before => sub {
my $tree = shift;
my $ttype = $tree->term_type();
if ( $ttype == T_CONSTANT or $ttype == T_VARIABLE ) {
return undef;
}
elsif ( $ttype == T_OPERATOR ) {
my $type = $tree->type();
if ( $type == B_SUM
or $type == B_DIFFERENCE
or $type == U_MINUS )
{
return ();
}
elsif ( $type == B_PRODUCT ) {
$return = $tree->{operands}[0]->is_integer()
|| $tree->{operands}[1]->is_integer();
return undef;
}
elsif ($type == U_P_DERIVATIVE
or $type == U_T_DERIVATIVE )
{
my $tree = $tree->apply_derivatives();
$tree = $tree->simplify();
my $ttype = $tree->term_type();
return undef
if ( $ttype == T_CONSTANT
or $ttype == T_VARIABLE );
if ( $ttype == T_OPERATOR ) {
my $type = $tree->type();
if ( $type == U_P_DERIVATIVE
|| $type == U_T_DERIVATIVE )
{
$return = 0;
return undef;
}
else {
return { descend_into => [$tree] };
}
}
else {
die "apply_derivatives "
. "screwed the pooch in "
. "is_sum().";
}
}
elsif ( is_constant($tree) ) {
return undef;
}
else {
$return = 0;
return undef;
}
}
else {
croak "is_sum called on invalid tree type.";
}
die;
},
);
return $return;
}
sub test_num_equiv {
my ($t1, $t2) = (shift(), shift());
if (ref($t1) !~ /^Math::Symbolic/) {
croak("test_numeric_equivalence() must be called on Math::Symbolic tree");
}
if (ref($t2) !~ /^Math::Symbolic/ and ref($t2) ne 'CODE') {
croak("first argument to test_numeric_equivalence() must be a Math::Symbolic tree or a code reference");
}
my $is_code = ref($t2) eq 'CODE' ? 1 : 0;
my %args = @_;
my $limits = $args{limits} || {};
my $tests = $args{tests} || 20;
my $eps = $args{epsilon} || 1e-7;
my $retries = $args{retries} || 5;
my $upper = $args{upper} || 10;
my $lower = $args{lower} || -10;
my @s1 = $t1->signature();
my @s2 = $is_code ? () : $t2->signature();
my %sig = map {($_=>undef)} @s1, @s2;
my $mult = $upper-$lower;
my $retry = 0;
foreach (1..$tests) {
croak("Could not evaluate test functions with numbers -10..10")
if $retry > $retries-1;
for (keys %sig) {
my $num = rand()*$mult - $mult/2;
redo if $limits->{$_} and not $limits->{$_}->($num);
$sig{$_} = $num;
}
no warnings;
my($y1, $y2);
eval {$y1 = $t1->value(%sig);};
if ($@) {
warn "error during evaluation: $@";
$retry++;
$mult /= 2;
redo;
}
if ($is_code) {
eval {$y2 = $t2->(map {$sig{$_}} sort keys %sig)};
}
else {
eval {$y2 = $t2->value(%sig);};
}
if ($@) {
warn "error during evaluation: $@";
$retry++;
$mult /= 2;
redo;
}
if (not defined $y1) {
warn "Result of '$t1' not defined; ".Dumper(\%sig);
next if not defined $y2;
$retry++;
redo;
}
elsif (not defined $y2) {
warn "Result of '$t2' not defined; ".Dumper(\%sig);
$retry++;
redo;
}
warn("1: $y1, 2: $y2; ".Dumper(\%sig)), return 0 if $y1+$eps < $y2 or $y1-$eps > $y2;
$mult = $upper-$lower;
$retry = 0;
}
return 1;
}
1;