1 USING: accessors calendar kernel math math.order money sequences ;
4 TUPLE: account name interest-rate interest-payment-day opening-date transactions unpaid-interest interest-last-paid ;
6 : <account> ( name interest-rate interest-payment-day opening-date -- account )
7 V{ } clone 0 pick account boa ;
9 TUPLE: transaction date amount description ;
10 C: <transaction> transaction
12 : >>transaction ( account transaction -- account )
13 over transactions>> push ;
15 : total ( transactions -- balance )
16 0 [ amount>> + ] reduce ;
18 : balance>> ( account -- balance ) transactions>> total ;
20 : open-account ( name interest-rate interest-payment-day opening-date opening-balance -- account )
21 >r [ <account> ] keep r> "Account Opened" <transaction> >>transaction ;
23 : daily-rate ( yearly-rate day -- daily-rate )
26 : daily-rate>> ( account date -- rate )
27 [ interest-rate>> ] dip daily-rate ;
29 : before? ( date date -- ? ) <=> 0 < ;
31 : transactions-on-date ( account date -- transactions )
32 [ before? ] curry filter ;
34 : balance-on-date ( account date -- balance )
35 transactions-on-date total ;
37 : pay-interest ( account date -- )
38 over unpaid-interest>> "Interest Credit" <transaction>
39 >>transaction 0 >>unpaid-interest drop ;
41 : interest-payment-day? ( account date -- ? )
42 day>> swap interest-payment-day>> = ;
44 : ?pay-interest ( account date -- )
45 2dup interest-payment-day? [ pay-interest ] [ 2drop ] if ;
47 : unpaid-interest+ ( account amount -- account )
48 over unpaid-interest>> + >>unpaid-interest ;
50 : accumulate-interest ( account date -- )
51 [ dupd daily-rate>> over balance>> * unpaid-interest+ ] keep
52 >>interest-last-paid drop ;
54 : process-day ( account date -- )
55 2dup accumulate-interest ?pay-interest ;
57 : each-day ( quot start end -- )
59 >r dup >r over >r swap call r> r> 1 days time+ r> each-day
64 : process-to-date ( account date -- account )
65 over interest-last-paid>> 1 days time+
66 [ dupd process-day ] spin each-day ;
68 : inserting-transactions ( account transactions -- account )
69 [ [ date>> process-to-date ] keep >>transaction ] each ;