Acme::AlgebraicToRPN - convert algebraic notation to sane RPN

  $rpn = Acme::AlgebraicToRPN->new;
  @RPN = $rpn->eval($equation);

    3
    4
    add

    perldoc Acme::AlgebraicToRPN

  $al = Acme::AlgebraicToRPN->new(%opts);

  userFunc - user functions, as array reference

  $al = Acme::AlgebraicToRPN->new(userFunc =>
    [qw(box fft)]);

  @stack = $al->rpn($expr);

  negate
  add
  subtract
  multiply
  divide
  exponentiate
  sin
  cos
  tan
  cot
  asin
  acos
  atan
  atan2
  acot
  sinh
  cosh
  asinh
  acosh

  [1] If you supply a custom function, you can supply arguments
      to it. When you see your function name on the returned stack,
      the next thing on the stack is the I<number> of arguments,
      and then the arguments themselves. For example, let's say
      you registered your function 'foo' (in constructor)
      and you gave B<rpn> this equation: 4*foo(a,3)

      You'd get back this:
      4 a 3 2 foo multiply

  $stack = $al->rpn($expr);

  $ok = $al->check(\@stack, @expected);

package Acme::AlgebraicToRPN;

use warnings;
use strict;

our $VERSION = '0.02';

package Acme::AlgebraicToRPN;

use strict;
use warnings;
use Regexp::Common;
use Perl6::Attributes;
use Math::Symbolic;
use Math::SymbolicX::ParserExtensionFactory;

sub new {
    my ($class, %opts) = @_;
    my $self = \%opts;
    bless $self, $class;
    $.stack = [];
    $.parser = Math::Symbolic::Parser->new;
    $.Class = $class;
    if (defined $.userFunc) {
        my @uf = @{$.userFunc};
        my %uf;
        map { $uf{$_} = 1 } @uf;
        $.userFunc = \%uf;
        my %x;
        map {
            my $proc = $_;
            $x{$_} = sub {
                my $argumentstring = shift;
                return Math::Symbolic::Constant->new(
                    qq($proc($argumentstring))
                );
            };
        } @uf;
        Math::SymbolicX::ParserExtensionFactory->add_private_functions(
            $.parser,
            %x
        );
    }
    return $self;
}

sub rpn {
    my ($self, $algebraic) = @_;
    $algebraic =~ s/\s+//g;
    # ensure parens match
    my $open  = $algebraic =~ tr/(/(/;
    my $close = $algebraic =~ tr/)/)/;
    return unless $open == $close;
    #my $tree = Math::Symbolic->parse_from_string($algebraic);
    my $tree;
    my $rpn;

    eval q(
                $tree = $.parser->parse($algebraic);
                $rpn  = $tree->to_string('prefix');
        );

    if ($@) {
        print STDERR "$.Class - equation didn't parse; did you forget ",
            "to add a userFunc?\n";
        return undef;
    }

    $rpn =~ s/\s//g;
    ./_Eval($rpn);
        my @result = ./_Cleanup();
    # reset, ready for next equation
    $.stack = [];
    return @result;
}

sub rpn_as_string {
    my ($self, $algebraic) = @_;
    my @result = ./rpn($algebraic);
        return join(",", @result);
}

sub _Cleanup {
        my ($self) = @_;
        my @Stack;
        map {
                $_ =~ s/^,//;
        if ($_ ne '') {
            my (@c) = split(',', $_);
            if (@c) {
                s/\s//g foreach @c;
                push(@Stack, @c);
            }
            else {
                push(@Stack, $_);
            }
        }
    } @{$.stack};
    return @Stack;
}

sub _Eval {
    my ($self, $expr) = @_;
    return unless defined $expr;
    #print "Evaling $expr\n";
    if ($expr =~ /(.+?),(.+)/) {
        my $L = $1;
        my $R = $2;
        if ($L =~ /^\w+$/ && $R =~ /$RE{balanced}{-parens=>'()'}/) {
            #print "HERE $L\n";
            push(@{$.stack}, $L);
        }
    }

    if ($expr =~ /(\w+)($RE{balanced}{-parens=>'()'})(.*)/) {
        my $op = $1;
        my $p  = $2;
        my $r  = $3;
        my $core = substr($p, 1, length($p)-2);
        if (defined $.userFunc && defined $.userFunc{$op}) {
            # count # of commas in arg list
            my $na = $core =~ tr/,/,/;
            # bump by one
            $na++;
            # add # of aguments on
            $core = qq($core,$na);
        }
        ./_Eval($core);
                push(@{$.stack}, $core) 
                        unless $core =~ /$RE{balanced}{-parens=>'()'}/;
        push(@{$.stack}, $op);
        ./_Eval($r) 
                        if defined $r && $r =~ /$RE{balanced}{-parens=>'()'}/;
        push(@{$.stack}, $r) 
            if defined $r && !($r =~ /$RE{balanced}{-parens=>'()'}/);
    }
}

sub check {
    my ($self, $ref, @result) = @_;
    my @shouldbe = @$ref;
    return 0 unless @shouldbe == @result;
    my $same = 1;
    map {
        my $sb = shift(@shouldbe);
        $same = 0 unless $sb eq $_;
    } @result;
    return $same;
}

1; # End of Acme::AlgebraicToRPN