pbot/modules/rpn.pl

#!/usr/bin/perl -sw
use strict;
use List::Util qw[ reduce ]; $a=$b;

our $XLATE ||= 0;

sub rpn2exp {
  local $SIG{__WARN__} = sub {
    print "Malformed arguments.\n";
    exit 1;
  };
  my %tops = map{ $_ => undef } qw[ % MOD + ADD * MULT / DIV ** POW - SUB ];
  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, "($arg1 $item $arg2)";
    }
    elsif ( my( $func ) = $item =~ m[^(.*)\(\)$] ) {
      my $args = pop @stack;
      if ($args > 4) {
        print "Too many function arguments.\n";
        exit 1;
      }
      my @args = map{ pop @stack } 1 .. $args;
      push @stack, $func . '(' . join( ', ', reverse @args ) . ')';
    }
  }
  return "@stack";
}

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 - SUB ] );

my @varargs;
sub exp2rpn {
  my( $exp, $aStack, $aBits ) = @_;
  print "Unbalanced parens: '$exp'" and exit 1 unless nestedOk $exp;
  if ( $exp =~ m/^$re_term$/ and $exp !~ m/\{\d+\}/ ) {
    push @$aStack, $exp;
  }
  else {{
      my( $left, $op, $right, $rest ) = $exp =~ m[
        ^ (?: ( $re_term )? ( $re_op ) )? ( $re_term ) ( .* ) $
      ]x or print "malformed (sub)expression '$exp'" and exit 1;
#{ no warnings; print "'$exp' => L'$left' O'$op' R'$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 if $func;
          exp2rpn( $aBits->[ $subex ], $aStack, $aBits );
          push @$aStack, pop( @varargs ), "$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 {
  my( $exp ) = @_;
  print "Unbalanced parens: '$exp'" and exit 1 unless nestedOk $exp;
  $exp =~ s[\s+][]g;
  my( $n, @bits )= ( 1, $exp );

  for ( reverse @bits ) {
    s/\( ( [^()]* )  \)/ push @bits, $1; "{${ \( $n++ ) }}"; /ex while m/[()]/;
  }

  s/([^,]+)(,?)/push @bits, $1; "{${ \( $n++ ) }}$2" /eg for reverse @bits;

  for ( reverse @bits ) {
    1 while s/( $re_term (?:\*\*)          $re_term )/ push @bits, $1; "{${ \( $n++ ) }}"; /gex;
    1 while s/( $re_term (?:[*\/%])         $re_term )/ push @bits, $1; "{${ \( $n++ ) }}"; /gex;
    1 while s/( $re_term (?:(?<![eE])[+-]) $re_term )/ push @bits, $1; "{${ \( $n++ ) }}"; /gex;
  }
  return @{ exp2rpn $bits[ 0 ], [], \@bits };
}

my $mode = shift @ARGV;
my $args = join ' ', @ARGV;

if (not $args) {
  print "Missing arguments.\n";
  exit 1;
}

if ($mode eq 'rpn') {
  my @rpn = parseExp $args;
  print join(', ', @rpn), "\n";
} else {
  my $infix = rpn2exp split /\s*,\s*/, $args;
  print "$infix\n";
}