@prog bank.muf
1 9999 d
1 i
$def prop-balance "@bank/balance"
$def prop-time "@bank/time"
$def prop-cmdline "@bank/cmdline"
: say me @ swap notify ;
: isay me @ prop-cmdline getpropstr if pop else say then ;
: bank-read
	me @ prop-cmdline getpropstr dup if
		dup "/" instr dup if
			1 - strcut 1 strcut swap pop
			me @ prop-cmdline rot addprop
		else
			pop me @ prop-cmdline "" addprop
		then
		swap over strcat say
	else
		pop pop
		1 read dup string? if swap pop exit then
		0 sleep daemon kill
	then
;
(A "flt" is a floating-point value, represented as three integers on the
 stack.  If they are, deepest first, A B C, then the number represented
 is [[B*2^30]+C] * 2^A.  Note that there are no hidden bits, and zero
 is represented with B and C both zero.  Negative numbers are represented
 as A B -[C+1], where A B C represent the absolute value as above.  Only
 the low 30 bits of B and C are significant, and except for zero, the
 highest significant bit of B is always 1.  A "dbl" is the same thing,
 except there are four ints of mantissa: A B C D E represents
 [[B*2^90]+[C*2^60]+[D*2^30]+E] * 2^A, with the sign being carried on E.
 Note that in both cases the implied binary point is at the far right end
 of the mantissa.)
$def mantissa-mask 1073741823 (0x3fffffff)
( $def neg -1 * )
( : /% over over / rot rot % ; )
( : %/ over over % rot rot / ; )
$def %/ /% swap
: mneg 1 + -1 * ;
: noop nop ;
: shift-flt-mantissa-left-small (B C n -- B C)
	rot over << 3 pick 30 4 pick - >> | mantissa-mask &
	rot rot << mantissa-mask &
;
: shift-dbl-mantissa-left-small (B C D E n -- B C D E)
	30 over -
	0 1 4 1 for pop
		4 rotate dup 5 pick << rot | mantissa-mask & -7 rotate over >>
	loop
	pop pop pop
;
: shift-flt-mantissa-left-large (B C n -- B C)
	30 - rot pop << mantissa-mask & 0
;
: shift-flt-mantissa-left (B C n -- B C)
	dup 30 >= if
		shift-flt-mantissa-left-large
	else
		shift-flt-mantissa-left-small
	then
;
: shift-flt-mantissa-right-small (B C n -- B C)
	swap over >> 3 pick 30 4 pick - << | mantissa-mask &
	rot rot >> swap
;
: shift-flt-mantissa-right-large (B C n -- B C)
	30 - swap pop >> 0 swap
;
: shift-flt-mantissa-right (B C n -- B C)
	dup 30 >= if
		shift-flt-mantissa-right-large
	else
		shift-flt-mantissa-right-small
	then
;
: normalize-flt-shift (A B C n -- A B C)
	3 pick 1073741823 (0x3fffffff) 3 pick >> ~ 1073741823 (0x3fffffff) & & not if
		4 rotate over - -4 rotate shift-flt-mantissa-left-small
	else
		pop
	then
;
: normalize-flt (A B C -- A B C)
	over over or not if pop pop pop 0 0 0 exit then
	dup 0 < if mneg ' mneg else ' noop then -4 rotate
	(signfix A B C)
	over not if swap rot 30 - rot rot then
	15 normalize-flt-shift
	8 normalize-flt-shift
	4 normalize-flt-shift
	2 normalize-flt-shift
	1 normalize-flt-shift
	4 rotate exec
;
: normalize-dbl-shift (A B C D E n -- A B C D E)
	5 pick 1073741823 (0x3fffffff) 3 pick >> ~ 1073741823 (0x3fffffff) & & not if
		6 rotate over - -6 rotate shift-dbl-mantissa-left-small
	else
		pop
	then
;
: normalize-dbl (A B C D E -- A B C D E)
	over over or 4 pick or 5 pick or not if
		pop pop pop pop pop 0 0 0 0 0 exit
	then
	dup 0 < if mneg ' mneg else ' noop then -6 rotate
	(signfix A B C D E)
	begin 4 pick not while 4 rotate 5 rotate 30 - -5 rotate loop
	15 normalize-dbl-shift
	8 normalize-dbl-shift
	4 normalize-dbl-shift
	2 normalize-dbl-shift
	1 normalize-dbl-shift
	6 rotate exec
;
: int-to-flt 0 0 rot dup 0 < if 1 - then normalize-flt ;
: div-flt-by-int (A B C int -- A B C)
	(assumes int is < 2^28 or so)
	(A B C i)
	over 4 pick or not if pop exit then
	dup 0 < if neg swap mneg swap then
	over 0 < if swap mneg swap ' mneg else ' noop then -5 rotate
	(signfix A B C i)
	rot over /% 4 rotate 0 -4 rotate
	(signfix A i qB qC rB rC)
	begin
		over over or
	while
		4 pick 536870912 (0x20000000) <
	while
		4 2 roll 1 shift-flt-mantissa-left-small 4 2 roll
		1 shift-flt-mantissa-left-small
		6 rotate 1 - -6 rotate
		over 6 pick >= if swap 5 pick - swap rot 1 + rot rot then
	loop
	(signfix A i qB qC rB rC)
	(to round, check remainder vs i and maybe increment quotient)
	pop pop (truncate - discard remainder)
	rot pop rot 30 + rot rot 4 rotate exec
;
: perform-flt-add (A B1 C1 B2 C2 -- A B C)
	rot + dup 1073741824 (0x40000000) & if
		1073741824 (0x40000000) - swap 1 + swap
	then
	rot rot + dup 1073741824 (0x40000000) & if
		swap 1 shift-flt-mantissa-right-small
		rot 1 + rot rot
	else
		swap
	then
;
: perform-flt-sub (A B1 C1 B2 C2 -- A B C)
	(subtracts B2/C2 from B1/C1)
	rot swap - dup 0 < if
		1073741824 (0x40000000) + swap 1 + swap
	then
	rot rot - dup 0 < if
		neg over if
			1 - swap 1073741825 (0x40000001) -
		else
			swap pop -1
		then
	else
		swap
	then
	normalize-flt
;
: add-flt-to-flt (A1 B1 C1 A2 B2 C2 -- A B C)
	over over or not if pop pop pop exit then
	5 pick 5 pick or not if 6 3 roll pop pop pop exit then
	6 pick 4 pick -
	dup 0 < if 7 -3 roll 4 rotate neg then
	4 rotate pop
	dup 60 >= if pop pop pop exit then
	over 0 < if
		swap mneg swap shift-flt-mantissa-right mneg
	else
		shift-flt-mantissa-right
	then
	3 pick 0 < if
		rot mneg rot rot
		dup 0 < if
			mneg perform-flt-add mneg
		else
			perform-flt-sub mneg
		then
	else
		dup 0 < if
			mneg perform-flt-sub
		else
			perform-flt-add
		then
	then
;
: explode-mantissa-n (X -- Xa Xb Xc)
	mantissa-mask &
	dup 20 >> swap
	dup 10 >> 1023 (0x3ff) & swap
	1023 (0x3ff) &
;
: explode-flt-mantissa (B C -- Ba Bb Bc Ca Cb Cc)
	swap explode-mantissa-n 4 rotate explode-mantissa-n
;
: add-int-to-dbl-mantissa (B C D E i -- B C D E)
	(assumes no overflow)
	+ 2 swap
	begin
		dup 1073741824 (0x40000000) &
	while
		1073741824 (0x40000000) - over neg rotate 1 + dup rotate 1 +
	loop
	over neg rotate pop
;
: mult-flt-by-flt (A1 B1 C1 A2 B2 C2 -- A B C)
	4 pick 0 < if 4 rotate mneg -4 rotate 1 else 0 then
	over 0 < if not swap mneg swap then
	-7 rotate
	(sign A1 B1 C1 A2 B2 C2)
	rot 6 rotate + 60 + -5 rotate
	explode-flt-mantissa 8 -2 roll explode-flt-mantissa
	0 0 0 0
	(sign A B2a B2b B2c C2a C2b C2c B1a B1b B1c C1a C1b C1c Bp Cp Dp Ep)
	32 27 -1 for
		0
		13 3 pick 19 - -1 for
			3 pick over - pick swap pick * +
		loop
		swap pop
		-5 rotate 10 shift-dbl-mantissa-left-small 5 rotate
		add-int-to-dbl-mantissa
	loop
	26 22 -1 for
		0
		8 3 pick 14 - 1 for
			3 pick over - pick swap pick * +
		loop
		swap pop
		-5 rotate 10 shift-dbl-mantissa-left-small 5 rotate
		add-int-to-dbl-mantissa
	loop
	16 4 roll 1 12 1 for pop pop loop
	normalize-dbl pop pop 4 rotate if mneg then
;
: mult-flt-by-int (A B C i -- A B C)
	(cheat - should do something more efficient than this)
	int-to-flt mult-flt-by-flt
;
: flt-to-int-trunc (A B C -- i)
	dup 0 < if mneg -1 else 1 then -4 rotate
	rot 60 +
	dup 1 < if pop pop pop pop 0 exit then
	60 swap - shift-flt-mantissa-right swap pop *
;
: flt-to-str (A B C -- s)
	dup 0 < if mneg "-" else "" then -4 rotate
	3 pick 3 pick 3 pick flt-to-int-trunc
	dup intostr "." strcat 6 rotate swap strcat -5 rotate
	neg int-to-flt add-flt-to-flt
	1 10 1 for pop
		10 int-to-flt
		mult-flt-by-flt
		3 pick 3 pick 3 pick flt-to-int-trunc
		dup intostr 6 rotate swap strcat -5 rotate
		neg int-to-flt
		add-flt-to-flt
	loop
	pop pop pop
;
: unpack-fltstr (s -- A B C)
	dup not if pop 0 0 0 exit then
	10 strcut 10 strcut atoi dup 1 & if -1 else 1 then swap 1 >> *
	rot atoi rot atoi swap
;
: pad-to-10
	begin dup strlen 10 < while "0" swap strcat loop
;
: pack-fltstr (A B C -- s)
	over over or not if pop pop pop "" exit then
	intostr pad-to-10 swap intostr pad-to-10 strcat swap
	dup 0 < if neg 1 else 0 then over + + intostr strcat
;
: compute-interest-factor
	(computes 1.00175^[n/86400])
	(magic numbers are 1.00175^[x/86400] where x is the number &ed with)
	1 int-to-flt
	4 pick          1 & if -59  536870922  928376316 mult-flt-by-flt then
	4 pick          2 & if -59  536870933  783011045 mult-flt-by-flt then
	4 pick          4 & if -59  536870955  492281210 mult-flt-by-flt then
	4 pick          8 & if -59  536870998  984566198 mult-flt-by-flt then
	4 pick         16 & if -59  536871085  895405681 mult-flt-by-flt then
	4 pick         32 & if -59  536871259  717129973 mult-flt-by-flt then
	4 pick         64 & if -59  536871607  360759869 mult-flt-by-flt then
	4 pick        128 & if -59  536872302  722486722 mult-flt-by-flt then
	4 pick        256 & if -59  536873693  375099563 mult-flt-by-flt then
	4 pick        512 & if -59  536876474  765670934 mult-flt-by-flt then
	4 pick       1024 & if -59  536882037  519487597 mult-flt-by-flt then
	4 pick       2048 & if -59  536893163  212786151 mult-flt-by-flt then
	4 pick       4096 & if -59  536915415  342062117 mult-flt-by-flt then
	4 pick       8192 & if -59  536959922  350247666 mult-flt-by-flt then
	4 pick      16384 & if -59  537048947  440044310 mult-flt-by-flt then
	4 pick      32768 & if -59  537227041  922535306 mult-flt-by-flt then
	4 pick      65536 & if -59  537583407 1025211520 mult-flt-by-flt then
	4 pick     131072 & if -59  538296849  517886934 mult-flt-by-flt then
	4 pick     262144 & if -59  539726574  297151524 mult-flt-by-flt then
	4 pick     524288 & if -59  542597426   70074125 mult-flt-by-flt then
	4 pick    1048576 & if -59  548385021  842475785 mult-flt-by-flt then
	4 pick    2097152 & if -59  560146071  253455598 mult-flt-by-flt then
	4 pick    4194304 & if -59  584430286  951879920 mult-flt-by-flt then
	4 pick    8388608 & if -59  636202767  988063346 mult-flt-by-flt then
	4 pick   16777216 & if -59  753913003  840124755 mult-flt-by-flt then
	4 pick   33554432 & if -59 1058699222  846823099 mult-flt-by-flt then
	4 pick   67108864 & if -58 1043867361  119117858 mult-flt-by-flt then
	4 pick  134217728 & if -56 1014824088  304455150 mult-flt-by-flt then
	4 pick  268435456 & if -52  959139252  248054624 mult-flt-by-flt then
	4 pick  536870912 & if -44  856768437  880268951 mult-flt-by-flt then
	4 pick 1073741824 & if -28  683639343  933223449 mult-flt-by-flt then
	4 rotate pop
;
: update-balance (player set-if-none? -- )
	over prop-time prop-exists? if
		pop systime dup 3 pick prop-time getpropstr atoi -
		compute-interest-factor
		5 pick prop-balance getpropstr unpack-fltstr
		mult-flt-by-flt pack-fltstr 3 pick prop-balance rot addprop
		over prop-time rot intostr addprop
	else
		if dup prop-time systime intostr addprop then
		dup prop-balance remove_prop
	then
	pop
;
: current-balance-flt (player -- A B C)
	prop-balance getpropstr unpack-fltstr
;
: current-balance (player -- amount)
	current-balance-flt flt-to-int-trunc
;
: change-account (player amount -- )
	over prop-balance getpropstr unpack-fltstr
	4 rotate int-to-flt add-flt-to-flt
	3 pick 3 pick 3 pick flt-to-int-trunc if
		pack-fltstr swap prop-balance rot addprop
	else
		pop pop pop dup prop-balance remove_prop prop-time remove_prop
	then
;
: withdraw
	me @ 0 update-balance me @ current-balance
	dup not if "There is no money in your account!" say pop exit then
	"How much would you like to withdraw?  (0 to " over intostr ")"
	strcat strcat isay "[withdraw amount] " bank-read
	"" "," subst "" "$" subst atoi
	dup 0 < if
		"If you wish to increase your account, please choose Deposit."
		say pop pop exit
	then
	over over < if
		"Your account doesn't contain that much!" say pop pop exit
	then
	me @ over addpennies
	neg me @ swap change-account
	"Withdrawn." say pop
;
: deposit
	"How much would you like to deposit?  (0 to " me @ pennies intostr ")"
	strcat strcat isay "[deposit amount] " bank-read
	"" "," subst "" "$" subst atoi
	dup 0 < if
		"If you wish to increase your money, please choose Withdraw."
		say pop exit
	then
	dup me @ pennies > if
		"You don't have that much!" say pop exit
	then
	me @ 1 update-balance
	dup me @ swap change-account
	neg me @ swap addpennies
	"Deposited." say
;
: deposit-another
	"How much would you like to deposit?  (0 to " me @ pennies intostr ")"
	strcat strcat isay "[deposit amount] " bank-read
	"" "," subst "" "$" subst atoi
	dup 0 < if
		"If you wish to increase your money, please choose Withdraw."
		say pop exit
	then
	dup me @ pennies > if
		"You don't have that much!" say pop exit
	then
	"Into whose account do you wish to deposit it?" isay
	"[deposit to account of] " bank-read
	"*" swap strcat match dup player? not if
		"I don't recognize that player name." say pop pop exit
	then
	dup 1 update-balance
	over change-account
	neg me @ swap addpennies
	"Deposited." say
;
: balance
	me @ 0 update-balance
	"Your current balance: $"
	me @ current-balance intostr strcat "." strcat say
;
: goodbye
	"Thank you for banking with Capital Savings!" isay
;
: wiz-view
	"Whose account do you wish to view?" isay
	"[view account of] " bank-read
	"*" swap strcat match dup player? not if
		"I don't recognize that player name." say pop exit
	then
	dup 0 update-balance
	dup name "'s current balance: $" strcat
	swap current-balance-flt flt-to-str strcat "." strcat say
;
: wiz-change
	"Whose account do you wish to change?" isay
	"[change account of] " bank-read
	"*" swap strcat match dup player? not if
		"I don't recognize that player name." say pop exit
	then
	dup 1 update-balance
	dup name "'s current balance: $" strcat
	over current-balance intostr strcat "." strcat say
	"How much do you wish to change it by?" isay
	"[change account by] " bank-read atoi
	change-account
	"Changed." say
;
: wiz-set
	"Whose account do you wish to set?" isay
	"[set account of] " bank-read
	"*" swap strcat match dup player? not if
		"I don't recognize that player name." say pop exit
	then
	dup 1 update-balance
	dup name "'s current balance: $" strcat
	over current-balance intostr strcat "." strcat say
	"What do you wish to set it to?" isay
	"[set account to] " bank-read
	dup atoi dup intostr 3 pick strcmp if
		"Not changed." say pop pop pop exit
	then
	swap pop
	dup not if
		pop
		dup prop-balance remove_prop
		prop-time remove_prop
		"Cleared."
	else
		int-to-flt pack-fltstr prop-balance swap addprop
		"Set."
	then
	say
;
: wizoptions
	"[V]iew account, [C]hange account, or [S]et account?" isay
	"[wiz cmd] " bank-read 1 strcut pop tolower
	dup "v" strcmp not if pop wiz-view exit then
	dup "c" strcmp not if pop wiz-change exit then
	dup "s" strcmp not if pop wiz-set exit then
	pop "(No action taken.)" say
;
: do-main-menu-once
	"Do you want to [D]eposit, [W]ithdraw, see your [B]alance," isay
	"deposit into [A]nother player's account, or [Q]uit?" isay
	me @ wizard? if
		"(wi[Z]ard options also available)" isay
	then
	1 "[cmd] " bank-read 1 strcut pop tolower
	dup "d" strcmp not if pop deposit exit then
	dup "a" strcmp not if pop deposit-another exit then
	dup "w" strcmp not if pop withdraw exit then
	dup "b" strcmp not if pop balance exit then
	dup "q" strcmp not if pop goodbye pop 0 exit then
	me @ wizard? if
		dup "z" strcmp not if pop wizoptions exit then
	then
	pop
;
: intro
	"Welcome to Mouse's Capital Savings Bank!" isay
	"Now, with interest compounded _every second_!" isay
;
: reset-me "me" match me ! ;
: save-cmdline me @ prop-cmdline rot addprop ;
: destroy-cmdline me @ prop-cmdline remove_prop ;
: depthcheck
	depth if depth pstack begin depth while pop loop then
;
: main
	save-cmdline
	reset-me
	intro
	begin depthcheck do-main-menu-once while loop
	destroy-cmdline
;
.
c
q