#!/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

~;
}