$Math::Lapack::Expr::VERSION
=
'0.002'
;
our
$_debug_counts
;
our
@EXPORT
=
qw.$_debug_counts transpose inverse sum abs T.
;
'0+'
=> \
&eval_ast
,
'""'
=> \
&to_string
,
'**'
=> \
&pow_ast
,
'-'
=> \
&sub_ast
,
'+'
=> \
&add_ast
,
'*'
=> \
&mul_ast
,
'/'
=> \
&div_ast
,
'x'
=> \
&dot_ast
,
log
=> \
&log_ast
,
exp
=> \
&exp_ast
;
our
$AUTOLOAD
;
sub
to_string {
&eval_ast
}
sub
add_ast {
my
(
$a
,
$b
) =
@_
;
return
bless
{
type
=>
'add'
,
args
=> [
$a
,
$b
] } => __PACKAGE__;
}
sub
sub_ast {
my
(
$a
,
$b
,
$s
) =
@_
;
return
bless
{
type
=>
'sub'
,
args
=> [
$a
,
$b
,
$s
] } => __PACKAGE__;
}
sub
mul_ast {
my
(
$a
,
$b
) =
@_
;
return
bless
{
type
=>
'mul'
,
args
=> [
$a
,
$b
] } => __PACKAGE__;
}
sub
div_ast {
my
(
$a
,
$b
,
$s
) =
@_
;
return
bless
{
type
=>
'div'
,
args
=> [
$a
,
$b
,
$s
] } => __PACKAGE__;
}
sub
dot_ast {
my
(
$a
,
$b
) =
@_
;
return
bless
{
type
=>
'dot'
,
args
=> [
$a
,
$b
] } => __PACKAGE__;
}
sub
T {
&transpose
}
sub
transpose {
my
$a
=
shift
;
return
bless
{
type
=>
'transpose'
,
args
=> [
$a
] } => __PACKAGE__;
}
sub
inverse {
my
$a
=
shift
;
return
bless
{
type
=>
'inverse'
,
args
=> [
$a
] } => __PACKAGE__;
}
sub
pow_ast {
my
(
$a
,
$b
) =
@_
;
return
bless
{
type
=>
'pow'
,
args
=> [
$a
,
$b
] } => __PACKAGE__;
}
sub
sum {
my
(
$a
,
$b
) =
@_
;
return
bless
{
type
=>
'sum'
,
args
=> [
$a
,
$b
] } => __PACKAGE__;
}
sub
log_ast {
my
(
$a
) =
@_
;
return
bless
{
type
=>
'log'
,
args
=> [
$a
] } => __PACKAGE__;
}
sub
exp_ast {
my
(
$a
) =
@_
;
return
bless
{
type
=>
'exp'
,
args
=> [
$a
] } => __PACKAGE__;
}
our
%evaluators
= (
dot
=>
sub
{
my
$tree
=
shift
;
return
Math::Lapack::Matrix::eval_dot(
$tree
->{args}[0],
$tree
->{args}[1],
$tree
->{transpose_left},
$tree
->{transpose_right});
}
);
sub
eval_ast {
my
$tree
=
shift
;
$_debug_counts
->{eval_ast}++;
if
(blessed(
$tree
) &&
$tree
->isa(__PACKAGE__)) {
return
$tree
->{evaluated}
if
exists
(
$tree
->{evaluated});
if
(
$tree
->{type} ne
"matrix"
) {
my
$evaluated
=
exists
(
$tree
->{simplified}) ?
$tree
->{simplified} : _optimize_ast(
$tree
);
if
(
exists
(
$tree
->{args})) {
$tree
->{args} = [
map
{eval_ast(
$_
)} @{
$tree
->{args}} ];
}
my
$ans
;
if
(
exists
(
$evaluators
{
$tree
->{type}})) {
$ans
=
$evaluators
{
$tree
->{type}}->(
$tree
);
}
else
{
no
strict
'refs'
;
my
$package
=
exists
(
$tree
->{
package
}) ?
$tree
->{
package
} :
"Math::Lapack::Matrix"
;
$ans
=
"${package}::eval_$tree->{type}"
->(@{
$tree
->{args}});
}
$tree
->{evaluated} =
$ans
;
return
$ans
;
}
}
return
$tree
;
}
sub
_is_transpose {
my
$child
=
shift
;
return
blessed(
$child
) &&
$child
->isa(__PACKAGE__) &&
$child
->{type} eq
"transpose"
;
}
sub
_optimize_ast {
my
(
$tree
) =
@_
;
$_debug_counts
->{optimize}++;
if
(blessed(
$tree
) &&
$tree
->isa(__PACKAGE__)) {
if
(
exists
(
$tree
->{evaluated})) {
$tree
=
$tree
->{evaluated};
}
elsif
(
exists
(
$tree
->{simplified})) {
$tree
=
$tree
->{simplified};
}
elsif
(
exists
(
$tree
->{args})) {
my
@child
=
map
{ _optimize_ast(
$_
) } @{
$tree
->{args}};
if
(
$tree
->{type} eq
"dot"
) {
if
(_is_transpose(
$child
[0])) {
$tree
->{transpose_left} = 1;
$tree
->{args}[0] =
$child
[0]{args}[0];
}
if
(_is_transpose(
$child
[1])) {
$tree
->{transpose_right} = 1;
$tree
->{args}[1] =
$child
[1]{args}[0];
}
}
else
{
$tree
->{args} = [
@child
];
}
}
elsif
(blessed(
$tree
) &&
ref
(
$tree
) !~ /Matrix/) {
die
ref
(
$tree
) }
}
return
$tree
}
sub
DESTROY {
my
$self
=
shift
;
}
AUTOLOAD {
my
$method
=
$AUTOLOAD
;
our
$Depth
//= 0;
local
$Depth
=
$Depth
+ 1;
$method
=~ s/.*:://;
my
$obj
=
shift
;
if
(blessed(
$obj
)) {
my
$evaluated_tree
=
$obj
->eval_ast;
if
(
$Depth
> 100) {
my
$ref
=
ref
(
$obj
);
my
$ref_tree
=
ref
(
$evaluated_tree
);
die
<<"EOD"
*** AUTOLOAD[$method] in deep recursion.
*** OBJ is a $ref.
*** TREE is a $ref_tree.
EOD
}
if
(blessed(
$evaluated_tree
)) {
return
$evaluated_tree
->
$method
(
@_
);
}
else
{
no
strict
'refs'
;
return
&$method
(
$evaluated_tree
);
}
}
else
{
return
$obj
;
}
}
1;