From 7fa7ed962f3c0f0e490f95926e6b686c1bf1cfa5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 15:28:09 -0600 Subject: [PATCH 1/9] Fix prettyprinting of invalid curries and tuples --- core/prettyprint/backend/backend.factor | 13 ++++++++++++- core/prettyprint/prettyprint-tests.factor | 4 ++++ 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index d1364a5986..226595aa4d 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -182,9 +182,20 @@ M: tuple pprint-narrow? drop t ; >pprint-sequence pprint-elements block> r> pprint-word block> ] check-recursion ; - + 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? [ diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 5907c22686..a7e087ffad 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -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 From c6be6bcfdf076fc95e7b065b1dfc49137e3fea60 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 15:53:42 -0600 Subject: [PATCH 2/9] New sockets benchmark --- extra/benchmark/sockets/sockets.factor | 29 ++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100755 extra/benchmark/sockets/sockets.factor diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor new file mode 100755 index 0000000000..876ff0b61d --- /dev/null +++ b/extra/benchmark/sockets/sockets.factor @@ -0,0 +1,29 @@ +USING: io.sockets io.server io kernel math threads debugger +concurrency tools.time prettyprint ; +IN: benchmark.sockets + +: simple-server ( -- ) + 7777 local-server "simple-server" [ + 10 [ read1 write1 flush ] times + ] with-server ; + +: simple-client ( -- ) + "localhost" 7777 [ + 10 [ CHAR: a dup write1 flush read1 assert= ] times + ] with-stream ; + +: socket-benchmark ( n -- ) + dup pprint " clients: " write + [ simple-server ] in-thread + yield yield + [ drop simple-client ] parallel-each ; + +: socket-benchmarks + [ 10 socket-benchmark ] time + [ 20 socket-benchmark ] time + [ 40 socket-benchmark ] time + [ 80 socket-benchmark ] time + [ 160 socket-benchmark ] time + [ 320 socket-benchmark ] time ; + +MAIN: socket-benchmarks From 80c9fe3c83b5890fe14cc7b499a268299e8b26ca Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 16:10:03 -0600 Subject: [PATCH 3/9] Add stop-server word --- extra/io/server/server.factor | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index a23984c207..5cb5aa5592 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -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 r> server-loop ; inline + >r 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 From 5c0374ce3251f4145bab54bad89a136880a53c95 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 16:10:11 -0600 Subject: [PATCH 4/9] Improved sockets benchmark --- extra/benchmark/sockets/sockets.factor | 38 ++++++++++++++++++-------- 1 file changed, 26 insertions(+), 12 deletions(-) diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 876ff0b61d..e8efc11c32 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -3,27 +3,41 @@ concurrency tools.time prettyprint ; IN: benchmark.sockets : simple-server ( -- ) - 7777 local-server "simple-server" [ - 10 [ read1 write1 flush ] times + 7777 local-server "benchmark.sockets" [ + read1 CHAR: x = [ + stop-server + ] [ + 20 [ read1 write1 flush ] times + ] if ] with-server ; : simple-client ( -- ) "localhost" 7777 [ - 10 [ CHAR: a dup write1 flush read1 assert= ] times + CHAR: b write1 flush + 20 [ CHAR: a dup write1 flush read1 assert= ] times + ] with-stream ; + +: stop-server ( -- ) + "localhost" 7777 [ + CHAR: x write1 ] with-stream ; : socket-benchmark ( n -- ) dup pprint " clients: " write - [ simple-server ] in-thread - yield yield - [ drop simple-client ] parallel-each ; + [ + [ simple-server ] in-thread + 100 sleep + [ drop simple-client ] parallel-each + stop-server + yield yield + ] time ; : socket-benchmarks - [ 10 socket-benchmark ] time - [ 20 socket-benchmark ] time - [ 40 socket-benchmark ] time - [ 80 socket-benchmark ] time - [ 160 socket-benchmark ] time - [ 320 socket-benchmark ] time ; + 10 socket-benchmark + 20 socket-benchmark + 40 socket-benchmark + 80 socket-benchmark + 160 socket-benchmark + 320 socket-benchmark ; MAIN: socket-benchmarks From bacc5dc61075198363019d88daa7d920960fde33 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 16:19:10 -0600 Subject: [PATCH 5/9] Fix factor.sh for NetBSD --- misc/Factor.tmbundle/Commands/Eval Selection | 0 misc/Factor.tmbundle/Commands/Run Selection | 0 misc/factor.sh | 59 +++++++++++--------- 3 files changed, 33 insertions(+), 26 deletions(-) create mode 100644 misc/Factor.tmbundle/Commands/Eval Selection create mode 100644 misc/Factor.tmbundle/Commands/Run Selection diff --git a/misc/Factor.tmbundle/Commands/Eval Selection b/misc/Factor.tmbundle/Commands/Eval Selection new file mode 100644 index 0000000000..e69de29bb2 diff --git a/misc/Factor.tmbundle/Commands/Run Selection b/misc/Factor.tmbundle/Commands/Run Selection new file mode 100644 index 0000000000..e69de29bb2 diff --git a/misc/factor.sh b/misc/factor.sh index f0eb232821..5d7e7d0b94 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -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 " } 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 ;; From 8db19c2ee5cb6e144d417084357d56a3631d1062 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:21:16 -0600 Subject: [PATCH 6/9] 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 7/9] 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 8/9] 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 9/9] 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