mirror of
https://codeberg.org/scip/rpnc.git
synced 2025-12-17 12:31:04 +01:00
deprecate perl version, make go version the new one (2.0.0)
This commit is contained in:
679
archived/rpnc
Executable file
679
archived/rpnc
Executable file
@@ -0,0 +1,679 @@
|
||||
#!/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
|
||||
|
||||
~;
|
||||
}
|
||||
Reference in New Issue
Block a user