#!/usr/local/bin/perl
#  dc.pl - an arbitrary precision RPN calculator, using only string ops
#
#  Created for the Perl Power Tools project Mar 1999 by running my original
#  sed version at http://seders.icheme.org through s2p -n.  I fixed up the
#  result quite a bit, overcoming the s2p and sed limitations, but didn't
#  optimize the essence of the program.  A normal implementation of dc would
#  probably use something like Math::BigInt instead of pattern substitution.

##  dc.sed created by Greg Ubben <gsu@romulus.ncsc.mil> early 1995, late 1996
##  @(#)GSU dc.sed 1.0 27-Feb-1997 [non-explanatory]
##
##  Examples:
##	sqrt(2) to 10 digits:	echo "10k 2vp" | dc.sed
##	20 factorial:		echo "[d1-d1<!*]s! 20l!xp" | dc.sed
##	sin(ln(7)):		echo "s(l(7))" | bc -c /usr/lib/lib.b | dc.sed
##	hex to base 60:		echo "60o16i 6B407.CAFE p" | dc.sed
##	tests most of dc.sed:	echo 16oAk2vp | dc.sed
##
##  Format of pattern space:
##	<stack>|P|K0|I10|O10|ra<stack>|rx<stack>|rZ<stack>|?<input-stack>
##  Where <stack> is a sequence of 0 or more numbers or strings, each
##  followed by a tilde (~).  The stack items will not contain [|~].
##
##  To debug or analyze, give the dc Y command as input or add it to
##  embedded dc routines, or add the sed p command to the beginning of
##  the main loop or at various points in the low-level sed routines.
##
##  Not implemented:	! \  [! added in dc.pl]
##  But implemented:	K Y t # !< !> != fractional-bases
##  SunOS sed limits:	199/199 commands (though could pack in 10-20 more)
##  Limitations: 	scale <= 999; |obase| >= 1; input digits in [0..F]
##  Completed:		1am Feb 4, 1997

eval 'exec /usr/local/bin/perl -S $0 ${1+"$@"}'
	if $running_under_some_shell;

push @ARGV, "-";

$_ = "|P|K0|I10|O10|?";

for (;;) {
    s/\|\?./|?/s;
    if (/\|\?!*[lLsS;:<>=]?$/) {
	last unless $line = <>;
	$line =~ tr/|~/\36\37/;
	$_ .= $line;
    }
    if (/\|\?(#|![^<>=])/) {
	s/\|\?(.)([^\n~]*)/|?/;
	($line = $2) =~ tr/\36\37/|~/;
	system $line  if $1 eq "!";
    }
    goto Binop  if /\|\?!*[-+*\/%^<>=]/;
    goto Binop  if /^\|.*\|\?[dpPfQXZvxkiosStT;:]/s;
    goto Number if /\|\?[_0-9A-F.]/;
    goto String if /\|\?\[/;
    goto Load   if /\|\?l/;
    goto Load1  if /\|\?L/;
    goto Save   if /\|\?[sS]/;

    /\|\?c/ && s/[^|]*//;
    /\|\?d/ && s/([^~]*~)/$1$1/;
    /\|\?f/ && s//|?f[pSbz0<aLb]dSaxsaLa/;
    /\|\?x/ && s/([^~]*~)(.*\|\?x)~*/$2$1/s;
    /\|\?[KIO]/ && s/(.*\|([KIO])([^|]*).*\|\?\2)/$3~$1/s;
    /\|\?T/ && s/\.*0*~/~/;

    # a slow, non-stackable array implementation in dc, just for completeness
    # A fast, stackable, associative array implementation could be done in sed
    # (format: {key}value{key}value...), but would be longer, like load & save.
    /\|\?;/ &&
     s/\|\?;([^{}])/|?~[s}s{L{s}q]S}[S}l$1L}1-d0>}s$1L$1l{xS$1]dS{xL}/;
    /\|\?:/ &&
     s/\|\?:([^{}])/|?~[s}L{s}L{s}L}s$1q]S}S}S{[L}1-d0>}S}l$1s$1L$1l{xS$1]dS{x/;

    next if /\|\?[\s~cdfxKIOT]/;
    goto Print if /\|\?[pP]/;
    /\|\?k/ && s/^(\d{1,3})([.~].*\|K)[^|]*/$2$1/s;
    /\|\?i/ && s/^(-?\d*\.?\d+)(~.*\|I)[^|]*/$2$1/s;
    /\|\?o/ && s/^(-?[1-9]\d*\.?\d*)(~.*\|O)[^|]*/$2$1/s;
    goto Pop   if /\|\?[kio]/;
    goto Trunc if /\|\?t/;
    goto Input if /\|\?\?/;
    goto Break if /\|\?Q/;
    goto Quit  if /\|\?q/;
    $hold = $_;
    goto Count if /\|\?[XZz]/;
    goto Sqrt  if /\|\?v/;
    s/.*\|\?([^Y]).*/$1 is unimplemented/s;
    s/([^\n -[\]-~])/sprintf '\%03o', ord $1/eg;	# sed l command
    s/\n/\\n/g;
    print $_, "\n";
    $_ = $hold;
    next;

  Print:
    if (/^-?\d*\.?\d+~.*\|\?p/s and not /\|O10\|/) {

    #  Print a number in a non-decimal output base.  Uses registers a,b,c,d.
    #  Handles fractional output bases (O<-1 or O>=1), unlike other dc's.
    #  Converts the fraction correctly on negative output bases, unlike
    #  UNIX dc.  Also scales the fraction more accurately than UNIX dc.
    #
    s{\|\?p}
     {|?pKSa0kd[[-]Psa0la-]Sad0>a[0P]sad0=a[A*2+]saOtd0>a1-ZSd[[[[ ]P]sclb
1!=cSbLdlbtZ[[[-]P0lb-sb]sclb0>c1+]sclb0!<c[0P1+dld>c]scdld>cscSdLbP]q]Sb
[t[1P1-d0<c]scd0<c]ScO_1>bO1!<cO[16]<bOX0<b[[q]sc[dSbdA>c[A]sbdA=c[B]sbd
B=c[C]sbdC=c[D]sbdD=c[E]sbdE=c[F]sb]xscLbP]~Sd[dtdZOZ+k1O/Tdsb[.5]*[.1]O
X^*dZkdXK-1+ktsc0kdSb-[Lbdlb*lc+tdSbO*-lb0!=aldx]dsaxLbsb]sad1!>a[[.]POX
+sb1[SbO*dtdldx-LbO*dZlb!<a]dsax]sadXd0<asbsasaLasbLbscLcsdLdsdLdLak[]pP};
    next;
    }

    /\|\?p/ && s/([^~]*)/$1\n~$1/;
    # perl: can print partial lines immediately vs buffering in |P
    #s/(.*\|P)([^|]*)/\n$2$1/s;
    #s/([^~]*)\n([^~]*)(.*\|P)/$1$3$2/s;
    $hold = $_;
    s/~.*//s;
    tr/\36\37/|~/;
    print;		# $_, "\n"  if s/.//s;
    $_ = $hold;

  Pop:
    s/[^~]*~//;
    next;

  Load:
    s/(.*\|\?.)(.)/${2}0~$1/s;
    s/^(.)0(.*\|r\1([^~|]*)~)/$1$3$2/s;
    s/.//s;
    next;

  Load1:
    s/(.*\|\?.)(.)/$2$1/s;
    s/^(.)(.*\|r\1)([^~|]*~)/|$3$2/s;
    warn "register empty\n"  unless /^\|/;
    s/.//s;
    next;

  Save:
    s/(.*\|\?.)(.)/$2$1/s;
    /^(.).*\|r\1/s || s/((.).*\|)/$1r$2|/s;
    /\|\?S/        && s/((.).*\|r\2)/$1~/s;
    s/(.)([^~]*~)(.*\|r\1)[^~|]*~?/$3$2/s;
    next;

  Quit:
    last unless s/\|\?[^~]*~[^~]*~/|?q/;
    next;

  Break:
    s/(\d*)/$1;987654321009;/;
    1 while
	s/^([^;]*)([1-9])(0*)([^1]*\2(.)[^;]*\3(9*).*\|\?.)[^~]*~/$1$5$6$4/s;
    goto Pop;

  Input:
    last unless $line = <STDIN>;
    $line =~ tr/|~/\36\37/;
    $_ .= "\n" . $line;
    s/\|\?\?(.*)(\n.*)\n/|?$2~$1/s;
    next;

  Count:
    /\|\?Z/         && s/~.*//s;
    /^-?\d*\.?\d+$/ && s/[-.0]*([^.]*)\.*/$1/;
    /\|\?X/         && s/-*[0-9A-F]*\.*([0-9A-F]*).*/$1/s;
    s/\|.*//s;
    /~/ && s/[^~]//g;
    s/./a/gs;
    do {			# $_ = length;
	s/a{10}/b/g;
	s/(b*a*)/$1a9876543210;/;
	s/a.{9}(.).*;/$1/;
	y/b/a/;
    } while /a/;
    $_ .= "\n"; $_ .= $hold;
    /\|\?z/ && s/\n/\n~/;
    s/\n[^~]*//;
    next;

  Trunc:
    # for efficiency, doesn't pad with 0s, so 10k 2 5/ returns just .40
    s/([^.~]*\.*)(.*\|K([^|]*))/$3;9876543210009909:$1,$2/s;
    1 while
	s/^([^;]*)([1-9])(0*)([^1]*\2(.)[^:]*\3(9*)[^,]*),(\d)/$1$5$6$4$7,/;
    s/[^:]*:([^,]*)[^~]*/$1/;
    goto Normal;

  Number:
    s/(.*\|\?)(_?[0-9A-F]*\.?[0-9A-F]*)/$2~$1~/s;
    s/^_/-/;
    goto Normal  if /^[^A-F~]*~.*\|I10\|/s or /^[-0.]*~/;
    s {([^.~]*)\.*([^~]*)}
      {[Ilb^lbk/,$1$2~0A1B2C3D4E5F1=11223344556677889900;.$2};
    1 while
	s/^([^,]*),(-*)([0-F])([^;]*(.)\3[^1;]*(1*))/I*+$1$2$6$5~,$2$4/;
    s {...([^/]*.)([^,]*)[^.]*(.*\|\?.)}
      {$2$3KSb[99]k$1]SaSaXSbLalb0<aLakLbktLbk}s;
    next;

  String:
    do {
	if (/\|\?[^]]*$/) {
	    last unless $line = <>;
	    $line =~ tr/|~/\36\37/;
	    $_ .= $line;
	}
	s/(\|\?[^]]*)\[([^]]*)]/$1|{$2|}/;
    } while /\|\?\[/;
    s/(.*\|\?)\|{(.*)\|}/$2~${1}[/s;
    s/\|{/[/g;
    s/\|}/]/g;
    next;

  Binop:
    unless (/^[^~|]*~[^|]/) {
	warn "stack empty\n";
	next;
    }
    /^-?\d*\.?\d+~/       ||  s/[^~]*(.*\|\?!*[^!=<>])/0$1/s;
    /^[^~]*~-?\d*\.?\d+~/ || s/~[^~]*(.*\|\?!*[^!=<>])/~0$1/s;
    $hold = $_;
    goto Mul if /\|\?\*/;
    goto Div if /\|\?\//;
    goto Rem if /\|\?\%/;
    goto Exp if /\|\?\^/;

    /\|\?[+-]/ && s/^(-*)([^~]*~)(-*)([^~]*~).*\|\?(-?).*/$2$4s$3o$1$3$5/s;
    s/([^.~]*)([^~]*~[^.~]*)(.*)/<$1,$2,$3|=-~.0,123456789<></s;
    /^<([^,]*,[^~]*)\.*0*~\1\.*0*~/ && s/</=/;
    1 while
	s/^(<[^,]*)(\d),([^,]*)(\d),/$1,$2$3,$4/;
    /^<([^~]*)([^~])[^~]*~\1(.).*\|=.*\3.*\2/s && s/</>/;
    if (/\|\?/) {
	s/^([<>])(-[^~]*~-.*\1)(.)/$3$2/s;
	s/^(.)(.*\|\?!*)\1/$2!$1/s;
	s/(\|\?![^!](.))/$1l$2x/s;
	s/[^~]*~[^~]*~(.*\|\?)!*.(.*)\|=.*/$1$2/s;
	next;
    }
    s/(-*)\1\|=.*/;9876543210;9876543210/;
    /o-/ && s/;9876543210/;0123456789/;
    s/^>([^~]*~)([^~]*~)s(-*)(-*o\3(-*))/>$2$1s$5$4/;

    s/,(\d*)\.*([^,]*),(\d*)\.*(\d*)/$1,$2$3.,$4;0/;
    1 while
	s/,(\d)([^,]*),;*(\d)(\d*);*0*/$1,$2$3,$4;0/;
    s/.([^,]*),~(.*);0~s(-*)o-*/$1~${3}0$2~/;

    do {
	s {(.?)(~[^,]*)(\d)(\.*),([^;]*)(;([^;]*(\3[^;]*)).*\1(.*))}
	  {$2,$4$5$9$8$7$6};
	s/,([^~]*~).{10}(.)[^;]{0,9}([^;]?)[^;]*/,$2$1$3/;
    } until /^~.*~;/;

  Endbin:
    s/.([^,]*),([\d.]*).*/$1$2/;
    $_ .= "\n"; $_ .= $hold;
    s/\n[^~]*~[^~]*//;

  Normal:
    s/^(-*)0*([\d.]*\d)[^~]*/$1$2/;
    s/^[^1-9~]*~/0~/;
    next;

  Mul:
    s {(-*)(\d*)\.*(\d*)~(-*)(\d*)\.*(\d*).*\|K([^|]*).*}
      {$1$4$2$5.!$3$6,|$2<$3~$5>$6:$7;9876543210009909}s;
    1 while
	s/!\d([^<]*)<(\d?)([^>]*)>(\d?)/0!$1$2<$3$4>/ +
	(/!\d/ && s/(:[^;]*)([1-9])(0*)([^0]*\2(.).*\3(9*))/$1$5$6$4/)
	and not /<~[^>]*>:0*;/;
    s/(-*)\1([^>]*).*/;$2^>:9876543210aaaaaaaaa/;
    do {
	s/(\d~*)\^/^$1/;
	s/<(\d*)(.*[~^])(\d*)>/$1<$2>$3/;
	do {
	    s{>(\d)(.*\1.{9}(a*))}
	     {$1>$2;9${3}8${3}7${3}6${3}5${3}4${3}3${3}2${3}1${3}0};
	    s/(;[^<]*)(\d)<([^;]*).*\2\d*(.*)/$4$1<$2$3/;
	    s/a\d/a/g;
	    s/a{10}/b/g;
	    s/b{10}/c/g;
	} while /\|0*[1-9][^>]*>0*[1-9]/;
	s/;/a9876543210;/;
	s/a.{9}(.)[^;]*([^,]*)\d([.!]*),/$2,$1$3/;
	y/cb/ba/;
    } until /\|<\^/;
    goto Endbin;

  Div:
    #  CDDET
    unless (/^[-.0]*[1-9]/) {
	warn "divide by 0\n";
	goto Pop;
    }
    s/(-*)(\d*)\.*([^~]*~-*)(\d*)\.*([^~]*)/$2.$3$1;0$4.$5;0/;
    1 while
	s/^\.0([^.]*)\.;*(\d)(\d*);*0*/.$1$2.$3;0/  or
	s/^([^.]*)(\d)\.([^;]*;)0*(\d*)(\d)\./$1.$2${3}0$4.$5/;
    s/~(-*)\1(-*);0*([^;]*\d)[^~]*/~123456789743222111~$2$3/;
    s/(.(.)[^~]*)[^9]*\2.{8}(.)[^~]*/$3~$1/s;
    s {(\|\?.)}
  {$1SaSadSaKdlaZ+LaX-1+[sb1]Sbd1>bkLatsbLa[dSa2lbla*-*dLa!=a]dSaxsakLasbLb*t};
    next;

  Rem:
    s,\|\?%,|?%Sadla/LaKSa[999]k*Lak-,;
    next;

  Exp:
    # This decimal method is just a little faster than the binary method done
    # totally in dc:  1LaKLb [kdSb*LbK]Sb [[.5]*d0ktdSa<bkd*KLad1<a]Sa d1<a kk*
    warn "fraction in exponent ignored\n"  if /^[^~]*\./;
    s,[^-\d].*,;9d**dd*8*d*d7dd**d*6d**d5d*d*4*d3d*2lbd**1lb*0,s;
    1 while
	s/(\d);(.*\1([d*]*)[^l]*([^*]*)(\**))/;dd*d**d*$4$3$5$2/;
    $_ .= "\n"; $_ .= $hold;
    s,-*.{9}([^9]*)[^0]*0.(.*\|\?.),$2~saSaKdsaLb0kLbkK*+k1$1LaktsbkLax,s;
    s{(\|\?.)}
     {$1SadSbdXSaZla-SbKLaLadSb[0Lb-d1lb-*d+K+0kkSb[1Lb/]q]Sa0>a[dk]sadK<a[Lb]};
    next;

  Sqrt:
    #  first square root using sed:  8k2v at 1:30am Dec 17, 1996
    warn "square root of negative number\n"  if /^-/;
    next  if /^[-0]/;
    s/~.*//s;
    /^\./ ? s/0(\d)/$1/g : s/\d\d/7/g;
    $_ .= "~"; $_ .= $hold;
    s{(\|\?.)}
     {$1KSbSb[dk]SadXdK<asadlb/lb+[.5]*[sbdlb/lb+[.5]*dlb>a]dsaxsasaLbsaLatLbk};

    #  work around 0k16v17v195v224v precision glitch found by Ken Pizzini
    /^\d*~.*\|K0/s && s/(\|\?.KSb)([^t]*)/${1}1k${2}0k/;
    next;
}

#  END OF GSU dc.sed  [dc.pl]