extra/bank/bank.factor

   1 USING: accessors calendar kernel math math.order money sequences ;
   2 IN: bank
   3
   4 TUPLE: account name interest-rate interest-payment-day opening-date transactions unpaid-interest interest-last-paid ;
   5
   6 : <account> ( name interest-rate interest-payment-day opening-date -- account )
   7     V{ } clone 0 pick account boa ;
   8
   9 TUPLE: transaction date amount description ;
  10 C: <transaction> transaction
  11
  12 : >>transaction ( account transaction -- account )
  13     over transactions>> push ;
  14
  15 : total ( transactions -- balance )
  16     0 [ amount>> + ] reduce ;
  17
  18 : balance>> ( account -- balance ) transactions>> total ;
  19
  20 : open-account ( name interest-rate interest-payment-day opening-date opening-balance -- account )
  21     >r [ <account> ] keep r> "Account Opened" <transaction> >>transaction ;
  22
  23 : daily-rate ( yearly-rate day -- daily-rate )
  24     days-in-year / ;
  25
  26 : daily-rate>> ( account date -- rate )
  27     [ interest-rate>> ] dip daily-rate ;
  28
  29 : transactions-on-date ( account date -- transactions )
  30     [ before? ] curry filter ;
  31
  32 : balance-on-date ( account date -- balance )
  33     transactions-on-date total ;
  34
  35 : pay-interest ( account date -- )
  36     over unpaid-interest>> "Interest Credit" <transaction>
  37     >>transaction 0 >>unpaid-interest drop ;
  38
  39 : interest-payment-day? ( account date -- ? )
  40     day>> swap interest-payment-day>> = ;
  41
  42 : ?pay-interest ( account date -- )
  43     2dup interest-payment-day? [ pay-interest ] [ 2drop ] if ;
  44
  45 : unpaid-interest+ ( account amount -- account )
  46     over unpaid-interest>> + >>unpaid-interest ;
  47
  48 : accumulate-interest ( account date -- )
  49     [ dupd daily-rate>> over balance>> * unpaid-interest+ ] keep
  50     >>interest-last-paid drop ;
  51
  52 : process-day ( account date -- )
  53     2dup accumulate-interest ?pay-interest ;
  54
  55 : each-day ( quot start end -- )
  56     2dup before? [
  57         >r dup >r over >r swap call r> r> 1 days time+ r> each-day
  58     ] [
  59         3drop
  60     ] if ;
  61
  62 : process-to-date ( account date -- account )
  63     over interest-last-paid>> 1 days time+
  64     [ dupd process-day ] spin each-day ;
  65
  66 : inserting-transactions ( account transactions -- account )
  67     [ [ date>> process-to-date ] keep >>transaction ] each ;