From 8db19c2ee5cb6e144d417084357d56a3631d1062 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:21:16 -0600 Subject: [PATCH 1/6] add ?first2 --- extra/sequences/lib/lib.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 048d63dc64..1d95f9fdf6 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -178,6 +178,10 @@ PRIVATE> : ?third ( seq -- third/f ) 2 swap ?nth ; inline : ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline +: ?first2 ( seq -- 1st/f 2nd/f ) dup ?first swap ?second ; inline +: ?first3 ( seq -- 1st/f 2nd/f 3rd/f ) dup ?first2 rot ?third ; inline +: ?first4 ( seq -- 1st/f 2nd/f 3rd/f 4th/f ) dup ?first3 roll ?fourth ; inline + : accumulator ( quot -- quot vec ) V{ } clone [ [ push ] curry compose ] keep ; From 0699bacf86e862dcc569c4fca0eff907c420d40d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:21:59 -0600 Subject: [PATCH 2/6] add money library --- extra/money/authors.txt | 2 ++ extra/money/money-tests.factor | 21 +++++++++++++++++++++ extra/money/money.factor | 29 +++++++++++++++++++++++++++++ extra/money/summary.txt | 1 + 4 files changed, 53 insertions(+) create mode 100644 extra/money/authors.txt create mode 100644 extra/money/money-tests.factor create mode 100644 extra/money/money.factor create mode 100644 extra/money/summary.txt diff --git a/extra/money/authors.txt b/extra/money/authors.txt new file mode 100644 index 0000000000..5674120196 --- /dev/null +++ b/extra/money/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Slava Pestov diff --git a/extra/money/money-tests.factor b/extra/money/money-tests.factor new file mode 100644 index 0000000000..19d6b6c2aa --- /dev/null +++ b/extra/money/money-tests.factor @@ -0,0 +1,21 @@ +USING: money parser tools.test ; +IN: temporary + +[ -1/10 ] [ DECIMAL: -.1 ] unit-test +[ -1/10 ] [ DECIMAL: -0.1 ] unit-test +[ -1/10 ] [ DECIMAL: -00.10 ] unit-test + +[ 0 ] [ DECIMAL: .0 ] unit-test +[ 0 ] [ DECIMAL: 0.0 ] unit-test +[ 0 ] [ DECIMAL: 0. ] unit-test +[ 0 ] [ DECIMAL: 0 ] unit-test +[ 1/10 ] [ DECIMAL: .1 ] unit-test +[ 1/10 ] [ DECIMAL: 0.1 ] unit-test +[ 1/10 ] [ DECIMAL: 00.10 ] unit-test + + + +[ "DECIMAL: ." eval ] must-fail +[ "DECIMAL: f" eval ] must-fail +[ "DECIMAL: 0.f" eval ] must-fail +[ "DECIMAL: f.0" eval ] must-fail diff --git a/extra/money/money.factor b/extra/money/money.factor new file mode 100644 index 0000000000..d742a3be5a --- /dev/null +++ b/extra/money/money.factor @@ -0,0 +1,29 @@ +USING: io kernel math math.functions math.parser parser +namespaces sequences splitting combinators continuations +sequences.lib ; +IN: money + +: dollars/cents ( dollars -- dollars cents ) + 100 * 100 /mod round ; + +: money. ( object -- ) + dollars/cents + [ + "$" % + swap number>string + 3 group "," join % + "." % number>string 2 48 pad-left % + ] "" make print ; + +TUPLE: not-a-decimal ; +: DECIMAL: + scan + "." split dup length 1 2 between? [ + T{ not-a-decimal } throw + ] unless + ?first2 + >r dup ?first CHAR: - = [ drop t "0" ] [ f swap ] if r> + [ dup empty? [ drop "0" ] when ] 2apply + dup length + >r [ string>number dup [ T{ not-a-decimal } throw ] unless ] 2apply r> + 10 swap ^ / + swap [ neg ] when parsed ; parsing diff --git a/extra/money/summary.txt b/extra/money/summary.txt new file mode 100644 index 0000000000..fcfaf151f6 --- /dev/null +++ b/extra/money/summary.txt @@ -0,0 +1 @@ +Utility for calculating money with rationals From 0e9ec0dd6a4a4c62ea3afcf99a36ce4f330cf150 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:27:22 -0600 Subject: [PATCH 3/6] Add taxes library --- extra/taxes/authors.txt | 1 + extra/taxes/summary.txt | 1 + extra/taxes/taxes-tests.factor | 98 +++++++++++++++++++++++ extra/taxes/taxes.factor | 140 +++++++++++++++++++++++++++++++++ 4 files changed, 240 insertions(+) create mode 100644 extra/taxes/authors.txt create mode 100644 extra/taxes/summary.txt create mode 100644 extra/taxes/taxes-tests.factor create mode 100644 extra/taxes/taxes.factor diff --git a/extra/taxes/authors.txt b/extra/taxes/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/taxes/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/taxes/summary.txt b/extra/taxes/summary.txt new file mode 100644 index 0000000000..e983139ccb --- /dev/null +++ b/extra/taxes/summary.txt @@ -0,0 +1 @@ +Calculate federal and state tax withholdings diff --git a/extra/taxes/taxes-tests.factor b/extra/taxes/taxes-tests.factor new file mode 100644 index 0000000000..4091156558 --- /dev/null +++ b/extra/taxes/taxes-tests.factor @@ -0,0 +1,98 @@ +USING: kernel money taxes tools.test ; +IN: temporary + +[ + 426 23 +] [ + 12000 2008 3 f net biweekly + dollars/cents +] unit-test + +[ + 426 23 +] [ + 12000 2008 3 t net biweekly + dollars/cents +] unit-test + +[ + 684 4 +] [ + 20000 2008 3 f net biweekly + dollars/cents +] unit-test + + + +[ + 804 58 +] [ + 24000 2008 3 f net biweekly + dollars/cents +] unit-test + +[ + 831 31 +] [ + 24000 2008 3 t net biweekly + dollars/cents +] unit-test + + +[ + 780 81 +] [ + 24000 2008 3 f net biweekly + dollars/cents +] unit-test + +[ + 818 76 +] [ + 24000 2008 3 t net biweekly + dollars/cents +] unit-test + + +[ + 2124 39 +] [ + 78250 2008 3 f net biweekly + dollars/cents +] unit-test + +[ + 2321 76 +] [ + 78250 2008 3 t net biweekly + dollars/cents +] unit-test + + +[ + 2612 63 +] [ + 100000 2008 3 f net biweekly + dollars/cents +] unit-test + +[ + 22244 52 +] [ + 1000000 2008 3 f net biweekly + dollars/cents +] unit-test + +[ + 578357 40 +] [ + 1000000 2008 3 f net + dollars/cents +] unit-test + +[ + 588325 41 +] [ + 1000000 2008 3 t net + dollars/cents +] unit-test diff --git a/extra/taxes/taxes.factor b/extra/taxes/taxes.factor new file mode 100644 index 0000000000..0f51d7ab6a --- /dev/null +++ b/extra/taxes/taxes.factor @@ -0,0 +1,140 @@ +USING: arrays assocs kernel math math.intervals namespaces +sequences combinators.lib money ; +IN: taxes + +: monthly ( x -- y ) 12 / ; +: semimonthly ( x -- y ) 24 / ; +: biweekly ( x -- y ) 26 / ; +: weekly ( x -- y ) 52 / ; +: daily ( x -- y ) 360 / ; + +! Each employee fills out a w4 +TUPLE: w4 year allowances married? ; +C: w4 + +: allowance ( -- x ) 3500 ; inline + +: calculate-w4-allowances ( w4 -- x ) + w4-allowances allowance * ; + +! Withhold: FICA, Medicare, Federal (FICA is social security) +: fica-tax-rate ( -- x ) DECIMAL: .062 ; inline + +! Base rate -- income over this rate is not taxed +TUPLE: fica-base-unknown ; +: fica-base-rate ( year -- x ) + H{ + { 2008 102000 } + { 2007 97500 } + } at* [ T{ fica-base-unknown } throw ] unless ; + +: fica-tax ( salary w4 -- x ) + w4-year fica-base-rate min fica-tax-rate * ; + +! Employer tax only, not withheld +: futa-tax-rate ( -- x ) DECIMAL: .062 ; inline + +! No base rate for medicare; all wages subject +: medicare-tax-rate ( -- x ) DECIMAL: .0145 ; inline +: medicare-tax ( salary w4 -- x ) drop medicare-tax-rate * ; + +MIXIN: collector +GENERIC: adjust-allowances ( salary w4 collector -- newsalary ) +GENERIC: withholding ( salary w4 collector -- x ) +GENERIC: net ( salary w4 collector -- x ) + +TUPLE: tax-table single married ; + +: ( single married class -- obj ) + >r tax-table construct-boa r> construct-delegate ; + +: tax-bracket-range dup second swap first - ; + +: tax-bracket ( tax salary triples -- tax salary ) + [ [ tax-bracket-range min ] keep third * + ] 2keep + tax-bracket-range [-] ; + +: tax ( salary triples -- x ) + 0 -rot [ tax-bracket ] each drop ; + +: marriage-table ( w4 tax-table -- triples ) + swap w4-married? + [ tax-table-married ] [ tax-table-single ] if ; + +: federal-tax ( salary w4 tax-table -- n ) + [ adjust-allowances ] 2keep marriage-table tax ; + +! http://www.irs.gov/pub/irs-pdf/p15.pdf +! Table 7 ANNUAL Payroll Period + +: federal-single ( -- triples ) + { + { 0 2650 DECIMAL: 0 } + { 2650 10300 DECIMAL: .10 } + { 10300 33960 DECIMAL: .15 } + { 33960 79725 DECIMAL: .25 } + { 79725 166500 DECIMAL: .28 } + { 166500 359650 DECIMAL: .33 } + { 359650 1/0. DECIMAL: .35 } + } ; + +: federal-married ( -- triples ) + { + { 0 8000 DECIMAL: 0 } + { 8000 23550 DECIMAL: .10 } + { 23550 72150 DECIMAL: .15 } + { 72150 137850 DECIMAL: .25 } + { 137850 207700 DECIMAL: .28 } + { 207700 365100 DECIMAL: .33 } + { 365100 1/0. DECIMAL: .35 } + } ; + +TUPLE: federal ; +INSTANCE: federal collector +: ( -- obj ) + federal-single federal-married federal ; + +M: federal adjust-allowances ( salary w4 collector -- newsalary ) + drop calculate-w4-allowances - ; + +M: federal withholding ( salary w4 tax-table -- x ) + [ federal-tax ] 3keep drop + [ fica-tax ] 2keep + medicare-tax + + ; + +M: federal net ( salary w4 collector -- x ) + >r dupd r> withholding - ; + +M: collector net ( salary w4 collector -- x ) + >r dupd r> + [ withholding ] 3keep + drop withholding + - ; + + +! Minnesota +: minnesota-single ( -- triples ) + { + { 0 1950 DECIMAL: 0 } + { 1950 23750 DECIMAL: .0535 } + { 23750 73540 DECIMAL: .0705 } + { 73540 1/0. DECIMAL: .0785 } + } ; + +: minnesota-married ( -- triples ) + { + { 0 7400 DECIMAL: 0 } + { 7400 39260 DECIMAL: .0535 } + { 39260 133980 DECIMAL: .0705 } + { 133980 1/0. DECIMAL: .0785 } + } ; + +TUPLE: minnesota ; +INSTANCE: minnesota collector +: ( -- obj ) + minnesota-single minnesota-married minnesota ; + +M: minnesota adjust-allowances ( salary w4 collector -- newsalary ) + drop calculate-w4-allowances - ; + +M: minnesota withholding ( salary w4 collector -- x ) + [ adjust-allowances ] 2keep marriage-table tax ; From 34c1170963820b19c728453d00c46ba870443b2a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:27:40 -0600 Subject: [PATCH 4/6] add a few utility words --- extra/html/parser/analyzer/analyzer.factor | 35 +++++++++------------- 1 file changed, 14 insertions(+), 21 deletions(-) diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index e4f11cd91e..dcfbd1e197 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,5 +1,5 @@ -USING: assocs html.parser kernel math sequences strings unicode.categories - unicode.case ; +USING: assocs html.parser kernel math sequences strings ascii +arrays shuffle unicode.case namespaces ; IN: html.parser.analyzer : remove-blank-text ( vector -- vector' ) @@ -65,28 +65,21 @@ IN: html.parser.analyzer [ tag-attributes "href" swap at ] map [ ] subset ; +: (find-all) ( n seq quot -- ) + 2dup >r >r find* [ + dupd 2array , 1+ r> r> (find-all) + ] [ + r> r> 3drop + ] if* ; +: find-all ( seq quot -- alist ) + [ 0 -rot (find-all) ] { } make ; -! : find-last-tag ( name vector -- index tag ) - ! [ - ! dup tag-matched? [ 2drop f ] [ tag-name = ] if - ! ] with find-last ; +: find-opening-tags-by-name ( name seq -- seq ) + [ [ tag-name = ] keep tag-closing? not and ] with find-all ; -! : find-last-tag* ( name n vector -- tag ) - ! 0 -rot find-last-tag ; +: href-contains? ( str tag -- ? ) + tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ; -! : find-matching-tag ( tag -- tag ) - ! dup tag-closing? [ - ! find-last-tag - ! ] [ - ! ] if ; - - -! clear "/Users/erg/web/fark.html" file-contents parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map ! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map -! clear "/Users/erg/web/hostels.html" file-contents parse-html "Currency" "name" pick find-first-attribute-key-value - -! clear "/Users/erg/web/hostels.html" file-contents parse-html -! "Currency" "name" pick find-first-attribute-key-value -! pick find-between remove-blank-text From a345d4fc37e8142b2c91f14c1fdae2c2e5bb15a5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:32:36 -0600 Subject: [PATCH 5/6] delete a couple files in misc/Factor.tmbundle --- .../Commands/Eval Selection:Line.tmCommand | 27 ------------------- .../Run Selection:Line in Listener.tmCommand | 27 ------------------- 2 files changed, 54 deletions(-) delete mode 100644 misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand delete mode 100644 misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand diff --git a/misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand b/misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand deleted file mode 100644 index 37867a2737..0000000000 --- a/misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand +++ /dev/null @@ -1,27 +0,0 @@ - - - - - beforeRunningCommand - nop - command - #!/usr/bin/env ruby - -require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor" -puts factor_eval(STDIN.read) - fallbackInput - line - input - selection - keyEquivalent - ^E - name - Eval Selection/Line - output - replaceSelectedText - scope - source.factor - uuid - 8E01DDAF-959B-4237-ADB9-C133A4ACCE90 - - diff --git a/misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand b/misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand deleted file mode 100644 index 5028bd8db3..0000000000 --- a/misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand +++ /dev/null @@ -1,27 +0,0 @@ - - - - - beforeRunningCommand - nop - command - #!/usr/bin/env ruby - -require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor" -factor_run(STDIN.read) - fallbackInput - line - input - selection - keyEquivalent - ^~e - name - Run Selection/Line in Listener - output - discard - scope - source.factor - uuid - 15A984BD-BC65-43E8-878A-267788C8DA70 - - From 008da8a6baf32758726e55d4217008c1514b5e7b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:45:38 -0600 Subject: [PATCH 6/6] cleanup on aisle DECIMAL: --- extra/money/money.factor | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/extra/money/money.factor b/extra/money/money.factor index d742a3be5a..4058ee9e6a 100644 --- a/extra/money/money.factor +++ b/extra/money/money.factor @@ -12,18 +12,21 @@ IN: money "$" % swap number>string 3 group "," join % - "." % number>string 2 48 pad-left % + "." % number>string 2 CHAR: 0 pad-left % ] "" make print ; TUPLE: not-a-decimal ; -: DECIMAL: - scan - "." split dup length 1 2 between? [ - T{ not-a-decimal } throw - ] unless - ?first2 - >r dup ?first CHAR: - = [ drop t "0" ] [ f swap ] if r> + +: not-a-decimal ( -- * ) + T{ not-a-decimal } throw ; + +: parse-decimal ( str -- ratio ) + "." split1 + >r dup "-" head? [ drop t "0" ] [ f swap ] if r> [ dup empty? [ drop "0" ] when ] 2apply dup length - >r [ string>number dup [ T{ not-a-decimal } throw ] unless ] 2apply r> - 10 swap ^ / + swap [ neg ] when parsed ; parsing + >r [ string>number dup [ not-a-decimal ] unless ] 2apply r> + 10 swap ^ / + swap [ neg ] when ; + +: DECIMAL: + scan parse-decimal parsed ; parsing