Re: [SPOILER] Solution for QotW #25 (RPN calculator)

[email protected] writes:

> I thought about using eval STRING, but decided against it. Instead,
> my solution is based around a dispatch table containing both
> functions and the number of stack arguments they expect. The
> functions' return value is added to the stack only when it's
> defined, so functions can return 'undef' if they don't want that to
> happen.

I did use eval, which makes it absolutely trivial to extend the
functionality.  So I started throwing in other perl operators like
'++' and '?' and 'x'.  The downside is that I don't have the heart to
document what all of these things do, much less decide if they make
sense.  The help text you display is something I should have done.

I'm also not at all sure that I got things right, since I don't check
what I push on the stack.  My solution is prone to trying to print
'undef'.  If I had more time, I'd write a decent test suite.

This is my "what cool things are on CPAN" solution.  The most
egregious example is the Switch module.  It made things more readable
than cascading ifs, in my opinion.  But the dispatch table is fairly
straightforward too.

Regexp::Common saved me from having to debug my regex for detecting
numbers.

If STDIN is connected to a tty, I used Term::ReadLine.  Otherwise, I
used the <> operator.

I borrowed fib from the Memoize module, just so I could memoize it. :)

My original attempt at roll and rolld required a temporary stack and
seemed inelegant.  I used splice for attempt number two.  One of the
side effects is that it defines "-2 roll".  Whether or not it's useful
behavior is an entirely different question.

I added a print operator that prints the current state of the stack.
This was most helpful for testing when I piped commands into the
calculator.

Thanks for another enjoyable quiz,
Jon

#!/usr/bin/perl -w
use strict;

use Switch 'Perl6';
use Term::ReadLine;
use Carp;
use Memoize;
use Regexp::Common qw{number};

sub factorial{
    my $a = shift;
    warn "factorial not defined for numbers less than 1" if $a < 1;
    return $a if $a <= 1;
    return $a*factorial($a - 1);
}

# Compute Fibonacci numbers
sub fib {
    my $n = shift;
    return $n if $n < 2;
    fib($n-1) + fib($n-2);
}

memoize 'fib';

{
    my @stack;
    my %unary_op = map {$_ => 1}
      qw{++ -- ~ abs int cos sin exp log sqrt factorial fib};
    my %binary_op = map {$_ => 1} 
      qw{+ - / * ** % & | ^ .. x > < >= <= << >> == != <=> && ||};
    my %exit = (quit => 1, exit => 1);

    my $format = "%d: %g\n";

    sub check_stack{
        my $n = shift;
        if (@stack >= $n){
            return 1;
        } else {
            carp "Need at least $n terms for this operation";
            return 0;
        };
    }

    my $term = new Term::ReadLine 'Reverse Polish Notation Calculator';
    my $prompt = "> ";
    my $interactive = -t STDIN;

    my $OUT = $term->OUT || \*STDOUT;

    sub print_stack{
        my $i = $#stack;

        for (@stack) {
            printf $OUT $format, $i--, $_;
        }
    }

    sub process_terms{
        for (@_) {
            given ($_){
                when /^0x$RE{num}{hex}$/ {push @stack, hex $_}

                when /^0$RE{num}{oct}$/ {push @stack, oct $_}

                when /^0b$RE{num}{bin}$/ {push @stack, oct $_}

                when /^$RE{num}{dec}$/ {push @stack, $_}

                when (%unary_op) {
                    return unless check_stack(1);
                    push @stack, eval "$_ pop(\@stack)";
                    warn $@ if $@;
                }

                when (%binary_op) {
                    return unless check_stack(2);
                    my $a = pop(@stack);
                    push @stack, eval "pop(\@stack) $_ $a";
                    warn $@ if $@;
                }

                when 'drop' {pop @stack}

                when 'swap' {
                    return unless check_stack(2);
                    my $a = pop @stack;
                    my $b = pop @stack;
                    push @stack, $a, $b;
                }

                when 'clear' {@stack = ()}

                when 'dup' {
                    return unless check_stack(1);
                    my $a = pop @stack;
                    push @stack, $a, $a;
                }

                when 'atan2' {
                    return unless check_stack(2);
                    my $a = pop @stack;
                    push @stack, atan2(pop(@stack), $a);
                }

                when 'dec' {$format = "%d: %g\n"}

                when 'bin' {$format = "0b%b: 0b%b\n"}

                when 'oct' {$format = "0%o: 0%o\n"}

                when 'hex' {$format = "0x%x: 0x%X\n"}

                when 'roll' {
                    return unless check_stack(1);
                    my $n = pop @stack;
                    return unless check_stack(abs($n) + 1);

                    my $a = splice(@stack, $n, 1);
                    push @stack, $a;
                }

                when 'rolld' {
                    return unless check_stack(1);
                    my $n = pop @stack;
                    return unless check_stack(abs($n) + 1);

                    my $a = pop @stack;
                    splice(@stack, $n, 0, $a);
                }

                when '!' {
                    my $a = pop @stack;
                    push @stack, factorial($a);
                }

                when '?' {
                    my $a = pop @stack;
                    my $b = pop @stack;
                    my $c = pop @stack;
                    push @stack, $a ? $b : $c;
                }

                when (%exit) {exit};

                when 'print' {print_stack}

                default {
                    warn "Unknown term '$_'";
                    return;
                }
            }
        }
    }

    sub get_input{
        if ($interactive) {
            $_ = $term->readline($prompt);
            $term->addhistory($_) if /\S/;
            return $_;
        } else {
            <>;
        }
    }
}

while (defined ($_ = get_input)) {
    process_terms(split);
    print_stack;
}