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

There are all extensions except hex/oct/bin, and i think it's easy to implement 
more.


#!/usr/local/bin/perl
# RPN calculator (QOTW #25) by Filin
$VERSION=0.02;

use strict;
use warnings;

our $Verbose=0; # will print some messages if =1

# What is a number? (Numbers: 1, -1, 1.1, 0.1, -.1, 1.e10, -0.1E-100)
my $number_re = qr/^ [+-]?  (?: \d+(?:\.\d*)? | \.\d+ )  (?:[eE][+-]?\d+)? $/x;

# For error handling: 
my $not_enough_msg = "Not enough elements in stack\n";

my @stack; # the stack. ;) 

##################################### Definitions of operations:
sub perl_infix($);

my %ops = (
	# just perl binary operators:
	'*'   => perl_infix '*',  
	'+'   => perl_infix '+',
	'-'   => perl_infix '-',
	'/'   => perl_infix '/',
	'%'   => perl_infix '%',
	'**'  => perl_infix '**',
	'|'   => perl_infix '|',
	'&'   => perl_infix '&',
	'^'   => perl_infix '^',
	
	# prefix unary operators and functions, but there are no special generator
	# (TODO perl_unary ?)
	'~'   => function(sub{~shift}, 1), 
	'_'   => function(sub{-shift}, 1), # unary minus
	sqrt  => function(sub{sqrt shift  }, 1), 
	sin   => function(sub{sin  shift  }, 1), 
	cos   => function(sub{cos  shift  }, 1),
	int   => function(sub{int  shift  }, 1),
	abs   => function(sub{abs  shift  }, 1),
	exp   => function(sub{exp  shift  }, 1),
	log   => function(sub{log  shift  }, 1),

	atan2 => function(sub{atan2 shift, shift}, 2), 

	# 4 standart stack manipulation commands:
	drop  => function(sub{return      }, 1), 
	dup   => function(sub{(shift) x 2 }, 2),
	swap  => function(sub{pop(), pop()}, 2),
	clear => sub {@stack = ()}, # doesn't use generator => no arity check

	# extended stack manipulation, (and there ara extended sintax for arity checks) :
	rold  => function(sub{unshift(@_, pop   @_); @_}, sub{1+pop @stack}),
	roll  => function(sub{push   (@_, shift @_); @_}, sub{1+pop @stack}),
	ndrop => function(sub{return}, sub{pop @stack}), # drops last (top) n elements
);


# Common wrapper generator 
# function(SUB, ARITY)
# Returns a sub which checks arity and manipulates on stack
# e.g.: 
#   function(sub{1}, 100) - pops 100 elements from stack and then push one
# ARITY can be a sub:
#   function(sub{(1) x @_}, sub{scalar @stack} - fill all elements with '1'
sub function {
	my ($fun, $arity) = @_;
	return sub {
		my $arity = ref($arity) eq 'CODE' ? &$arity : $arity;
		die $not_enough_msg  if @stack<$arity;
		my @args; for (1..$arity) {unshift @args, pop @stack}
		my @res = &$fun(@args);
		print "[ @args ==> @res ]\n"  if $Verbose;
		push @stack, @res;
	}
}
# Generator for standart perl binary operators
sub perl_infix($) {
	my ($op) = @_;
	function sub { my $res = eval "$_[0] $op $_[1]";
	               die $@  if $@;
			       return $res;	}, 2;
}

##################################### The main input/calculate/output cycle and its procedures

print "RPN Calculator\n> ";
while (<>) {
	chomp;
	calculate(split);
	print_stack();
	print "> ";
}

sub calculate {
	my (@toks) = @_;
	my @oldstack=@stack;
	local $@; # there are no error yet
	for my $tok (@toks) {
		if ($tok=~m/$number_re/) {
			push @stack, $tok;
		} elsif ($ops{$tok}) {
			eval { $ops{$tok}->() };
		} else {
			$@ = "Undefined operation $tok\n";
		}
		if ($@) {
			$@=~s/at .* line \s+ \d+.*//x;
			die "Error: $@"  if $@ eq $not_enough_msg; # XXX To die or not to die?
			warn "$@";
		}
	}
	@stack=@oldstack  if $@; # rollback if error
}

sub print_stack {
	for (my $i=0; $i<@stack; $i++) {
		print ' ', $#stack-$i, ": $stack[$i]\n";
	}
}