#! /usr/bin/perl

# ================================================================
# This is a very rough equivalent of the Unix bc program.
#
# John Kerl
# kerl.john.r@gmail.com
# 2005-06-30
# ================================================================

# To do:
# * Allow optional *output* of underscores (-u).  Default off.
# * Support binary.  hex2bin, bin2hex to module; h2b/b2h/bc to call.
# * Support bigint.  Do away with built-in integers; too small.
#   Need to add base conversion to bigint package.
# * Prefix user-entered vars with "$" if not already there.

# ----------------------------------------------------------------
$prompt = "kbc: ";
$ibase  = 10;
$obase  = 10;
$fp_output_fmt = "%f";
$do_binary_underscores = 1;
$min_binary_width = 32;
$want_prompt = 1;

# Pre-define these often-used values for the user.
$pi = 4*atan2(1,1);
$e = exp(1);

# ================================================================
while (@ARGV) {
	if (do_option($ARGV[0])) {
		shift @ARGV;
	}
	else {
		last;
	}
}

if (@ARGV) {
	eval_line(join " ", @ARGV);
}
else {
	print $prompt if $want_prompt;
	while (<>) {
		chomp;
		last if ($_ =~ m/^\s*[\.qx]\s*$/i);
		last if ($_ =~ m/^\s*quit\s*$/i);
		last if ($_ =~ m/^\s*exit\s*$/i);
		last if ($_ =~ m/^\s*bye\s*$/i);
		if ($_ =~ m/^\s*$/) {
			print $prompt if $want_prompt;
			next;
		}
		eval_line($_);
		print $prompt if $want_prompt;
	}
}

# ================================================================
sub eval_line
{
	my $evalrc;

	my $line = shift @_;
	for my $expr (split /;+/, $line) {
		next if ($expr =~ m/^\s*$/);
		$evalrc = eval_expression($expr);
		last if (!$evalrc);
	}
	return $evalrc;
}

# ----------------------------------------------------------------
sub eval_expression
{
	my $evalrc;

	my $input = shift @_;
	my $output;

	# Extract options.
	my @in_tokens = split /\s+/, $input;

	while (do_option($in_tokens[0])) {
		shift @in_tokens;
	}
	return unless (@in_tokens);
	$input = join " ", @in_tokens;


	# Remove underscores.
	$input =~ s/_//g;


	# Canonicalize whitespace.
	$input = canonicalize_whitespace($input);


	# Perform input base conversion.
	$input = convert_bases($input);

	# Have Perl evaluate the arithmetic expression.
	$input .= ";";
	$output = eval $input;
	$evalrc = $output;


	# Format and print the output.
	if ($obase == 16) {
		$output = sprintf("%x", $output);
		$output = "0x" . $output;
		print "$output\n";
	}
	elsif ($obase == 2) {
		$output = sprintf("0x%x", $output); # Decimal to hex
		$output = "0b" . hex2bin($output);  # Hex to binary
		print "$output\n";
	}
	else {
		printf "$fp_output_fmt\n", $output;
	}

	return $evalrc;
}

# ----------------------------------------------------------------
sub print_help
{
	print "Usage goes here.\n";
}

# ----------------------------------------------------------------
sub do_option
{
	my $arg = shift @_;
	my $is_option = 1;

	if    ($arg =~ m:^[/-]h:i)   { print_help(); }
	elsif ($arg =~ m:^[/-]\?$:i) { print_help(); exit;}
	elsif ($arg =~ m:^[/-]ix$:i) { $ibase = 16; }
	elsif ($arg =~ m:^[/-]ox$:i) { $obase = 16; }
	elsif ($arg =~ m:^[/-]id$:i) { $ibase = 10; }
	elsif ($arg =~ m:^[/-]od$:i) { $obase = 10; }
	elsif ($arg =~ m:^[/-]ib$:i) { $ibase =  2; }
	elsif ($arg =~ m:^[/-]ob$:i) { $obase =  2; }
	elsif ($arg =~ m:^[/-]e$:i)  { $fp_output_fmt =  "%e"; }

	elsif ($arg =~ m:^[/-]p$:i)  { $want_prompt = 1; }
	elsif ($arg =~ m:^[/-]np$:i) { $want_prompt = 0; }

	elsif ($arg =~ m:^[/-]cls$:i) { system("clear"); }

	elsif ($arg =~ m:^[/-]x$:i)  { $ibase = 16; $obase = 16; }
	elsif ($arg =~ m:^[/-]d$:i)  { $ibase = 10; $obase = 10; }
	elsif ($arg =~ m:^[/-]b$:i)  { $ibase =  2; $obase =  2; }
	elsif ($arg =~ m:^[/-]u$:i)  { $do_binary_underscores = 1; }
	elsif ($arg =~ m:^[/-]nu$:i) { $do_binary_underscores = 0; }

	elsif ($arg =~ m:^[/-]bl:i)  {
		$arg =~ s:^[/-]bl::;
		if ($arg <= 0) {
			print "Min. binary width must be positive.\n"
		}
		else {
			$min_binary_width = $arg;
		}
	}

	elsif ($arg =~ m/^\//i)    {
		print "Unknown option \"$arg\".\n";
		exit;
	}
	else { $is_option = 0; }

	return $is_option;
}

# ----------------------------------------------------------------
sub canonicalize_whitespace
{
	my $input = shift @_;

	$input =~ s/\(/ ( /g;
	$input =~ s/\)/ ) /g;
	$input =~ s/\+/ + /g;
	$input =~ s/e *\+ */e-/g; # Fix the scientific notation we just broke
	$input =~ s/\-/ - /g;
	$input =~ s/e *\- */e-/g; # Fix the scientific notation we just broke
	$input =~ s/\*/ * /g;
	$input =~ s/\*/ * /g;
	$input =~ s/\* *\*/ ** /g; # Fix the ** we just broke
	$input =~ s/\// \/ /g;
	$input =~ s/%/ % /g;
	$input =~ s/=/ = /g;
	$input =~ s/&/ & /g;
	$input =~ s/\|/ | /g;
	$input =~ s/\^/ ^ /g;
	$input =~ s/\~/ ~ /g;

	$input =~ s/\s+/ /g;

	return $input;
}

# ----------------------------------------------------------------
sub convert_bases
{
	my $input = shift @_;

	my @fields = split " ", $input;

	for my $field (@fields) {
		if ($field =~ m/^[0-9a-f]+$/i) {

			if ($field =~ m/^0x/i) {
				# Input is specifed to be in hex.  Perl can handle that.
			}
			elsif ($field =~ m/^0d/i) {
				# Input is specifed to be in decimal.  Strip off leading "0d".
				$field =~ s/^0[Dd]//;
			}
			elsif ($field =~ m/^0b/i) {
				# Input is specifed to be in binary.  My installation of Perl
				# can't handle "0b" literals.  Strip off leading "0b" and
				# convert to hex.
				$field =~ s/^0[Bb]//;
				$field = bin2hex($field);
			}
			else {
				# Input base wasn't specified.  Apply default base.
				if ($ibase == 16) {
					$field = "0x" . $field;
				}
				elsif ($ibase == 2) {
					$field =~ s/^0[Bb]//;
					$field = bin2hex($field);
				}
				else {
					# Else input is decimal; OK as is.  Unless there's a leading
					# 0 which means octal to Perl; I never ever ever ever give a
					# hoot about octal so let's make such input look like decimal.
					if ($field =~ m/^0+/) {
						$field =~ s/^0+//;
						if ($field == "") {
							$field = "0";
						}
					}
				}
			}
		}
	}
	$input = join " ", @fields;
}

# ----------------------------------------------------------------
sub hex2bin
{
	my $arg = lc shift @_;
	if ($arg =~ m/^0x/) {
		$arg =~ s/^0x//;
	}
	$arg =~ s/_//g;

	my $num_hex_chars = length($arg);

	if ($num_hex_chars < $min_binary_width) {
		my $templen = int($min_binary_width/4) - $num_hex_chars;
		my $tempstr = "0" x $templen;
		$arg = $tempstr . $arg;
	}

	my @in_chars = split //, $arg;
	my $output = "";


	while (@in_chars) {

		if    ($in_chars[0] eq "0") { $output .= "0000"; }
		elsif ($in_chars[0] eq "1") { $output .= "0001"; }
		elsif ($in_chars[0] eq "2") { $output .= "0010"; }
		elsif ($in_chars[0] eq "3") { $output .= "0011"; }

		elsif ($in_chars[0] eq "4") { $output .= "0100"; }
		elsif ($in_chars[0] eq "5") { $output .= "0101"; }
		elsif ($in_chars[0] eq "6") { $output .= "0110"; }
		elsif ($in_chars[0] eq "7") { $output .= "0111"; }

		elsif ($in_chars[0] eq "8") { $output .= "1000"; }
		elsif ($in_chars[0] eq "9") { $output .= "1001"; }
		elsif ($in_chars[0] eq "a") { $output .= "1010"; }
		elsif ($in_chars[0] eq "b") { $output .= "1011"; }

		elsif ($in_chars[0] eq "c") { $output .= "1100"; }
		elsif ($in_chars[0] eq "d") { $output .= "1101"; }
		elsif ($in_chars[0] eq "e") { $output .= "1110"; }
		elsif ($in_chars[0] eq "f") { $output .= "1111"; }

		else { $output.= "????"; }


		if ($do_binary_underscores) {
			if (@in_chars > 1) {
				$output .= "_";
			}
		}
		shift @in_chars;
	}
	return $output;
}

# ----------------------------------------------------------------
sub bin2hex
{

	my $arg = lc shift @_;
	chomp $arg;

	if ($arg =~ m/^0b/) {
		$arg =~ s/^0b//;
	}
	$arg =~ s/_//g;

	my $len = length $arg;
	my $len_mod = $len % 4;
	if ($len_mod != 0) {
		$arg = ("0" x (4 - $len_mod)) . $arg;
	}

	my @in_chars = split //, $arg;
	my $output = "";
	my $output_count = 0;
	my $terminal_count = int(@in_chars / 4) - 1;

	while (@in_chars) {
		my $a = $in_chars[0];
		my $b = $in_chars[1];
		my $c = $in_chars[2];
		my $d = $in_chars[3];

		if    (($a eq "0") && ($b eq "0") && ($c eq "0") && ($d eq "0")) { $output .= "0"; }
		elsif (($a eq "0") && ($b eq "0") && ($c eq "0") && ($d eq "1")) { $output .= "1"; }
		elsif (($a eq "0") && ($b eq "0") && ($c eq "1") && ($d eq "0")) { $output .= "2"; }
		elsif (($a eq "0") && ($b eq "0") && ($c eq "1") && ($d eq "1")) { $output .= "3"; }

		elsif (($a eq "0") && ($b eq "1") && ($c eq "0") && ($d eq "0")) { $output .= "4"; }
		elsif (($a eq "0") && ($b eq "1") && ($c eq "0") && ($d eq "1")) { $output .= "5"; }
		elsif (($a eq "0") && ($b eq "1") && ($c eq "1") && ($d eq "0")) { $output .= "6"; }
		elsif (($a eq "0") && ($b eq "1") && ($c eq "1") && ($d eq "1")) { $output .= "7"; }

		elsif (($a eq "1") && ($b eq "0") && ($c eq "0") && ($d eq "0")) { $output .= "8"; }
		elsif (($a eq "1") && ($b eq "0") && ($c eq "0") && ($d eq "1")) { $output .= "9"; }
		elsif (($a eq "1") && ($b eq "0") && ($c eq "1") && ($d eq "0")) { $output .= "a"; }
		elsif (($a eq "1") && ($b eq "0") && ($c eq "1") && ($d eq "1")) { $output .= "b"; }

		elsif (($a eq "1") && ($b eq "1") && ($c eq "0") && ($d eq "0")) { $output .= "c"; }
		elsif (($a eq "1") && ($b eq "1") && ($c eq "0") && ($d eq "1")) { $output .= "d"; }
		elsif (($a eq "1") && ($b eq "1") && ($c eq "1") && ($d eq "0")) { $output .= "e"; }
		elsif (($a eq "1") && ($b eq "1") && ($c eq "1") && ($d eq "1")) { $output .= "f"; }

		else { $output.= "?"; }

		if ($do_binary_underscores) {
			#if ((($output_count % 4) == 3) && ($output_count < $terminal_count))
			if (((@in_chars % 16) == 4) && (@in_chars > 16)) {
				$output .= "_";
			}
		}

		$output_count++;
		shift @in_chars;
		shift @in_chars;
		shift @in_chars;
		shift @in_chars;
	}
	return "0x" . $output;
}