Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-02-11 16:32:53 -06:00
commit 9fe1dd871a
17 changed files with 410 additions and 49 deletions

View File

@ -185,6 +185,17 @@ M: tuple pprint-narrow? drop t ;
M: object pprint* pprint-object ;
M: curry pprint*
dup curry-quot callable? [ pprint-object ] [
"( invalid curry )" swap present-text
] if ;
M: compose pprint*
dup compose-first over compose-second [ callable? ] both?
[ pprint-object ] [
"( invalid compose )" swap present-text
] if ;
M: wrapper pprint*
dup wrapped word? [
<block \ \ pprint-word wrapped pprint-word block>

View File

@ -321,3 +321,7 @@ unit-test
[ [ 2 . ] ] [
[ 2 \ break (step-into) . ] (remove-breakpoints)
] unit-test
[ ] [ 1 \ + curry unparse drop ] unit-test
[ ] [ 1 \ + compose unparse drop ] unit-test

View File

@ -0,0 +1,43 @@
USING: io.sockets io.server io kernel math threads debugger
concurrency tools.time prettyprint ;
IN: benchmark.sockets
: simple-server ( -- )
7777 local-server "benchmark.sockets" [
read1 CHAR: x = [
stop-server
] [
20 [ read1 write1 flush ] times
] if
] with-server ;
: simple-client ( -- )
"localhost" 7777 <inet> <client> [
CHAR: b write1 flush
20 [ CHAR: a dup write1 flush read1 assert= ] times
] with-stream ;
: stop-server ( -- )
"localhost" 7777 <inet> <client> [
CHAR: x write1
] with-stream ;
: socket-benchmark ( n -- )
dup pprint " clients: " write
[
[ simple-server ] in-thread
100 sleep
[ drop simple-client ] parallel-each
stop-server
yield yield
] time ;
: socket-benchmarks
10 socket-benchmark
20 socket-benchmark
40 socket-benchmark
80 socket-benchmark
160 socket-benchmark
320 socket-benchmark ;
MAIN: socket-benchmarks

View File

@ -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 <slice> 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

View File

@ -26,8 +26,10 @@ LOG: accepted-connection NOTICE
: server-loop ( server quot -- )
[ accept-loop ] curry with-disposal ; inline
SYMBOL: servers
: spawn-server ( addrspec quot -- )
>r <server> r> server-loop ; inline
>r <server> dup servers get push r> server-loop ; inline
\ spawn-server NOTICE add-error-logging
@ -39,9 +41,13 @@ LOG: accepted-connection NOTICE
: with-server ( seq service quot -- )
[
V{ } clone servers set
[ spawn-server ] curry concurrency:parallel-each
] curry with-logging ; inline
: stop-server ( -- )
servers get [ dispose ] each ;
: received-datagram ( addrspec -- ) drop ;
\ received-datagram NOTICE add-input-logging

2
extra/money/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Doug Coleman
Slava Pestov

View File

@ -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

29
extra/money/money.factor Normal file
View File

@ -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
<reversed> 3 group "," join <reversed> %
"." % 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

1
extra/money/summary.txt Normal file
View File

@ -0,0 +1 @@
Utility for calculating money with rationals

View File

@ -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 ;

1
extra/taxes/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
extra/taxes/summary.txt Normal file
View File

@ -0,0 +1 @@
Calculate federal and state tax withholdings

View File

@ -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

140
extra/taxes/taxes.factor Normal file
View File

@ -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 ;

View File

@ -1,4 +1,4 @@
#!/bin/bash -e
#!/usr/bin/env bash
# Programs returning != 0 will not cause script to exit
set +e
@ -11,6 +11,9 @@ OS=
ARCH=
WORD=
NO_UI=
GIT_PROTOCOL=${GIT_PROTOCOL:="git"}
GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"}
ensure_program_installed() {
echo -n "Checking for $1..."
@ -51,6 +54,9 @@ check_installed_programs() {
ensure_program_installed wget
ensure_program_installed gcc
ensure_program_installed make
case $OS in
netbsd) ensure_program_installed gmake;;
esac
check_gcc_version
}
@ -106,6 +112,7 @@ find_os() {
*Darwin*) OS=macosx;;
*linux*) OS=linux;;
*Linux*) OS=linux;;
*NetBSD*) OS=netbsd;;
esac
}
@ -153,6 +160,8 @@ echo_build_info() {
echo MAKE_TARGET=$MAKE_TARGET
echo BOOT_IMAGE=$BOOT_IMAGE
echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET
echo GIT_PROTOCOL=$GIT_PROTOCOL
echo GIT_URL=$GIT_URL
}
set_build_info() {
@ -188,22 +197,19 @@ find_build_info() {
echo_build_info
}
invoke_git() {
git $*
check_ret git
}
git_clone() {
echo "Downloading the git repository from factorcode.org..."
git clone git://factorcode.org/git/factor.git
check_ret git
invoke_git clone $GIT_URL
}
git_pull_factorcode() {
echo "Updating the git repository from factorcode.org..."
git pull git://factorcode.org/git/factor.git master
check_ret git
}
http_git_pull_factorcode() {
echo "Updating the git repository from factorcode.org..."
git pull http://factorcode.org/git/factor.git master
check_ret git
invoke_git pull $GIT_URL master
}
cd_factor() {
@ -211,21 +217,28 @@ cd_factor() {
check_ret cd
}
invoke_make() {
case $OS in
netbsd) make='gmake';;
*) make='make';;
esac
$make $*
check_ret $make
}
make_clean() {
make clean
check_ret make
invoke_make clean
}
make_factor() {
make NO_UI=$NO_UI $MAKE_TARGET -j5
check_ret make
invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5
}
delete_boot_images() {
echo "Deleting old images..."
rm $BOOT_IMAGE > /dev/null 2>&1
rm $BOOT_IMAGE.* > /dev/null 2>&1
rm staging.*.image > /dev/null 2>&1
rm staging.*.image > /dev/null 2>&1
}
get_boot_image() {
@ -257,8 +270,8 @@ maybe_download_dlls() {
}
get_config_info() {
check_installed_programs
find_build_info
check_installed_programs
check_libraries
}
@ -285,13 +298,6 @@ update() {
make_factor
}
http_update() {
get_config_info
http_git_pull_factorcode
make_clean
make_factor
}
update_bootstrap() {
delete_boot_images
get_boot_image
@ -299,7 +305,7 @@ update_bootstrap() {
}
refresh_image() {
./$FACTOR_BINARY -script -e="refresh-all save 0 USE: system exit"
./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit"
check_ret factor
}
@ -316,6 +322,8 @@ install_libraries() {
usage() {
echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|wget-bootstrap"
echo "If you are behind a firewall, invoke as:"
echo "env GIT_PROTOCOL=http $0 <command>"
}
case "$1" in
@ -324,7 +332,6 @@ case "$1" in
self-update) update; make_boot_image; bootstrap;;
quick-update) update; refresh_image ;;
update) update; update_bootstrap ;;
http-update) http_update; update_bootstrap ;;
bootstrap) get_config_info; bootstrap ;;
wget-bootstrap) get_config_info; delete_boot_images; get_boot_image; bootstrap ;;
*) usage ;;