http://www.perlmonks.org?node_id=423906


in reply to Re^4: Generic RPN Translator available?
in thread Generic RPN Translator available?

An updated version of the above with all the bugs I am aware of fixed.

It attempts to verify the results by reversing them. The caveat being that as far as I can see, there is no easy way to put back parenthesis around subexpressions? Hence it will flag expressions that contain parenthesised subexpression as not being correctly.

In every case I have tested, the expression has been reversed correctly except for the replacement of the parens.

It's not a perfect test method, but the best I have come up with. Anyone have a better one?

Results

P:\test>423305 1+2+3 1, 2, +, 3, + 1+2+3 a+b+c a, b, +, c, + a+b+c abc+def+Efg_hij abc, def, +, Efg_hij, + abc+def+Efg_hij 2.0+1e-2/0.01E-21 2.0, 1e-2, +, 0.01E-21, / 2.0+1e-2/0.01E-21 max(a,b,c,d)*atan(pi*4,-1) a, b, c, d, 4, max(), pi, 4, *, -1, 2, atan(), * max(a,b,c,d)*atan(pi*4,-1) sin(cos(x)-tan(y))+f(g(z)) x, 1, cos(), y, 1, tan(), -, 1, sin(), z, 1, g(), 1, f(), + sin(cos(x)-tan(y))+f(g(z)) 2*(somevar+other)+max(this,that) 2, somevar, other, +, *, this, that, 2, max(), + 2*somevar+other+max(this,that) ** Reversal didn't match original ** A+(B*C-D)/E A, B, C, *, D, -, +, E, / A+B*C-D/E ** Reversal didn't match original ** (a*(b)-c^(3.4e-2)) a, b, *, c, -, 3.4e-2, ^ a*b-c^3.4e-2 ** Reversal didn't match original ** 5^((-2e-3+x)*sin(p+4.0)/fred) 5, -2e-3, x, +, p, 4.0, +, 1, sin(), *, fred, /, ^ 5^-2e-3+x*sin(p+4.0)/fred ** Reversal didn't match original ** sin(a)+sin(ab)+sin(a,b) a, 1, sin(), ab, 1, sin(), +, a, b, 2, sin(), + sin(a)+sin(ab)+sin(a,b) Func_1(1,Func_2(Func3(1*2*3)*aFunc(3))+FuNc(4,5,6),-2,e,-10,-2e-10)+1 1, 1, 2, *, 3, *, 1, Func3(), 3, 1, aFunc(), *, 1, Func_2(), 4, 5, 6, +3, FuNc(), +, -2, e, -10, -2e-10, 6, Func_1(), 1, + Func_1(1,Func_2(Func3(1*2*3)*aFunc(3))+FuNc(4,5,6),-2,e,-10,-2e-10)+1

Code:

#! perl -slw use strict; use List::Util qw[ reduce ]; $a=$b; our $XLATE ||= 0; sub nestedOk{ index( $_[ 0 ], '(' ) <= index( $_[ 0 ], ')' ) and 0 == reduce{ $a + ( $b eq '(' ) - ( $b eq ')' ) } 0, split'[^()]*', $_[ 0 ] } my $re_var = qr[ [a-zA-Z]\w* ]x; my $re_subex = qr[ \{\d+\} ]x; my $re_func = qr[ $re_var $re_subex ]x; my $re_num = qr[ -? \d+ (?: \. \d+ )? (?: [Ee] [+-]? \d+ )? ]x; my $re_term = qr[ $re_num | $re_func | $re_subex | $re_var ]x; my $re_op = qr[[,%+*/^-]]; my %ops = ( qw[ % MOD + ADD * MULT / DIV ^ POW - SUBT ] ); my @varargs; sub exp2rpn { my( $exp, $aStack, $aBits ) = @_; die "Unbalanced parens: '$exp'" unless nestedOk $exp; { my( $left, $op, $right, $rest ) = $exp =~ m[ ^ (?: ( $re_term )? ( $re_op ) )? ( $re_term ) ( .* ) $ ]x or die "malformed (sub)expression '$exp'"; #{ no warnings; print "'$exp' => '$left'$op'$right'$rest'"; } $varargs[ -1 ]++ if $op and $op eq ',' and @varargs; for ( $left, $right ) { next unless $_; if( my( $func, $subex ) = m[^ ( $re_var )? \{ ( \d+ ) \} $ +]x ) { push @varargs, 1; exp2rpn( $aBits->[ $subex ], $aStack, $aBits ); push @$aStack, pop @varargs if $func; push @$aStack, "$func()" if $func } else{ push( @$aStack, $_ ); } } push @$aStack, $XLATE ? $ops{ $op } : $op if $op and $op ne ','; $exp = $rest, redo if $rest; } return $aStack; } sub parseExp { local $_ = $_[ 0 ]; s[\s+][]g; return warn "Unbalanced parens: '$_'" unless nestedOk $_; my( $bit, @bits ) = 0; s[\( ( [^()]+ ) \)]{ push @bits, $1; "{${ \( $bit++ ) }}"; }ex while m[[()]]; return @{ exp2rpn $_, [], \@bits }; } sub rpn2exp { my %tops = map{ $_ => undef } qw[ % MOD + ADD * MULT / DIV ^ POW - + SUBT ]; my @stack; my $expr; while( @_ ) { my $item = shift @_; push( @stack, $item ), next unless exists $tops{ $item } or $item =~ m[\(\)$]; if( exists $tops{ $item } ) { my $arg2 = pop @stack; my $arg1 = pop @stack; push @stack, join '', $arg1, $item, $arg2; } elsif( my( $func ) = $item =~ m[^(.*)\(\)$] ) { my $args = pop @stack; my @args = map{ pop @stack } 1 .. $args; push @stack, $func . '(' . join( ',', reverse @args ) . ') +'; } } return "@stack"; } while( chomp( my $exp = <DATA> || '' ) ) { my @rpn = parseExp $exp; $exp =~ s[\s+][]g; my $reversed = rpn2exp @rpn; printf "%s\n%s\n%s\n\n", $exp, join(', ', @rpn), $reversed ; warn "\t** Reversal didn't match original **\n\n" unless $exp eq $ +reversed; } __DATA__ 1+2+3 a+b+c abc+def+Efg_hij 2.0+1e-2/0.01E-21 max( a, b, c, d ) * atan( pi*4, -1 ) sin( cos( x ) - tan( y ) ) + f( g( z ) ) 2*(somevar+other) + max(this, that) A+(B*C-D)/E (a*(b)-c^(3.4e-2)) 5^((-2e-3+x)*sin(p+4.0)/fred) sin(a) + sin(ab) + sin( a, b ) Func_1( 1, Func_2( Func3( 1* 2 * 3) * aFunc( 3 ) )+FuNc(4,5,6), -2,e, +-10, -2e-10 ) +1

Examine what is said, not who speaks.
Silence betokens consent.
Love the truth but pardon error.

Replies are listed 'Best First'.
Re^6: Generic RPN Translator available?
by saintmike (Vicar) on Jan 22, 2005 at 04:37 UTC
    Hmm, looks like precedence of * and / over + and - isn't handled correctly:
    a+b*c/2
    should yield
    a,b,c,*,2,/,+
    but results in
    a,b,+,c,*,2,/
    instead. I guess we really need grammar, especially if you into consideration that an operator like '**' or '^' needs even higher precedence.

      Update: It took all of about 25 minutes to implement 4 levels of presedence:

      ** | */% | +- | ,func()

      P:\test>423305 1+2*3 2, 3, *, 1, + ((2*3)+1) 1+2*3**4 3, 4, **, 2, *, 1, + (((3**4)*2)+1)

      It's not complete, but I thought you were looking for a starting point--not finished code.

      Have fun!


      Examine what is said, not who speaks.
      Silence betokens consent.
      Love the truth but pardon error.

        Here's a somewhat cleaned up and somewhat better tested version that handles infinite nesting, four levels of presecence etc.

        It also has a rpn2exp() routine that reverses the process that adds full parenthesis to show the effect of the precedence.

        Tests

        P:\test>423305 Func_1(1,Func_2(Func3(1+2*3)*aFunc(3))+FuNc(4,5,6),-2,e,-10,2e10)+1 1, 1, 2, 3, *, +, 1, Func3(), 3, 1, aFunc(), *, 1, Func_2(), 4, 5, 6, +3, FuNc(), +, -2, e, -10, 2e10, 6, Func_1(), 1, + ( Func_1( 1, ( Func_2( ( Func3( ( 1 + ( 2 * 3 ) ) ) * aFunc( 3 ) ) ) + + FuNc( 4, 5, 6 ) ), -2, e, -10, 2e10 ) + 1 ) func(1,2+3*4/5**6,7/8) 1, 2, 3, 4, *, 5, 6, **, /, +, 7, 8, /, 3, func() func( 1, ( 2 + ( ( 3 * 4 ) / ( 5 ** 6 ) ) ), ( 7 / 8 ) ) a+b*c/2 a, b, c, *, 2, /, + ( a + ( ( b * c ) / 2 ) ) abc+def+Efg_hij abc, def, +, Efg_hij, + ( ( abc + def ) + Efg_hij ) 2.0+1e-2/0.01E-21 2.0, 1e-2, 0.01E-21, /, + ( 2.0 + ( 1e-2 / 0.01E-21 ) ) max(a,b,c,d)*atan(pi*4,-1) a, b, c, d, 4, max(), pi, 4, *, -1, 2, atan(), * ( max( a, b, c, d ) * atan( ( pi * 4 ), -1 ) ) sin(cos(x)-tan(y))+f(g(z)) x, 1, cos(), y, 1, tan(), -, 1, sin(), z, 1, g(), 1, f(), + ( sin( ( cos( x ) - tan( y ) ) ) + f( g( z ) ) ) 2*(somevar+other)+max(this,that) 2, somevar, other, +, *, this, that, 2, max(), + ( ( 2 * ( somevar + other ) ) + max( this, that ) ) A+(B*C-D)/E A, B, C, *, D, -, E, /, + ( A + ( ( ( B * C ) - D ) / E ) ) (a*(b)-c**(3.4e-2)) a, b, *, c, 3.4e-2, **, - ( ( a * b ) - ( c ** 3.4e-2 ) ) 5**((-2e-3+x)*sin(p+4.0)/fred) 5, -2e-3, x, +, p, 4.0, +, 1, sin(), *, fred, /, ** ( 5 ** ( ( ( -2e-3 + x ) * sin( ( p + 4.0 ) ) ) / fred ) ) sin(a)+sin(ab)+sin(a,b) a, 1, sin(), ab, 1, sin(), +, a, b, 2, sin(), + ( ( sin( a ) + sin( ab ) ) + sin( a, b ) ) Func_2(Func3(1*2*3)*aFunc(3))+FuNc(4,5,6) 1, 2, *, 3, *, 1, Func3(), 3, 1, aFunc(), *, 1, Func_2(), 4, 5, 6, 3, +FuNc(), + ( Func_2( ( Func3( ( ( 1 * 2 ) * 3 ) ) * aFunc( 3 ) ) ) + FuNc( 4, 5, +6 ) ) func(1,2+3*4/5**6,7/8) 1, 2, 3, 4, *, 5, 6, **, /, +, 7, 8, /, 3, func() func( 1, ( 2 + ( ( 3 * 4 ) / ( 5 ** 6 ) ) ), ( 7 / 8 ) ) Func_1(1,xx,-2,e,-10,-2e-10)+1 1, xx, -2, e, -10, -2e-10, 6, Func_1(), 1, + ( Func_1( 1, xx, -2, e, -10, -2e-10 ) + 1 )

        Examine what is said, not who speaks.
        Silence betokens consent.
        Love the truth but pardon error.