Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
ffcc11559f
|
|
@ -1,5 +1,5 @@
|
||||||
USING: assocs html.parser kernel math sequences strings unicode.categories
|
USING: assocs html.parser kernel math sequences strings ascii
|
||||||
unicode.case ;
|
arrays shuffle unicode.case namespaces ;
|
||||||
IN: html.parser.analyzer
|
IN: html.parser.analyzer
|
||||||
|
|
||||||
: remove-blank-text ( vector -- vector' )
|
: remove-blank-text ( vector -- vector' )
|
||||||
|
|
@ -65,28 +65,21 @@ IN: html.parser.analyzer
|
||||||
[ tag-attributes "href" swap at ] map
|
[ tag-attributes "href" swap at ] map
|
||||||
[ ] subset ;
|
[ ] 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 )
|
: find-opening-tags-by-name ( name seq -- seq )
|
||||||
! [
|
[ [ tag-name = ] keep tag-closing? not and ] with find-all ;
|
||||||
! dup tag-matched? [ 2drop f ] [ tag-name = ] if
|
|
||||||
! ] with find-last ;
|
|
||||||
|
|
||||||
! : find-last-tag* ( name n vector -- tag )
|
: href-contains? ( str tag -- ? )
|
||||||
! 0 -rot <slice> find-last-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 "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
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
Doug Coleman
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -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
|
||||||
|
|
@ -0,0 +1,32 @@
|
||||||
|
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
|
||||||
|
<reversed> 3 group "," join <reversed> %
|
||||||
|
"." % number>string 2 CHAR: 0 pad-left %
|
||||||
|
] "" make print ;
|
||||||
|
|
||||||
|
TUPLE: not-a-decimal ;
|
||||||
|
|
||||||
|
: 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 [ not-a-decimal ] unless ] 2apply r>
|
||||||
|
10 swap ^ / + swap [ neg ] when ;
|
||||||
|
|
||||||
|
: DECIMAL:
|
||||||
|
scan parse-decimal parsed ; parsing
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Utility for calculating money with rationals
|
||||||
|
|
@ -178,6 +178,10 @@ PRIVATE>
|
||||||
: ?third ( seq -- third/f ) 2 swap ?nth ; inline
|
: ?third ( seq -- third/f ) 2 swap ?nth ; inline
|
||||||
: ?fourth ( seq -- fourth/f ) 3 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 )
|
: accumulator ( quot -- quot vec )
|
||||||
V{ } clone [ [ push ] curry compose ] keep ;
|
V{ } clone [ [ push ] curry compose ] keep ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Doug Coleman
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Calculate federal and state tax withholdings
|
||||||
|
|
@ -0,0 +1,98 @@
|
||||||
|
USING: kernel money taxes tools.test ;
|
||||||
|
IN: temporary
|
||||||
|
|
||||||
|
[
|
||||||
|
426 23
|
||||||
|
] [
|
||||||
|
12000 2008 3 f <w4> <federal> net biweekly
|
||||||
|
dollars/cents
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
426 23
|
||||||
|
] [
|
||||||
|
12000 2008 3 t <w4> <federal> net biweekly
|
||||||
|
dollars/cents
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
684 4
|
||||||
|
] [
|
||||||
|
20000 2008 3 f <w4> <federal> net biweekly
|
||||||
|
dollars/cents
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
[
|
||||||
|
804 58
|
||||||
|
] [
|
||||||
|
24000 2008 3 f <w4> <federal> net biweekly
|
||||||
|
dollars/cents
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
831 31
|
||||||
|
] [
|
||||||
|
24000 2008 3 t <w4> <federal> net biweekly
|
||||||
|
dollars/cents
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
[
|
||||||
|
780 81
|
||||||
|
] [
|
||||||
|
24000 2008 3 f <w4> <minnesota> net biweekly
|
||||||
|
dollars/cents
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
818 76
|
||||||
|
] [
|
||||||
|
24000 2008 3 t <w4> <minnesota> net biweekly
|
||||||
|
dollars/cents
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
[
|
||||||
|
2124 39
|
||||||
|
] [
|
||||||
|
78250 2008 3 f <w4> <minnesota> net biweekly
|
||||||
|
dollars/cents
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
2321 76
|
||||||
|
] [
|
||||||
|
78250 2008 3 t <w4> <minnesota> net biweekly
|
||||||
|
dollars/cents
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
[
|
||||||
|
2612 63
|
||||||
|
] [
|
||||||
|
100000 2008 3 f <w4> <minnesota> net biweekly
|
||||||
|
dollars/cents
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
22244 52
|
||||||
|
] [
|
||||||
|
1000000 2008 3 f <w4> <minnesota> net biweekly
|
||||||
|
dollars/cents
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
578357 40
|
||||||
|
] [
|
||||||
|
1000000 2008 3 f <w4> <minnesota> net
|
||||||
|
dollars/cents
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
588325 41
|
||||||
|
] [
|
||||||
|
1000000 2008 3 t <w4> <minnesota> net
|
||||||
|
dollars/cents
|
||||||
|
] unit-test
|
||||||
|
|
@ -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> 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 ;
|
||||||
|
|
||||||
|
: <tax-table> ( 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
|
||||||
|
: <federal> ( -- obj )
|
||||||
|
federal-single federal-married federal <tax-table> ;
|
||||||
|
|
||||||
|
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 <federal> 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
|
||||||
|
: <minnesota> ( -- obj )
|
||||||
|
minnesota-single minnesota-married minnesota <tax-table> ;
|
||||||
|
|
||||||
|
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 ;
|
||||||
|
|
@ -1,27 +0,0 @@
|
||||||
<?xml version="1.0" encoding="UTF-8"?>
|
|
||||||
<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
|
|
||||||
<plist version="1.0">
|
|
||||||
<dict>
|
|
||||||
<key>beforeRunningCommand</key>
|
|
||||||
<string>nop</string>
|
|
||||||
<key>command</key>
|
|
||||||
<string>#!/usr/bin/env ruby
|
|
||||||
|
|
||||||
require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
|
|
||||||
puts factor_eval(STDIN.read)</string>
|
|
||||||
<key>fallbackInput</key>
|
|
||||||
<string>line</string>
|
|
||||||
<key>input</key>
|
|
||||||
<string>selection</string>
|
|
||||||
<key>keyEquivalent</key>
|
|
||||||
<string>^E</string>
|
|
||||||
<key>name</key>
|
|
||||||
<string>Eval Selection/Line</string>
|
|
||||||
<key>output</key>
|
|
||||||
<string>replaceSelectedText</string>
|
|
||||||
<key>scope</key>
|
|
||||||
<string>source.factor</string>
|
|
||||||
<key>uuid</key>
|
|
||||||
<string>8E01DDAF-959B-4237-ADB9-C133A4ACCE90</string>
|
|
||||||
</dict>
|
|
||||||
</plist>
|
|
||||||
|
|
@ -1,27 +0,0 @@
|
||||||
<?xml version="1.0" encoding="UTF-8"?>
|
|
||||||
<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
|
|
||||||
<plist version="1.0">
|
|
||||||
<dict>
|
|
||||||
<key>beforeRunningCommand</key>
|
|
||||||
<string>nop</string>
|
|
||||||
<key>command</key>
|
|
||||||
<string>#!/usr/bin/env ruby
|
|
||||||
|
|
||||||
require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
|
|
||||||
factor_run(STDIN.read)</string>
|
|
||||||
<key>fallbackInput</key>
|
|
||||||
<string>line</string>
|
|
||||||
<key>input</key>
|
|
||||||
<string>selection</string>
|
|
||||||
<key>keyEquivalent</key>
|
|
||||||
<string>^~e</string>
|
|
||||||
<key>name</key>
|
|
||||||
<string>Run Selection/Line in Listener</string>
|
|
||||||
<key>output</key>
|
|
||||||
<string>discard</string>
|
|
||||||
<key>scope</key>
|
|
||||||
<string>source.factor</string>
|
|
||||||
<key>uuid</key>
|
|
||||||
<string>15A984BD-BC65-43E8-878A-267788C8DA70</string>
|
|
||||||
</dict>
|
|
||||||
</plist>
|
|
||||||
Loading…
Reference in New Issue