use strict; 
use warnings; 
use Data::Dumper; 

my %ops = ( 
       '+' => sub { $_[0] + $_[1] }, 
       '-' => sub { $_[0] - $_[1] }, 
       '*' => sub { $_[0] * $_[1] }, 
       '/' => sub { $_[1] or die "Division by zero.\n"; $_[0] / $_[1] 
+}, 
       '^' => sub { $_[0] ** $_[1] }, 
      ); 

my @ops      = ( '^', '*', '/', '+', '-' ); 
my @parens   = ( '(', ')' ); 
my @operands = ( '\d+', '\w+' ); 

my $tokre = join "|", @operands, map { "\Q$_\E" } @ops, @parens ; 

sub reduce_parens { 
  my $tokens = shift; 
  my @temp; 
  while( @$tokens ) { 
    my $tok = shift @$tokens; 
    if( $tok eq '(' ) { 
      push @temp, [ reduce_parens( $tokens ) ]; 
      next; 
    } 
    return @temp if $tok eq ')'; 
    push @temp, $tok; 
  } 
  return @temp; 
} 

sub reduce_ops { 
  my( $tokens, $op ) = @_; 
  my @temp; 
  while( @$tokens ) { 
    my $tok = shift @$tokens; 
    if( ref( $tok ) ) { 
      push @temp, [ reduce_ops( $tok, $op ) ]; 
      next; 
    } 
    if ( $tok eq $op ) { 
      my $left  = [ @temp ]; 
      my $right = [ reduce_ops( $tokens, $op) ]; 
      return ( 1==@$left?$$left[0]:$left, $op, 1==@$right?$$right[0]:$
+right ); 
    } 
    push @temp, $tok; 
  } 
  return @temp; 
} 

sub distributivity { 
  my $tokens = shift; 
  if( ref($tokens) && $$tokens[1] =~ /^(\*|\/)$/ ) { 
    if( ref( $$tokens[0] ) && $$tokens[0]->[1] =~ /^(\-|\+)$/ ) { 
      my $mult    = $$tokens[1]; 
      $$tokens[1] = $$tokens[0]->[1]; 
      my $left    = $$tokens[0]->[0]; 
      my $right   = $$tokens[0]->[2]; 
      $$tokens[0] = [ $left,  $mult, $$tokens[2] ]; 
      $$tokens[2] = [ $right, $mult, $$tokens[2] ]; 
    } elsif( ref( $$tokens[2] ) && $$tokens[2]->[1] =~ /^(\-|\+)$/ ) {
+ 
      my $mult    = $$tokens[1]; 
      $$tokens[1] = $$tokens[2]->[1]; 
      my $left    = $$tokens[2]->[0]; 
      my $right   = $$tokens[2]->[2]; 
      $$tokens[2] = [ $$tokens[0], $mult, $right ]; 
      $$tokens[0] = [ $$tokens[0], $mult, $left ]; 
    } 
  } 
  ref( $$tokens[$_] ) and distributivity( $$tokens[$_] ) for 0,2; 
} 

sub reduce_literals { 
  my $tokens = shift; 
  ref $$tokens[$_] and $$tokens[$_] = reduce_literals( $$tokens[$_] ) 
+for 0, 2; 
  if( !ref($$tokens[0]) && !ref($$tokens[1]) && 
      ($$tokens[0] !~ /\D/) && ($$tokens[2] !~ /\D/) ) { 
    return $ops{$$tokens[1]}->( $$tokens[0], $$tokens[2] ); 
  } 
  return $tokens; 
} 

sub parse_equation { 
  my $eq = shift; 
  my $tokens = [ $eq =~ /($tokre)/g ]; 
  @$tokens = reduce_parens $tokens; 
  @$tokens = reduce_ops $tokens, $_ for reverse @ops; 
  distributivity $tokens; 
  $tokens = reduce_literals $tokens; 
  #                print Dumper \@tokens; 
  return $tokens; 
} 

sub prepare { 
  my( $subtree, $level, $col, $graph ) = @_; 
  my $lcol = 0; 
  if( ref($subtree) ) { 
    $lcol = prepare( $subtree->[0], $level+2, $col, $graph );    # par
+se left side of tree, keep top position 
    $lcol and $graph->[$level]->[$_] = '_' for $lcol..$$col-1;   # dra
+w horizontal line 
    $graph->[$level]->[$$col++] = '/'; 
    $graph->[$level-1]->[$$col++] = $subtree->[1]; 
    $lcol = $$col;                                               # new
+ root of the tree 
    $graph->[$level]->[$$col++] = '\\'; 
    my $rcol = prepare( $subtree->[2], $level+2, $col, $graph ); # par
+se right side of the tree, keep its top position 
    $rcol and $graph->[$level]->[$_] = '_' for $lcol+1..$rcol-2; # dra
+w horizontal line 
  } else { 
    $graph->[$level++ -1]->[$$col] = $_ for split //, $subtree;       
+           # leaf 
    $$col++; 
  } 
  return $lcol;                                                  # ret
+urn column of root 
} 

sub printTree { 
  my $root = shift; 
  my @graph; 
  my $col = 1; 
  prepare( $root, 1, \$col, \@graph ); 
  for my $row ( @graph ) { 
    print $_ // ' ' for @$row; 
    print "\n"; 
  } 
} 

for( <DATA> ){ 
  print "\nEquation: $_\n"; 
  printTree parse_equation( $_ ); 
} 

__DATA__ 
1+x^2*((1+y)*3)+5*(4+(4+3)) 
((4+c)*y)^(4+2)/5-s^200 
2+2
[download]