[SPOILER] Solution to Perl Quiz of the Week #25 (RPN calculator)

#!/usr/bin/perl
# A simple rpn calculator as a solution for Perl QotW #25


use warnings;
use strict;
use Term::ReadLine;
use Math::Trig qw(tan asin acos pi);

# Binary operators that are implemented by perl
use constant BINARY_OPS => qw(+ - / * % ** & |);
# Unary operators that are implemented by perl
use constant UNARY_OPS => qw(abs int exp log sqrt ~ cos sin tan asin acos);
# Functions that need angle conversion, either for input or output
use constant TAKES_ANGLE => qw(cos sin tan);
use constant RETURNS_ANGLE => qw(asin acos atan);
# Perl constants accessible to the calculator
use constant CONSTANTS => qw(pi);

# Setup ReadLine support
my $term = new Term::ReadLine "Simple RPN Calculator";
my $OUT = $term->OUT || \*STDOUT;


# These will hold subroutines for displaying data and converting angles
my ($disp, $to_rads, $from_rads);
# The rpn stack
my @stack;

# Dispatch table for all the user defined calculator functions
my %dispatch = (drop => \&do_drop,
		swap => \&do_swap,
		clear => \&do_clear,
		dup => \&do_dup,
		roll => \&do_roll,
		rolld => \&do_rolld,
		'q' => sub {exit},
		hex => sub {$disp=sub {return sprintf("0x%x",$_[0]);}},
		dec => sub {$disp=sub {return $_[0];}},
		bin => sub {$disp=sub {my $str = unpack("B32", pack("N",$_[0]));
				       $str =~ s/^0+(?=\d)//;
				       return "0b$str"}},
		oct => sub {$disp=sub {return sprintf("0%o",$_[0]);}},

		rad => sub {$to_rads = sub {return $_[0]};
			    $from_rads = sub {return $_[0]}},
		deg => sub {$to_rads = sub {return 2 * pi * $_[0] / 360};
			    $from_rads = sub {return 360 * $_[0]/ (2 * pi)}},

		atan2 => \&do_atan2,
		'!' => \&do_factorial

);


# Dispatch table for input conversion
my %conversions=('0x' => sub {return hex($_[0])},
		 '0b' => sub {return unpack("N", pack("B32", substr("0" x 32 . shift, -32)))},
		 '0' => sub {return oct($_[0])});

# Default to degrees and decimal output
$dispatch{deg}->();
$dispatch{dec}->();

# This is the main loop
while ( defined ( $_ = $term->readline('> '))) {
  foreach my $field (split) {
    if ($field =~ /^(\-)?(0)([0-7]+)$/ || 
	$field =~ /^(\-)?(0x)?([0-9a-eA-E]+)$/ ||
	$field =~ /^(\-)?(0b)?([01]+)$/ ||
	$field =~ /^(\-)?[\d\.Ee]$/) {
      if (defined $2) {
	$field=$conversions{$2}->($3);
	$field *= -1 if ($1);
      }
      unshift @stack,$field;
    } else {
      parseOperator($field,\@stack);
    }


  }
  displayStack(@stack);
}


# Print the stack contents
sub displayStack {
  my @stack = @_;
  for (my $i = $#stack;$i>=0;$i--) {
    print $OUT "$i: ". $disp->($stack[$i]) ."\n";
  }
}



sub parseOperator {
  my $op=shift;
  my $r_stack=shift;

  if (defined $dispatch{$op}) {
    $dispatch{$op}->($r_stack);
  } else {
    if (grep $_ eq $op, BINARY_OPS) {
      my $a = shift @$r_stack;
      my $b = shift @$r_stack;
      my $res;
      eval "\$res = \$b $op \$a";
      $res=$from_rads->($res) if (grep $_ eq $op, RETURNS_ANGLE);
      unshift @$r_stack,$res;

    } elsif (grep $_ eq $op, UNARY_OPS) {
      my $a = shift @$r_stack;
      $a=$to_rads->($a) if (grep $_ eq $op, TAKES_ANGLE);
      my $res;
      eval "\$res = $op \$a";
      $res=$from_rads->($res) if (grep $_ eq $op, RETURNS_ANGLE);

      unshift @$r_stack,$res;
    } elsif (grep $_ eq $op, CONSTANTS) {
      my $res;
      eval ("\$res = $op");
      unshift @$r_stack,$res;
    } else {
      print $OUT "Operator $op not supported\n";
    }
    
  }
}

sub do_atan2 {
  my $r_stack=shift;

  my $a = shift @$r_stack;
  my $b = shift @$r_stack;
  my $res=atan2($a,$b);
  unshift @$r_stack,$from_rads->($res);
  
}

sub do_drop {
  my $r_stack=shift;

  shift @$r_stack;
}

sub do_swap {
  my $r_stack=shift;

  my $a=shift @$r_stack;
  my $b=shift @$r_stack;
  unshift @$r_stack,$a;
  unshift @$r_stack,$b;
}


sub do_clear {
  my $r_stack=shift;
  @$r_stack = ();
}


sub do_dup {
  my $r_stack=shift;

  my $a=shift @$r_stack;
  unshift @$r_stack,$a;
  unshift @$r_stack,$a;
}


sub do_roll {
  my $r_stack=shift;

  my $a=shift @$r_stack;
  my $roll=$$r_stack[$a];
  for (my $i=$a;$i>0;$i--) {
    $$r_stack[$i]=$$r_stack[$i-1];
  }
  $$r_stack[0]=$roll;
}

sub do_rolld {
  my $r_stack=shift;

  my $a=shift @$r_stack;
  my $roll=$$r_stack[0];

  for (my $i=0;$i<$a;$i++) {
    $$r_stack[$i]=$$r_stack[$i+1];
  }
  $$r_stack[$a]=$roll;
}


sub do_factorial {
  my $r_stack=shift;

  my $a=shift @$r_stack;
  if ($a<0 || $a != int($a)) {
    print $OUT "Can't factorial $a\n";
    unshift @$r_stack,$a;
  }  elsif ($a == 0) {
    unshift @$r_stack,1;
  } else {
    my $res=1;
    for (my $i=1;$i<=$a;$i++) {
      $res *= $i;
    }
    unshift @$r_stack,$res;
  }
 

}