[SPOILER] RPN Calculator (take 3)

I still don't see a copy of my reply anywhere (in mail or in the
archives), so I'll try again.

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

It's pretty messy, but it gets the job done, and I wanted to make it
easy to extend. I considered using some sort of Readline, but didn't
want to introduce any module dependancies. So without any further
ramblings:

#!/usr/bin/perl -w

# Solution for QOTW 25 (RPN calculator) - Dan Boger <[email protected]>

use strict;

my @stack;

# define what we know how to do
my %operators = ( 
                  '+'   => \&op_add,
                  '-'   => \&op_sub,
                  '*'   => \&op_mult,
                  '/'   => \&op_div,
                  '%'   => \&op_mod,
                  '**'  => \&op_pow,
                  drop  => \&op_drop,  # pops the top element and discards it.
                  dropn => \&op_dropn, # pops the top N elements and discards them.
                  swap  => \&op_swap,  # swaps the 0th (top) and 1st elements in the stack.
                  clear => \&op_clear, # removes all values from the stack.
                  dup   => \&op_dup,   # duplicate the top element, push it onto the stack
                  dupn  => \&op_dupn,  # duplicate the top element N times
                  roll  => \&op_roll,  # moves the Nth element in the stack
                  load  => \&op_load,  # load stack from rpn.txt
                  save  => \&op_save,  # save stack to rpn.txt
                  quit  => sub { exit },
                );

# and what we can learn to do
my %macro;

# main prompt loop
print "Type 'help' for help.";
print "\n> ";
while (<>) {
  &ParseCmd(\@stack, $_);
  &PrintStack(\@stack);
  print "\n> ";
}

sub ParseCmd {
  my ($stackref, $cmd) = @_;

  # cleanup command
  chomp;
  s/^\s+//;
  s/\s+$//;
  
  # allow custom macro definitions
  if (/^def: (\w+)\s+(.*)/i) { 
    $macro{$1} = $2;
    print "Macro $1 defined.\n";
    return;
  }

  my @commands = split ' ';

  # actually process each command
  while (my $cmd = shift @commands) {
    if ($cmd =~ /^help$/i) {
      &Usage;
      last;
    }

    if (exists $macro{$cmd}) { # expand macros
      # place the expanded command in the front of the queue
      unshift @commands, split ' ', $macro{$cmd};
      next;
    }

    if ($cmd =~ /^0[bx]?([0-9a-f]+)$/i) {    #### parse hex, bin and oct numberd
      push @stack, oct($cmd) + 0; 
    } elsif (                                #### parse regular numbers
             $cmd =~ /^ 
                       [+-]?  # allow negative (and positive for consistancy) numbers
                       (?:
                         [\d_]+(?:\.\d+)? # plain integers (5) or real number (5.2)
                           |
                         \.\d+            # allow also naked decimals (.5)
                       )
                       (?:                # possible exponent
                         [eE]
                         [+-]?            # positive or negative
                         \d+    
                       )?$/x) {
      push @stack, $cmd + 0;   # force perl to "numerify" it
    } elsif (exists $operators{$cmd}) {      #### see if we know this operator
      # we do, so just call the coderef
      unless (defined $operators{$cmd}->(\@stack)) {
        print "Failed in '$cmd'.\n";
        last;
      }
    } else {                                 #### fallback, complain
      print "Unknown command: '$cmd'.\n";
      &Usage;
      last;
    }
  }
}

sub PrintStack {
  my $stackref = shift;

  if (@$stackref) {
    for (reverse 0..$#$stackref) {
      print "$_: $stackref->[$#$stackref - $_]\n";
    }
  } else {
    print "Empty stack.\n";
  }
}

sub Usage {
  print "Known operators: ", join ", ", "def:", sort keys %operators;
  print "\n";
  if (keys %macro) {
    print "Defined macros:\n";
    foreach (keys %macro) {
      print "  $_: $macro{$_}\n";
    }
  }
}

sub op {
  # main workhorse of the code.  Take the code in our special syntax, load, and replace
  # the vars we need, then 'eval' it.
  my ($stackref, $code) = @_;

  my $has_res = 0; # flag to signify if we're returning and pushing into the stack the result
                   # or if we just return the vars pulled
  my @res;
  my %vars;

  # get the current value of the vars from the stack
  while ($code =~ /:(\d+)/) {
    my $pos = $1;
    my $index = $#$stackref - $pos;
    if ($index < 0) {  # make sure the stack has enough data - otherwise, complain
      print "ERR: Stack not deep enough.  Need at least ", $pos + 1, " elements.\n";
      return undef;
    }

    $code =~ s/:$pos(k)?\b/\$vars{$index}->[0]/g;
    $vars{$index} = [$stackref->[$index], $1 || ""]; # store the value, and any flags
  }

  if ($code =~ s/:r/\@res/g) {  # we're required to return (and push) the result
    $has_res = 1;
  }

  # run the submitted code
  eval $code;

  if ($@) {
    # something bad happend
    print "ERR: $@\n";
    return undef;
  }

  # the eval succeeded, let's remove the vars
  foreach (sort {$b <=> $a} keys %vars) {
    next if $vars{$_}->[1] eq 'k';  # the 'k' flag means keep it - don't remove it from 
                                    # the stack
    #print "Removing $_\n";
    splice (@$stackref, $_, 1, ());
  }

  if ($has_res) {  # push and return the results
    @res = reverse @res;
    push @$stackref, @res;
    return @res;
  } else {         # just return the vars we pulled
    return map {$_->[0]} @vars{sort {$a <=> $b} keys %vars};
  }
}

# operation definitions.  most cases can be dealt with with a simple equasion
sub op_add {
  my $stackref = shift;

  return &op($stackref, ':r = :0 + :1');
}

sub op_sub {
  my $stackref = shift;

  return &op($stackref, ':r = :1 - :0');
}

sub op_mult {
  my $stackref = shift;

  return &op($stackref, ':r = :0 * :1');
}


sub op_div {
  my $stackref = shift;

  return &op($stackref, ':r = :1 / :0');
}

sub op_mod {
  my $stackref = shift;
  
  return &op($stackref, ':r = :1 % :0');
}

sub op_pow {
  my $stackref = shift;
  
  return &op($stackref, ':r = :1 ** :0');
}

sub op_drop {
  my $stackref = shift;

  return &op($stackref, ':0');
}

sub op_dropn {
  my $stackref = shift;

  # get the argument for dropn
  my ($n) = &op($stackref, ":0");

  if ($n >= 0) {
    &op($stackref, ':0') for 1..$n;
  } else {
    print "ERR: $n is not a positive number.\n";
  }
}

sub op_swap {
  my $stackref = shift;

  return &op($stackref, ':r = (:1, :0)');
}

sub op_clear {
  my $stackref = shift;

  @$stackref = ();
  return 1;
}

sub op_dup {
  my $stackref = shift;

  return &op($stackref, ':r = :0k');
}

sub op_dupn {
  my $stackref = shift;

  my $n;
  ($n) = &op($stackref, ":0");
  if ($n >= 0) {
    &op($stackref, ':r = :0k') for 1..$n;
  } else {
    print "ERR: $n is not a positive number.\n";
  }
}

sub op_roll {
  my $stackref = shift;

  my $n;
  ($n) = &op($stackref, ":0");
  if (defined $n) {
    return &op($stackref, ":r = :$n");
  } else {
    return undef;
  }
}

sub op_load {
  my $stackref = shift;

  unless (open(STACK, "<rpn.txt")) {
    print "Failed to read: $!";
    return undef;
  }

  &op_clear($stackref);
  while (<STACK>) {
    &ParseCmd($stackref, $_);
  }

  print "Loaded stack from rpn.txt.\n";
}

sub op_save {
  my $stackref = shift;

  unless (open(STACK, ">rpn.txt")) {
    print "Failed to write: $!";
    return undef;
  }

  print STACK join "\n", @$stackref;
  print STACK "\n";
  foreach (keys %macro) {
    print STACK "def: $_ $macro{$_}\n";
  }
  close STACK;

  print "Saved to rpn.txt.\n";
}


__END__

-- 
Dan Boger
[email protected]