rpnc/rpnc

#!/usr/bin/perl

use Term::ReadLine;
use Data::Dumper;
use Getopt::Long;

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 $tty       = 1;
my $VERSION   = '1.05';
my $sub       = 0;
my $maxstack  = 10;
my $maxreg    = 5;
my $op;

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;
}

$op = shift;

if ($op) {
  $tty = 0;
  while (<STDIN>) {
    chomp;
    push @stack, split /\s\s*/;
  }
  print calc($op);
  exit;
}

# management commands, always lower case letters or words
my %commands = (
                # stack commands
                s   => sub { dumpstack(); },
                sa  => sub { dumpstack(1); },
                sc  => sub { clearstack(); },
                scx => sub { clearstack(1); dumpstack(); },
                sr  => sub { reversestack(); },
                srt => sub { rotatestack(); },
                # collector
                '(' => sub { $sub = 1 },
                ')' => sub { $sub = 0 },
                # 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; },
               );

# executed 1:1, or aliased
my %alias   = qw(^ ** x ^ < << > >> + + - - / / * * & & | |);

# hand coded functions
my %func    = (
               '%' => sub {
                 if (scalar @_ == 2) {
                   my ($a, $b) = @_;
                   return "($a / 100) * $b";
                 }
                 else {
                   print "percent only possible with 2 values\n";
                   undo();
                   return 0;
                 }
               },
               '%d' => sub {
                 # percentual difference
                 if (scalar @_ == 2) {
                   my ($a, $b) = @_;
                   return "(($a - $b) / $b) * 100"
                 }
                 else {
                   print "percent only possible with 2 values\n";
                   undo();
                   return 0;
                 }
               },
               'v' => sub {
                 if (scalar @_ == 2) {
                   my ($a, $b) = @_;
                   return "$a ** (1 / $b)";
                 }
                 else {
                   my $a = pop @_;
                   return "$a ** (1 / 2)";
                 }
               },
               'pr' => sub {
                 # parallel resistance, maybe add ~/.rpncrc support
                 # where to add such custom functions...
                 return "1 / (" . join(' + ', map { "1 / $_"} @_) . ")";
               },
               'm' => sub {
                 # median
                 if (scalar @_ >= 2) {
                   my $c = $#_;
                   if (scalar @_ % 2 == 0) {
                     # even
                     return "((sort qw(@_))[$c / 2] + (sort qw(@_))[($c / 2) + 1]) / 2";
                   }
                   else {
                     # uneven
                     return "(sort qw(@_))[$c / 2]";
                   }
                 }
                 else {
                   print "median only possible with 2 or more values\n";
                   undo(); return 0;
                 }
               },
               'a' => sub {
                 # average
                 return "(" . join(' + ', @_) . ") / " . scalar @_;
               }
              );

# math constants, always upper case letters, usable via eval{}
use constant PI => 3.141592653589793;
use constant V2 => 1.414213562373095;
use constant V3 => 1.732050807568877;

my $OUT = $term->OUT || \*STDOUT;
while ( defined ($_ = $term->readline(prompt())) ) {
  foreach my $tok (split /\s+/) {
    if ($tok =~ /^-?[A-Z\.\d]+?$/) {
      # number
      if ($tok =~ /^R(\d+?)/) {
        my $r = getreg($1);
        if ($r) {
          pushstack($r);
        }
        else {
          print "invalid register index!\n";
          next;
        }
      }
      else {
        pushstack($tok);
      }
      dumpstack();
    }
    else {
      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 {
  return unless $showstack;

  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 = scalar @register;
    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 {
  my @all = ();

  backup();

  if ($sub) {
    @all = @substack;
    @substack = ();
  }
  else {
    if (@stack) {
      if (scalar @stack == 1) {
        @all = pop @stack;
      }
      else {
        @all = reverse (pop @stack, pop @stack);
      }
    }
  }

  return @all;
}

sub getreg {
  my $n = shift;
  print scalar @register;
  if (scalar @register <= $n) {
    return $register[$n-1];
  }
  else {
    return 0;
  }
}

sub last_to_reg {
  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 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;

  my @last = getlast();

  if (@last) {
    if (exists $alias{$op}) {
      $op = $alias{$op};
      $code = join(" $op ",  @last);
    }
    elsif (exists $func{$op}) {
      my $sub = $func{$op};
      $code = &$sub(@last);
      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 {
    return;
  }
}


sub help {
  print qq~
Reverse Polish Notation Calculator, version $VERSION.
Copyleft (L) 2019 - 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 mode
                                           +    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
 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                    v    pull root (2nd if stack==1)
 rcx  clear X (last register element)      m    median
 rc   clear register                       a    average

Various Commands                          Constants: PI V2 V3
 u    undo last operation
 h    show history of past operations     Using register:
 q    finish (C-d works as well)             enter R + index, e.g. R1
 ?    print help
~;
}