mirror of
https://codeberg.org/scip/rpnc.git
synced 2025-12-17 04:21:01 +01:00
680 lines
15 KiB
Perl
Executable File
680 lines
15 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
|
|
use Term::ReadLine;
|
|
use Data::Dumper;
|
|
use Getopt::Long;
|
|
use Data::Dumper;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
my (@stack, @substack, @backup, @subbackup, @hist, @register);
|
|
my $term = Term::ReadLine->new('rpn calc');
|
|
my $debug = 0;
|
|
my $showstack = 1;
|
|
my $mgt = 0;
|
|
my $tty = 1;
|
|
my $VERSION = '1.10';
|
|
my $sub = 0;
|
|
my $maxstack = 10;
|
|
my $maxreg = 5;
|
|
my $silent = 1;
|
|
my $op;
|
|
|
|
# management commands, always lower case letters or words
|
|
my %commands = (
|
|
# stack commands
|
|
s => sub { $mgt = 1; dumpstack(); $mgt = 0; },
|
|
sa => sub { $mgt = 1; dumpstack(1); $mgt = 0;},
|
|
sc => sub { clearstack(); },
|
|
scx => sub { clearstack(1); dumpstack(); },
|
|
sr => sub { reversestack(); },
|
|
srt => sub { rotatestack(); },
|
|
# collector
|
|
'(' => sub { $sub = 1 },
|
|
')' => sub { stack2sub(); },
|
|
# register stuff
|
|
r => sub { last_to_reg(); dumpstack(); },
|
|
rcx => sub { clearreg(1); dumpstack(); },
|
|
rc => sub { clearreg(); },
|
|
# main
|
|
'?' => sub { help(); },
|
|
u => sub { undo(); dumpstack(); },
|
|
h => sub { showhist(); },
|
|
q => sub { exit; },
|
|
# toggles
|
|
td => sub { $debug ^= 1; },
|
|
ts => sub { $showstack ^= 1; },
|
|
# functions
|
|
fs => sub { showfuncs(); },
|
|
);
|
|
|
|
# executed 1:1, or aliased
|
|
my %alias = qw(^ ** x ^ < << > >> + + - - / / * * & & | |);
|
|
|
|
# holds user functions
|
|
my %custom;
|
|
|
|
# hand coded functions
|
|
my %func = (
|
|
'%' => sub {
|
|
# X % of Y
|
|
my ($a, $b) = getlast(2);
|
|
if (defined $b) {
|
|
return "($a / 100) * $b";
|
|
}
|
|
},
|
|
|
|
'%d' => sub {
|
|
# percentual difference
|
|
my ($a, $b) = getlast(2);
|
|
if (defined $b) {
|
|
return "(($a - $b) / $b) * 100"
|
|
}
|
|
},
|
|
|
|
'%+' => sub {
|
|
# Y + (X $ of Y)
|
|
my ($a, $b) = getlast(2);
|
|
if (defined $b) {
|
|
return "$a + (($a / 100) * $b)";
|
|
}
|
|
},
|
|
|
|
'%-' => sub {
|
|
# Y - (X $ of Y)
|
|
my ($a, $b) = getlast(2);
|
|
if (defined $b) {
|
|
return "$a - (($a / 100) * $b)";
|
|
}
|
|
},
|
|
|
|
'v' => sub {
|
|
# square root
|
|
my ($a) = getlast(1);
|
|
if (defined $a) {
|
|
return "$a ** (1 / 2)";
|
|
}
|
|
},
|
|
|
|
'm' => sub {
|
|
# median
|
|
my @values = getlast(2); # we need 2 or all in sub mode
|
|
if (scalar @values >= 2) {
|
|
my $c = $#values;
|
|
if (scalar @values % 2 == 0) {
|
|
# even
|
|
return "((sort qw(@values))[$c / 2] + (sort qw(@values))[($c / 2) + 1]) / 2";
|
|
}
|
|
else {
|
|
# uneven
|
|
return "(sort qw(@values))[$c / 2]";
|
|
}
|
|
}
|
|
else {
|
|
print "median only possible with 2 or more values\n";
|
|
undo();
|
|
return 0;
|
|
}
|
|
},
|
|
|
|
'a' => sub {
|
|
# average
|
|
my @values = getlast(2); # we need 2 or all in sub mode
|
|
if (scalar @values > 1) {
|
|
return "(" . join(' + ', @values) . ") / " . scalar @values;
|
|
}
|
|
else {
|
|
print "average only possible with 2 or more values\n";
|
|
undo();
|
|
return 0;
|
|
}
|
|
},
|
|
|
|
# converters:
|
|
# gallons to liters
|
|
'tl' => sub { return convert("* 3.785") },
|
|
# yards to meters
|
|
'tm' => sub { return convert("* 91.44") },
|
|
# miles to kilometers
|
|
'tk' => sub { return convert("* 1.609") },
|
|
# inches to cm
|
|
'tc' => sub { return convert("* 2.54") },
|
|
# to 'bytes
|
|
'tkb' => sub { return convert("/ 1000") },
|
|
'tmb' => sub { return convert("/ 1000 / 1000") },
|
|
'tgb' => sub { return convert("/ 1000 / 1000 / 1000") },
|
|
'ttb' => sub { return convert("/ 1000 / 1000 / 1000 / 1000") },
|
|
);
|
|
|
|
# math constants, always upper case letters, usable via eval{}
|
|
use constant PI => 3.141592653589793;
|
|
use constant V2 => 1.414213562373095;
|
|
use constant V3 => 1.732050807568877;
|
|
|
|
# handle command line
|
|
my ($o_h, $o_v, $o_s);
|
|
Getopt::Long::Configure( qw(no_ignore_case));
|
|
if (! GetOptions (
|
|
"version|v" => \$o_v,
|
|
"help|h" => \$o_h,
|
|
"debug|d" => \$debug,
|
|
"nostack|n" => \$o_s
|
|
) ) {
|
|
help();
|
|
exit;
|
|
}
|
|
|
|
if ($o_v) {
|
|
print "$0 version $VERSION\n";
|
|
exit;
|
|
}
|
|
|
|
if ($o_h) {
|
|
help();
|
|
exit;
|
|
}
|
|
|
|
if ($o_s) {
|
|
$showstack = 0;
|
|
}
|
|
|
|
# load config, if any
|
|
if (-s "$ENV{HOME}/.rpnc") {
|
|
if (open RC, "< $ENV{HOME}/.rpnc") {
|
|
while (<RC>) {
|
|
chomp();
|
|
next if (/^\s*#/ || /^\s*$/);
|
|
looptokenize($_);
|
|
}
|
|
close RC;
|
|
$silent = 0;
|
|
}
|
|
}
|
|
|
|
|
|
# run in commandline mode?
|
|
$op = shift;
|
|
if ($op) {
|
|
$tty = 0;
|
|
while (<STDIN>) {
|
|
chomp;
|
|
push @stack, split /\s\s*/;
|
|
}
|
|
print calc($op);
|
|
exit;
|
|
}
|
|
|
|
# else: run interactively
|
|
# main
|
|
my $OUT = $term->OUT || \*STDOUT;
|
|
while ( defined ($_ = $term->readline(prompt())) ) {
|
|
looptokenize($_);
|
|
}
|
|
|
|
|
|
1;
|
|
|
|
|
|
# converter helper
|
|
sub convert {
|
|
my $code = shift;
|
|
my ($a) = getlast(1);
|
|
if (defined $a) {
|
|
return "$a $code";
|
|
}
|
|
}
|
|
|
|
|
|
sub looptokenize {
|
|
# disassemble user input into tokens
|
|
my $tokens = shift;
|
|
|
|
if ($tokens =~ /^f\s/) {
|
|
# function definition
|
|
defun($tokens);
|
|
}
|
|
else {
|
|
foreach my $tok (split /\s+/, $tokens) {
|
|
if ($tok =~ /^-?[A-Z\.\d]+?$/) {
|
|
# number or register fetch
|
|
if ($tok =~ /^R(\d+?)/) {
|
|
# fetch number from register $1 and put it to stack
|
|
my $r = getreg($1);
|
|
if ($r) {
|
|
pushstack($r);
|
|
}
|
|
else {
|
|
print "invalid register index!\n";
|
|
next;
|
|
}
|
|
}
|
|
else {
|
|
# put number to stsack
|
|
pushstack($tok);
|
|
}
|
|
dumpstack();
|
|
}
|
|
else {
|
|
# operator or command, execute
|
|
if (exists $commands{$tok}) {
|
|
cmd($tok);
|
|
}
|
|
else {
|
|
print calc($tok);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
sub cmd {
|
|
my $c = shift;
|
|
|
|
if (exists $commands{$c}) {
|
|
my $sub = $commands{$c};
|
|
&$sub;
|
|
}
|
|
else {
|
|
print "unknown command '$c'!\n";
|
|
}
|
|
}
|
|
|
|
sub showhist {
|
|
foreach my $entry (@hist) {
|
|
printf "History: %10s = %s\n", $entry->[0], $entry->[1];
|
|
}
|
|
}
|
|
|
|
sub clearstack {
|
|
my $one = shift;
|
|
|
|
backup();
|
|
|
|
if ($sub) {
|
|
if ($one) {
|
|
pop @substack;
|
|
}
|
|
else {
|
|
@substack = ();
|
|
}
|
|
}
|
|
else {
|
|
if ($one) {
|
|
pop @stack;
|
|
}
|
|
else {
|
|
@stack = ();
|
|
}
|
|
}
|
|
}
|
|
|
|
sub reversestack {
|
|
backup();
|
|
if ($sub) {
|
|
@substack = reverse @substack;
|
|
}
|
|
else {
|
|
@stack = reverse @stack;
|
|
}
|
|
dumpstack();
|
|
}
|
|
|
|
sub rotatestack {
|
|
backup();
|
|
if ($sub) {
|
|
my $f = shift @substack;
|
|
@substack = (@substack, $f);
|
|
}
|
|
else {
|
|
my $f = shift @stack;
|
|
@stack = (@stack, $f);
|
|
}
|
|
dumpstack();
|
|
}
|
|
|
|
sub pushstack {
|
|
my $num = shift;
|
|
if ($num) {
|
|
if ($num =~ /^\./) {
|
|
$num = '0' . $num;
|
|
}
|
|
if ($sub) {
|
|
push @substack, $num;
|
|
}
|
|
else {
|
|
push @stack, $num;
|
|
}
|
|
}
|
|
}
|
|
|
|
sub dumpstack {
|
|
if (! $showstack && !$mgt) {
|
|
return;
|
|
}
|
|
|
|
my $max = shift;
|
|
my $x = ' ';
|
|
my $prefix = 'stack';
|
|
my @all;
|
|
|
|
if ($sub) {
|
|
@all = @substack;
|
|
$prefix = 'collectorstack';
|
|
}
|
|
else {
|
|
@all = @stack;
|
|
}
|
|
|
|
my $abs = scalar @all;
|
|
if (! $max && $abs > $maxstack) {
|
|
my $min = $max - ($max * 2);
|
|
@all = @all[$min .. -1];
|
|
printf "%s [..]\n", $prefix;
|
|
}
|
|
|
|
if (@register) {
|
|
my $p = 1;
|
|
foreach my $n (@register) {
|
|
printf "register R%d: %s\n", $p++, $n;
|
|
}
|
|
}
|
|
print "\n";
|
|
|
|
my $p = scalar @all;
|
|
foreach my $n (@all) {
|
|
$x = 'X' if($p == 1);
|
|
printf "%s %s %4d: %s\n", $prefix, $x, $p--, $n;
|
|
}
|
|
print "\n";
|
|
}
|
|
|
|
sub undo {
|
|
if ($sub) {
|
|
@substack = @subbackup;
|
|
}
|
|
else {
|
|
@stack = @backup;
|
|
}
|
|
}
|
|
|
|
sub backup {
|
|
if ($sub) {
|
|
@subbackup = @substack;
|
|
}
|
|
else {
|
|
@backup = @stack;
|
|
}
|
|
}
|
|
|
|
|
|
sub getlast {
|
|
# return and remove last 1, 2 or all elements of current stack
|
|
my $request = shift;
|
|
|
|
my @all = ();
|
|
|
|
backup();
|
|
|
|
if ($sub) {
|
|
# ignore request count
|
|
@all = @substack;
|
|
@substack = ();
|
|
}
|
|
else {
|
|
if (@stack) {
|
|
if (scalar @stack == 1) {
|
|
if ($request > 1) {
|
|
print "At least $request variables must be on the stack!\n";
|
|
}
|
|
else {
|
|
@all = pop @stack;
|
|
}
|
|
}
|
|
elsif (scalar @stack >= 2) {
|
|
@all = splice(@stack, -1 * $request, $request);
|
|
}
|
|
}
|
|
else {
|
|
print "Please enter one or more numbers to operate on!\n";
|
|
}
|
|
}
|
|
|
|
return @all;
|
|
}
|
|
|
|
sub getreg {
|
|
# fetch $n'th element from register
|
|
my $n = shift;
|
|
if ($n <= scalar @register) {
|
|
return $register[$n-1];
|
|
}
|
|
else {
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
sub last_to_reg {
|
|
# put last stack element to register
|
|
my $n;
|
|
if ($sub) {
|
|
if (@substack) {
|
|
$n = $substack[-1];
|
|
}
|
|
}
|
|
else {
|
|
if (@stack) {
|
|
$n = $stack[-1];
|
|
}
|
|
}
|
|
|
|
if ($n) {
|
|
if (scalar @register == $maxreg) {
|
|
shift @register;
|
|
}
|
|
push @register, $n;
|
|
}
|
|
}
|
|
|
|
sub clearreg {
|
|
my $one = shift;
|
|
|
|
if ($one) {
|
|
pop @register;
|
|
}
|
|
else {
|
|
@register = ();
|
|
}
|
|
}
|
|
|
|
sub stack2sub {
|
|
if (! $sub && scalar @substack == 0 && scalar @stack > 1) {
|
|
# not in collector mode, empty substack, move stack to substack, enter collect
|
|
backup();
|
|
@substack = @stack;
|
|
@stack = ();
|
|
$sub = 1;
|
|
}
|
|
else {
|
|
# leave collector mode
|
|
$sub = 0;
|
|
}
|
|
}
|
|
|
|
sub prompt {
|
|
my $count;
|
|
my $prompt;
|
|
|
|
if ($sub) {
|
|
$count = scalar @substack;
|
|
$prompt = '%--(';
|
|
}
|
|
else {
|
|
$count = scalar @stack;
|
|
$prompt = '%';
|
|
}
|
|
|
|
return sprintf "%3d %s ", $count, $prompt;
|
|
}
|
|
|
|
sub calc {
|
|
my $op = shift;
|
|
my $res;
|
|
my $code;
|
|
|
|
if (exists $alias{$op}) {
|
|
my @last = getlast(2);
|
|
$op = $alias{$op};
|
|
$code = join(" $op ", @last);
|
|
}
|
|
elsif (exists $func{$op}) {
|
|
my $sub = $func{$op};
|
|
$code = &$sub();
|
|
return unless $code;
|
|
}
|
|
else {
|
|
print "syntax error or unknown command ($op)!\n";
|
|
undo();
|
|
return;
|
|
}
|
|
|
|
# execute
|
|
eval "\$res = $code";
|
|
|
|
if ($@) {
|
|
# error, reset stack
|
|
print "Syntax error: $@, resetting stack\n";
|
|
undo();
|
|
}
|
|
else {
|
|
push @stack, $res;
|
|
$sub = 0;
|
|
|
|
if ($debug) {
|
|
print "DEBUG: $code = $res\n";
|
|
}
|
|
|
|
if ($tty) {
|
|
dumpstack();
|
|
push @hist, [$res, $code];
|
|
return "=> $res\n\n";
|
|
}
|
|
else {
|
|
return "$res\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
sub defun {
|
|
# define a function, use N1 .. NN as function arguments
|
|
my $code = shift;
|
|
my ($op, $name, @tokens) = split /\s\s*/, $code;
|
|
|
|
if ($name !~ /^[a-zA-Z0-9_]+$/) {
|
|
print "invalid function name (a-z0-9_)!\n";
|
|
return;
|
|
}
|
|
|
|
if (! exists $custom{$name}) {
|
|
# no need to check twice and overwriting of custom function must be legal
|
|
if (grep {$name eq $_} keys %commands) {
|
|
print "reserved function name (command)!\n";
|
|
return;
|
|
}
|
|
|
|
if (grep {$name eq $_} keys %func) {
|
|
print "reserved function name (function)!\n";
|
|
return;
|
|
}
|
|
}
|
|
|
|
$custom{$name} = "@tokens";
|
|
|
|
if ($custom{$name} =~ /^\{.*\}$/) {
|
|
# perl code
|
|
$func{$name} = sub { return eval "@tokens" };
|
|
}
|
|
else {
|
|
# rpnc code
|
|
$func{$name} = sub {
|
|
my $max = scalar @_;
|
|
my @args = reverse(@_);
|
|
|
|
# replace N1..NN with actual stack items
|
|
my @body;
|
|
foreach my $item (@tokens) {
|
|
if ($item =~ /^([A-Z])(\d+)$/) {
|
|
my $letter = $1;
|
|
my $i = $2;
|
|
if ($i <= $max) {
|
|
push @body, $args[$i-1];
|
|
}
|
|
else {
|
|
print "undefined variable ${letter}${i}!\n";
|
|
push @body, 0;
|
|
}
|
|
}
|
|
else {
|
|
push @body, $item;
|
|
}
|
|
}
|
|
|
|
# execute @body
|
|
looptokenize("@body");
|
|
};
|
|
}
|
|
|
|
print "function $name() defined.\n" unless $silent;
|
|
}
|
|
|
|
sub showfuncs {
|
|
foreach my $f (sort keys %custom) {
|
|
print "Function $f():\n $custom{$f}\n\n";
|
|
}
|
|
}
|
|
|
|
sub help {
|
|
print qq~
|
|
Reverse Polish Notation Calculator, version $VERSION.
|
|
Copyleft (L) 2019-2020 - Thomas von Dein.
|
|
Licensed under the terms of the GPL 3.0.
|
|
|
|
Commandline: rpn [-d] [<operator>]
|
|
|
|
If <operator> is provided, read numbers from STDIN,
|
|
otherwise runs interactively.
|
|
|
|
Configure: Available math operators:
|
|
td toggle debugging (-d) ( enter collect mode
|
|
ts toggle display of stack (-n) ) leave collect || stack => collect
|
|
+ add
|
|
Stack Management: - substract
|
|
s show the stack / divide
|
|
sa show the whole stack * multiply
|
|
scx clear X (last stack element) ^ expotentiate
|
|
sc clear stack % percent (%+ add %- substract)
|
|
sr reverse the stack %d percentual difference
|
|
srt rotate the stack & bitwise AND
|
|
| bitwise OR
|
|
Register Management: x bitwise XOR
|
|
r put X to register < > bitwise shift left or right
|
|
R1-9 push value of register to stack v square root
|
|
rcx clear X (last register element) m median
|
|
rc clear register a average
|
|
|
|
Converters:
|
|
tl gallons => liters tkb bytes => kb
|
|
tk miles => kilometers tmb bytes => mb
|
|
tm yards => meters tgb bytes => gb
|
|
tc inches => centimeters ttb bytes => tb
|
|
|
|
Various Commands: Functions:
|
|
u undo last operation f <name> op op... (use N1..NN for stack)
|
|
h show history of past operations fs show list of defined functions
|
|
q finish (C-d works as well) Using register: enter R + index, e.g. R1
|
|
? print help Constants: PI V2 V3
|
|
|
|
~;
|
|
}
|