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

There are some bug fixes and some new features. And no, there are no user functions in my calculator. Sory :)

Implemented:
  - * + - / % ** ^ | & ~
  - sin(), cos(), abs(), sqrt(), ...
  - swap drop clear dup
  - roll rold
New:
  - 0x/0/0b prefixes
  - hex/oct/bin/dec modes
  - n float - set precision mode
  - n sum   - sumarize n top elements in stack
  - N       - number of elements in stack
  - ... and others

And I realy think it's simple to add new operations in this implementation of rpn calculator.


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

use strict;
use warnings;

# What is a number?
my $number_re = qr/^ (?!0\d) [+-]? (?: \d+(?:\.\d*)? | \.\d+ )  (?:[eE][+-]?\d+)? $/x;
my $hex_int_re = qr/^ 0x [\da-z]+ $/ix;
my $oct_int_re = qr/^ 0  [\d]+    $/ix;
my $bin_int_re = qr/^ 0b [\d]+    $/ix;
my $nondec_re  = qr/^$hex_int_re|$oct_int_re|$bin_int_re$/;

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

my @stack;             # the stack. ;) 
my $pmode = "%s";      # printf mode
my @warns;             
sub pi() {4*atan2 1,1} # the pi constant

##################################### Definitions of operations:
sub perl_infix($);
sub function($$); # unfortunately '&$' is ill-bred

my %ops = (
	# just perl binary operators:
	'*'   => perl_infix '*',  
	'+'   => perl_infix '+',
	'-'   => perl_infix '-',
	'/'   => perl_infix '/',
	'%'   => perl_infix '%',
	'**'  => perl_infix '**',
	'|'   => perl_infix '|',
	'&'   => perl_infix '&',
	'^'   => perl_infix '^',
	
	# 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), 
	int   => (function sub{int  shift}, 1),
	abs   => (function sub{abs  shift}, 1),
	exp   => (function sub{exp  shift}, 1),
	log   => (function sub{log  shift}, 1),
	sin   => (function sub{sin  shift}, 1), 
	cos   => (function sub{cos  shift}, 1),

	# some trigonometry. Math::Trig may be better, but what about comlex numbers?
	atan2 => (function sub{atan2 shift, shift}, 2),
	pi    => sub{push @stack, pi},
	deg2rad => (function sub{pi*shift()/180}, 1),
	rad2deg => (function sub{180*shift()/pi}, 1),

	# 4 standart stack manipulation commands:
	drop  => (function sub{return      }, 1), 
	dup   => (function sub{(shift) x 2 }, 1),
	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{no warnings; 1 + pop @stack}),
	roll  => (function sub{push   (@_, shift @_); @_}, sub{no warnings; 1 + pop @stack}),
	ndrop => (function sub{return}, sub{pop @stack}), # drops last (top) n elements
	sum   => (function sub{                           # sumarize last n elements
		my $sum; for (@_) {$sum+=$_}; 
		return $sum
	}, sub{pop @stack}),
	N     => sub{push @stack, scalar @stack},         # number of elements in stack 

	# printf modes:                                                 
	hex   => sub{$pmode="%#x"},
	oct   => sub{$pmode="%#o"},
	bin   => sub{$pmode="%#b"},
	dec   => sub{$pmode="%s"},
	float => sub{
		my $prec=int pop @stack;
		die $not_enough_msg      if not defined $prec;
		die "Wrong precision\n"  if $prec<0; 
		$pmode="%.${prec}f"; 
	},
);

# 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 !defined($arity) or @stack<$arity;
		die "Wrong arity\n"  if $arity<=0;
		my @args; for (1..$arity) {unshift @args, pop @stack}
		my @res = &$fun(@args);
		push @stack, @res;
		return @args;
	}
}
# 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 "> ";
}
print "\n";

sub calculate {
	my (@toks) = @_;
	my @oldstack=@stack;
	local $@; # there are no error yet
	for my $tok (@toks) {
		if    ($tok=~m/$nondec_re/) { 
			no warnings qw(portable overflow); 
			local $SIG{__WARN__}=sub{$@=shift}; 
			push @stack, oct $tok; 
		} 
		elsif ($tok=~m/$number_re/) { push @stack, $tok+0; } 
		elsif ($ops{$tok})          { eval { $ops{$tok}->() }; } 
		else { $@ = "Undefined operation $tok\n"; }
		if ($@) {
			$@=~s/at .* line \s+ \d+.*//x;
			push @warns, $@;
			die "Error: $@"  if $@ eq $not_enough_msg;
		}
	}
	@stack=@oldstack  if $@; # rollback if error
}

sub print_stack {
	for (my $i=0; $i<@stack; $i++) {
		printf(' ' . ($#stack-$i) . ": $pmode\n", $stack[$i]);
	}
	while (my $w=pop @warns) {warn $w}
}