scip/rpnc
1
0
Fork 0
mirror of https://codeberg.org/scip/rpnc.git synced 2025-12-17 20:41:01 +01:00
Code Issues Packages Projects Releases Wiki Activity

fixed stack pops

Browse Source
This commit is contained in:
Thomas von Dein
2020-04-16 19:23:56 +02:00
parent 72eecdf6e8
commit 334297f645
1 changed files with 134 additions and 101 deletions
Download Patch File Download Diff File Expand all files Collapse all files

235
rpnc
View File

@@ -12,8 +12,9 @@ my (@stack, @substack, @backup, @subbackup, @hist, @register);
my $term = Term::ReadLine->new('rpn calc'); my $term = Term::ReadLine->new('rpn calc');
my $debug = 0; my $debug = 0;
my $showstack = 1; my $showstack = 1;
my $mgt = 0;
my $tty = 1; my $tty = 1;
my $VERSION = '1.08'; my $VERSION = '1.09';
my $sub = 0; my $sub = 0;
my $maxstack = 10; my $maxstack = 10;
my $maxreg = 5; my $maxreg = 5;
@@ -61,8 +62,8 @@ if ($op) {
# management commands, always lower case letters or words # management commands, always lower case letters or words
my %commands = ( my %commands = (
# stack commands # stack commands
s => sub { dumpstack(); }, s => sub { $mgt = 1; dumpstack(); $mgt = 0; },
sa => sub { dumpstack(1); }, sa => sub { $mgt = 1; dumpstack(1); $mgt = 0;},
sc => sub { clearstack(); }, sc => sub { clearstack(); },
scx => sub { clearstack(1); dumpstack(); }, scx => sub { clearstack(1); dumpstack(); },
sr => sub { reversestack(); }, sr => sub { reversestack(); },
@@ -92,112 +93,128 @@ my %alias = qw(^ ** x ^ < << > >> + + - - / / * * & & | |);
# holds user functions # holds user functions
my %custom; my %custom;
# converter helper
sub convert {
my $code = shift;
my ($a) = getlast(1);
if (defined $a) {
return "$a $code";
}
}
# hand coded functions # hand coded functions
my %func = ( my %func = (
'%' => sub { '%' => sub {
# X % of Y # X % of Y
if (scalar @_ == 2) { my ($a, $b) = getlast(2);
my ($a, $b) = @_; if (defined $b) {
return "($a / 100) * $b"; return "($a / 100) * $b";
} }
else {
print "percent only possible with 2 values\n";
undo();
return 0;
}
}, },
'%d' => sub { '%d' => sub {
# percentual difference # percentual difference
if (scalar @_ == 2) { my ($a, $b) = getlast(2);
my ($a, $b) = @_; if (defined $b) {
return "(($a - $b) / $b) * 100" return "(($a - $b) / $b) * 100"
} }
else {
print "percent only possible with 2 values\n";
undo();
return 0;
}
}, },
'%+' => sub { '%+' => sub {
# Y + (X $ of Y) # Y + (X $ of Y)
if (scalar @_ == 2) { my ($a, $b) = getlast(2);
my ($a, $b) = @_; if (defined $b) {
return "$a + (($a / 100) * $b)"; return "$a + (($a / 100) * $b)";
} }
else {
print "percent only possible with 2 values\n";
undo();
return 0;
}
}, },
'%-' => sub { '%-' => sub {
# Y - (X $ of Y) # Y - (X $ of Y)
if (scalar @_ == 2) { my ($a, $b) = getlast(2);
my ($a, $b) = @_; if (defined $b) {
return "$a - (($a / 100) * $b)"; return "$a - (($a / 100) * $b)";
} }
else {
print "percent only possible with 2 values\n";
undo();
return 0;
}
}, },
'v' => sub { 'v' => sub {
if (scalar @_ == 2) { # square root
my ($a, $b) = @_; my ($a) = getlast(1);
return "$a ** (1 / $b)"; if (defined $a) {
}
else {
my $a = pop @_;
return "$a ** (1 / 2)"; return "$a ** (1 / 2)";
} }
}, },
'm' => sub { 'm' => sub {
# median # median
if (scalar @_ >= 2) { my @values = getlast(2); # we need 2 or all in sub mode
my $c = $#_; if (scalar @values >= 2) {
if (scalar @_ % 2 == 0) { my $c = $#values;
if (scalar @values % 2 == 0) {
# even # even
return "((sort qw(@_))[$c / 2] + (sort qw(@_))[($c / 2) + 1]) / 2"; return "((sort qw(@values))[$c / 2] + (sort qw(@values))[($c / 2) + 1]) / 2";
} }
else { else {
# uneven # uneven
return "(sort qw(@_))[$c / 2]"; return "(sort qw(@values))[$c / 2]";
} }
} }
else { else {
print "median only possible with 2 or more values\n"; print "median only possible with 2 or more values\n";
undo(); return 0; undo();
return 0;
} }
}, },
'a' => sub { 'a' => sub {
# average # average
return "(" . join(' + ', @_) . ") / " . scalar @_; 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;
}
}, },
'x' => sub {
# XOR
my ($a, $b) = getlast(2);
if (defined $b) {
return "$a ^ $b";
}
},
'|' => sub {
# OR
my ($a, $b) = getlast(2);
if (defined $b) {
return "$a | $b";
}
},
'|' => sub {
# XOR
my ($a, $b) = getlast(2);
if (defined $b) {
return "$a ^ $b";
}
},
# converters: # converters:
# gallons to liters # gallons to liters
'tl' => sub { return $_[-1] * 3.785 }, 'tl' => sub { return convert("* 3.785") },
# yards to meters # yards to meters
'tm' => sub { return $_[-1] * 91.44 }, 'tm' => sub { return convert("* 91.44") },
# miles to kilometers # miles to kilometers
'tk' => sub { return $_[-1] * 1.609 }, 'tk' => sub { return convert("* 1.609") },
# inches to cm # inches to cm
'tc' => sub { return $_[-1] * 2.54 }, 'tc' => sub { return convert("* 2.54") },
# to 'bytes # to 'bytes
'tkb' => sub { return $_[-1] / 1000 }, 'tkb' => sub { return convert("/ 1000") },
'tmb' => sub { return $_[-1] / 1000 / 1000}, 'tmb' => sub { return convert("/ 1000 / 1000") },
'tgb' => sub { return $_[-1] / 1000 / 1000 / 1000 }, 'tgb' => sub { return convert("/ 1000 / 1000 / 1000") },
'ttb' => sub { return $_[-1] / 1000 / 1000 / 1000 / 1000 }, 'ttb' => sub { return convert("/ 1000 / 1000 / 1000 / 1000") },
# alias
'x' => sub { return join "^", @_ },
); );
# math constants, always upper case letters, usable via eval{} # math constants, always upper case letters, usable via eval{}
@@ -347,7 +364,9 @@ sub pushstack {
} }
sub dumpstack { sub dumpstack {
return unless $showstack; if (! $showstack && !$mgt) {
return;
}
my $max = shift; my $max = shift;
my $x = ' '; my $x = ' ';
@@ -405,23 +424,42 @@ sub backup {
sub getlast { sub getlast {
# return and remove last 1, 2 or all elements of current stack
my $request = shift;
my @all = (); my @all = ();
backup(); backup();
if ($sub) { if ($sub) {
# ignore request count
@all = @substack; @all = @substack;
@substack = (); @substack = ();
} }
else { else {
if (@stack) { if (@stack) {
if (scalar @stack == 1) { if (scalar @stack == 1) {
@all = pop @stack; if ($request > 1) {
print "At least $request variables must be on the stack!\n";
return 0;
}
else {
@all = pop @stack;
}
} }
else { else {
@all = reverse (pop @stack, pop @stack); if ($request == 1) {
@all = pop @stack;
}
else {
# return 2 elements, as we do not support more than 2 anyway
@all = reverse (pop @stack, pop @stack);
}
} }
} }
else {
print "Please enter one or more numbers to operate on!\n";
}
} }
return @all; return @all;
@@ -490,53 +528,48 @@ sub calc {
my $res; my $res;
my $code; my $code;
my @last = getlast();
if (@last) { if (exists $alias{$op}) {
if (exists $alias{$op}) { my @last = getlast(2);
$op = $alias{$op}; $op = $alias{$op};
$code = join(" $op ", @last); $code = join(" $op ", @last);
} }
elsif (exists $func{$op}) { elsif (exists $func{$op}) {
my $sub = $func{$op}; my $sub = $func{$op};
$code = &$sub(@last); $code = &$sub();
return unless $code; return unless $code;
}
else {
print "syntax error or unknown command!\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";
}
}
} }
else { else {
print "syntax error or unknown command!\n";
undo();
return; 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";
}
}
} }
@@ -632,7 +665,7 @@ Stack Management: - substract
srt rotate the stack & bitwise AND srt rotate the stack & bitwise AND
| bitwise OR | bitwise OR
Register Management: x bitwise XOR Register Management: x bitwise XOR
r put X to register v pull root (2nd if stack==1) r put X to register v square root
rcx clear X (last register element) m median rcx clear X (last register element) m median
rc clear register a average rc clear register a average