view release on metacpan or  search on metacpan

lib/Acme/AlgebraicToRPN.pm  view on Meta::CPAN

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

Plus any that you may add in constructor [1].

undef is returned if the parens don't balance. That's all the
checking we do.

  [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

=cut

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;
}

=head2 B<rpn_as_string>

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

Same as B<rpn>, but returns as a comma-separated list. Split on
commas, and you have your stack to be processed.

=cut

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