factor: trim using lists

[factor.git] / extra / bank / bank.factor

diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor
index c9228bedd50faf65e91afba74a9b7c1898e05ef6..fc214e05e31f3ecd8ddb46f68162f1295dba9e92 100644 (file)
--- a/extra/bank/bank.factor
+++ b/extra/bank/bank.factor
@@ -1,33 +1,69 @@
-USING: accessors calendar kernel money new-slots sequences ;
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar kernel math math.order sequences ;
 IN: bank
 
-MIXIN: policy
-TUPLE: simple-policy interest-rate ;
-INSTANCE: simple-policy policy
-C: <simple-policy> simple-policy
+TUPLE: account name interest-rate interest-payment-day opening-date transactions unpaid-interest interest-last-paid ;
 
-GENERIC: interest-rate ( date account policy -- rate )
-M: simple-policy interest-rate 2nip interest-rate>> ;
-
-: daily-interest-rate ( date account policy -- rate )
-    pick days-in-year >r interest-rate r> / ;
-
-TUPLE: account name balance transactions ;
-
-: <account> ( name -- account )
-    0 V{ } clone account construct-boa ;
+: <account> ( name interest-rate interest-payment-day opening-date -- account )
+    V{ } clone 0 pick account boa ;
 
 TUPLE: transaction date amount description ;
-
 C: <transaction> transaction
 
 : >>transaction ( account transaction -- account )
     over transactions>> push ;
 
-: open-account ( date opening-balance name -- account )
-    <account> >r "Account Opened" <transaction> >>transaction ;
+: total ( transactions -- balance )
+    [ amount>> ] map-sum ;
+
+: balance>> ( account -- balance ) transactions>> total ;
+
+: open-account ( name interest-rate interest-payment-day opening-date opening-balance -- account )
+    [ [ <account> ] keep ] dip "Account Opened" <transaction> >>transaction ;
+
+: daily-rate ( yearly-rate day -- daily-rate )
+    days-in-year / ;
+
+: daily-rate>> ( account date -- rate )
+    [ interest-rate>> ] dip daily-rate ;
+
+: transactions-on-date ( account date -- transactions )
+    [ before? ] curry filter ;
+
+: balance-on-date ( account date -- balance )
+    transactions-on-date total ;
+
+: pay-interest ( account date -- )
+    over unpaid-interest>> "Interest Credit" <transaction>
+    >>transaction 0 >>unpaid-interest drop ;
+
+: interest-payment-day? ( account date -- ? )
+    day>> swap interest-payment-day>> = ;
+
+: ?pay-interest ( account date -- )
+    2dup interest-payment-day? [ pay-interest ] [ 2drop ] if ;
+
+: unpaid-interest+ ( account amount -- account )
+    over unpaid-interest>> + >>unpaid-interest ;
+
+: accumulate-interest ( account date -- )
+    [ dupd daily-rate>> over balance>> * unpaid-interest+ ] keep
+    >>interest-last-paid drop ;
+
+: process-day ( account date -- )
+    2dup accumulate-interest ?pay-interest ;
 
-: open-account-now ( opening-balance name -- account )
-    now -rot open-account ;
+: each-day ( ... quot: ( ... day -- ... ) start end -- ... )
+    2dup before? [
+        [ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day
+    ] [
+        3drop
+    ] if ; inline recursive
 
+: process-to-date ( account date -- account )
+    over interest-last-paid>> 1 days time+
+    [ [ dupd process-day ] ] 2dip swap each-day ;
 
+: inserting-transactions ( account transactions -- account )
+    [ [ date>> process-to-date ] keep >>transaction ] each ;