extra/bank/bank.factor

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