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

On Tue, Sep 28, 2004 at 10:14:28PM -0400, Dan Sanderson wrote:
>For this quiz, we'll implement an interactive RPN calculator.

#! /usr/bin/perl -w

=pod

This solution includes all of the extra features suggested in Dan's post.

Term::Readline is ugly. I'd probably have used an unprompted stdin...

Internal functions are classified into "unary prefix" (e.g. abs, cos,
etc.), "binary infix" (e.g. +, *, etc.) and "binary prefix" (atan2).
More internal functions could of course be added trivially.

Output modes are controlled by format strings.

The messiest part of this is the error checking on the stack
manipulation functions. Too much duplicated code.

No trapping of mathematical errors.

=cut

use strict;

use Term::ReadLine;

my %dmodes=(
  dec => '%.6f',
  bin => '0b%b',
  oct => '%#o',
  hex => '%#x',
);
my $dmode='dec';

my %oplist;
map {$oplist{$_} = {ops => 1, pos => 'prefix'}} qw(~ abs int cos sin exp log sqrt);
map {$oplist{$_} = {ops => 2, pos => 'infix'}} qw(+ - * / ** % & |);
map {$oplist{$_} = {ops => 2, pos => 'prefix'}} qw(atan2);

my $term=Term::ReadLine->new;
my @stack;
while (defined($_ = $term->readline('> '))) {
  my @input=split ' ',$_;
  foreach my $op (@input) {
    if ($op =~ /^0(x[\da-f]+|b[01]+|[0-7]+)$/i) {
      push @stack,oct($op);
    } elsif ($op !~ /[^-.\d]/) {
      push @stack,$op;
    } elsif (exists $dmodes{$op}) {
      $dmode=$op;
    } elsif (exists $oplist{$op}) {
      if (scalar @stack < $oplist{$op}{ops}) {
        &err('STUND');
        last;
      } else {
        my @params=splice @stack,-$oplist{$op}{ops};
        my $expr=0;
        if ($oplist{$op}{ops}==1 && $oplist{$op}{pos} eq 'prefix') {
          $expr="$op $params[0]";
        } elsif ($oplist{$op}{ops}==2 && $oplist{$op}{pos} eq 'prefix') {
          $expr="$op($params[0],$params[1])";
        } elsif ($oplist{$op}{ops}==2 && $oplist{$op}{pos} eq 'infix') {
          $expr="$params[0] $op $params[1]";
        }
        push @stack,eval($expr);
      }
    } elsif ($op eq 'drop') {
      if (scalar @stack >= 1) {
        pop @stack;
      } else {
        &err('STUND');
        last;
      }
    } elsif ($op eq 'swap') {
      if (scalar @stack >= 2) {
        my @params=splice @stack,-2;
        push @stack,reverse @params;
      } else {
        &err('STUND');
        last;
      }
    } elsif ($op eq 'clear') {
      @stack=();
    } elsif ($op eq 'dup') {
      if (scalar @stack >= 1) {
        push @stack,$stack[-1];
      } else {
        &err('STUND');
        last;
      }
    } elsif ($op eq 'roll') {
      if (scalar @stack >= 1) {
        my $param=pop @stack;
        if (scalar @stack >= $param) {
          push @stack,splice @stack,-$param-1,1;
        } else {
          push @stack,$param;
          &err('STUND');
          last;
        }
      } else {
        &err('STUND');
        last;
      }
    } elsif ($op eq 'rolld') {
      if (scalar @stack >= 1) {
        my $param=pop @stack;
        if (scalar @stack >= $param) {
          splice @stack,-$param,0,pop @stack;
        } else {
          push @stack,$param;
          &err('STUND');
          last;
        }
      } else {
        &err('STUND');
        last;
      }
    } else {
      &err('WHAT');
    }
  }
  if (@stack) {
    my $n=scalar @stack - 1;
    foreach my $i (0..$#stack) {
      printf("%d: $dmodes{$dmode}\n",$n-$i,$stack[$i]);
    }
  }
}

sub err {
  my $code=shift;
  if ($code eq 'STUND') {
    print "Stack underflow\n";
  } elsif ($code eq 'WHAT') {
    die "Input not understood\n";
  }
}