extra/taxes/usa/federal/federal.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs kernel math math.intervals
   4 namespaces sequences money math.order taxes.usa.fica
   5 taxes.usa.medicare taxes.usa taxes.usa.w4 ;
   6 IN: taxes.usa.federal
   7
   8 ! http://www.irs.gov/pub/irs-pdf/p15.pdf
   9 ! Table 7 ANNUAL Payroll Period
  10
  11 : federal-single ( -- triples )
  12     {
  13         {      0   2650 DECIMAL: 0   }
  14         {   2650  10300 DECIMAL: .10 }
  15         {  10300  33960 DECIMAL: .15 }
  16         {  33960  79725 DECIMAL: .25 }
  17         {  79725 166500 DECIMAL: .28 }
  18         { 166500 359650 DECIMAL: .33 }
  19         { 359650   1/0. DECIMAL: .35 }
  20     } ;
  21
  22 : federal-married ( -- triples )
  23     {
  24         {      0   8000 DECIMAL: 0   }
  25         {   8000  23550 DECIMAL: .10 }
  26         {  23550  72150 DECIMAL: .15 }
  27         {  72150 137850 DECIMAL: .25 }
  28         { 137850 207700 DECIMAL: .28 }
  29         { 207700 365100 DECIMAL: .33 }
  30         { 365100   1/0. DECIMAL: .35 }
  31     } ;
  32
  33 SINGLETON: federal
  34 : <federal> ( -- obj )
  35     federal federal-single federal-married <tax-table> ;
  36
  37 : federal-tax ( salary w4 tax-table -- n )
  38     [ adjust-allowances ] 2keep marriage-table tax ;
  39
  40 M: federal adjust-allowances* ( salary w4 collector entity -- newsalary )
  41     2drop calculate-w4-allowances - ;
  42
  43 M: federal withholding* ( salary w4 tax-table entity -- x )
  44     drop
  45     [ federal-tax ] 2keepd
  46     [ fica-tax ] 2keep
  47     medicare-tax + + ;
  48
  49 : total-withholding ( salary w4 tax-table -- x )
  50     dup entity>> dup federal = [
  51         withholding*
  52     ] [
  53         drop
  54         [ drop <federal> federal withholding* ]
  55         [ dup entity>> withholding* ] 3bi +
  56     ] if ;
  57
  58 : net ( salary w4 collector -- x )
  59     [ dupd ] dip total-withholding - ;