From f706b50ac75bbc0f8dd8343ecbfd0aaafac89b66 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 23 May 2008 22:48:58 -0500
Subject: [PATCH 1/5] remove dipd, it's 2dip
---
extra/combinators/lib/lib-docs.factor | 2 +-
extra/combinators/lib/lib-tests.factor | 3 ---
extra/combinators/lib/lib.factor | 2 --
extra/lisp/parser/parser.factor | 2 +-
extra/peg/ebnf/ebnf.factor | 2 +-
extra/project-euler/047/047.factor | 4 ++--
extra/reports/noise/noise.factor | 2 +-
extra/space-invaders/space-invaders.factor | 8 ++++----
8 files changed, 10 insertions(+), 15 deletions(-)
diff --git a/extra/combinators/lib/lib-docs.factor b/extra/combinators/lib/lib-docs.factor
index c88ce8d9f9..355d5647df 100755
--- a/extra/combinators/lib/lib-docs.factor
+++ b/extra/combinators/lib/lib-docs.factor
@@ -23,7 +23,7 @@ HELP: ndip
{ $example "USING: combinators.lib kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }
{ $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }
}
-{ $see-also dip dipd } ;
+{ $see-also dip 2dip } ;
HELP: nslip
{ $values { "n" number } }
diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor
index 54847dc8b3..200a667b6b 100755
--- a/extra/combinators/lib/lib-tests.factor
+++ b/extra/combinators/lib/lib-tests.factor
@@ -5,9 +5,6 @@ IN: combinators.lib.tests
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
-{ 6 2 } [ 1 2 [ 5 + ] dip ] unit-test
-{ 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test
-
[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer
{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index d4a9386649..4c4a988935 100755
--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@@ -38,8 +38,6 @@ MACRO: napply ( n -- )
: 3apply ( obj obj obj quot -- ) 3 napply ; inline
-: dipd ( x y quot -- y ) 2 ndip ; inline
-
: 2with ( param1 param2 obj quot -- obj curry )
with with ; inline
diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor
index 44c79fd962..cf5ff56331 100644
--- a/extra/lisp/parser/parser.factor
+++ b/extra/lisp/parser/parser.factor
@@ -19,7 +19,7 @@ dquote = '"'
squote = "'"
digit = [0-9]
integer = ("-")? (digit)+ => [[ first2 append string>number ]]
-float = integer "." (digit)* => [[ first3 >string [ number>string ] dipd 3append string>number ]]
+float = integer "." (digit)* => [[ first3 >string [ number>string ] 2dip 3append string>number ]]
rational = integer "/" (digit)+ => [[ first3 nip string>number / ]]
number = float
| rational
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index c3252de500..8a3a06c58d 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -50,7 +50,7 @@ C: <ebnf> ebnf
: syntax-pack ( begin parser end -- parser )
#! Parse 'parser' surrounded by syntax elements
#! begin and end.
- [ syntax ] dipd syntax pack ;
+ [ syntax ] 2dip syntax pack ;
: 'identifier' ( -- parser )
#! Return a parser that parses an identifer delimited by
diff --git a/extra/project-euler/047/047.factor b/extra/project-euler/047/047.factor
index 98e819a7db..e59ca56f39 100644
--- a/extra/project-euler/047/047.factor
+++ b/extra/project-euler/047/047.factor
@@ -35,8 +35,8 @@ IN: project-euler.047
pick pick = [
swap - nip
] [
- dup prime? [ [ drop 0 ] dipd ] [
- 2dup unique-factors length = [ [ 1+ ] dipd ] [ [ drop 0 ] dipd ] if
+ dup prime? [ [ drop 0 ] 2dip ] [
+ 2dup unique-factors length = [ [ 1+ ] 2dip ] [ [ drop 0 ] 2dip ] if
] if 1+ (consecutive)
] if ;
diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor
index 3b37171da3..f94c774943 100755
--- a/extra/reports/noise/noise.factor
+++ b/extra/reports/noise/noise.factor
@@ -35,7 +35,7 @@ IN: reports.noise
{ compose 1/2 }
{ curry 1/3 }
{ dip 1 }
- { dipd 2 }
+ { 2dip 2 }
{ drop 1/3 }
{ dup 1/3 }
{ if 1/3 }
diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor
index f773d331b1..d3ca3673f4 100755
--- a/extra/space-invaders/space-invaders.factor
+++ b/extra/space-invaders/space-invaders.factor
@@ -22,9 +22,9 @@ TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap s
: set-bitmap-pixel ( color point array -- )
#! 'color' is a {r g b}. Point is {x y}.
[ bitmap-index ] dip ! color index array
- [ [ first ] dipd set-uchar-nth ] 3keep
- [ [ second ] dipd [ 1 + ] dip set-uchar-nth ] 3keep
- [ third ] dipd [ 2 + ] dip set-uchar-nth ;
+ [ [ first ] 2dip set-uchar-nth ] 3keep
+ [ [ second ] 2dip [ 1 + ] dip set-uchar-nth ] 3keep
+ [ third ] 2dip [ 2 + ] dip set-uchar-nth ;
: get-bitmap-pixel ( point array -- color )
#! Point is a {x y}. color is a {r g b}
@@ -311,7 +311,7 @@ M: invaders-gadget draw-gadget* ( gadget -- )
: plot-bitmap-bits ( bitmap point byte bit -- )
#! point is a {x y}.
- [ first2 ] dipd
+ [ first2 ] 2dip
dup swapd -1 * shift 1 bitand 0 =
[ - 2array ] dip
[ black ] [ dup get-point-color ] if
From 104baa137c4d5618687d19e53b52fab5833761d2 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 23 May 2008 23:23:41 -0500
Subject: [PATCH 2/5] add some taxes stuff
---
extra/taxes/taxes.factor | 7 +++++++
1 file changed, 7 insertions(+)
diff --git a/extra/taxes/taxes.factor b/extra/taxes/taxes.factor
index 8456d95673..1f4eb556dc 100644
--- a/extra/taxes/taxes.factor
+++ b/extra/taxes/taxes.factor
@@ -33,6 +33,13 @@ TUPLE: fica-base-unknown ;
! Employer tax only, not withheld
: futa-tax-rate ( -- x ) DECIMAL: .062 ; inline
+: futa-base-rate ( -- x ) 7000 ; inline
+: futa-tax-offset-credit ( -- x ) DECIMAL: .054 ; inline
+
+: futa-tax ( salary w4 -- x )
+ drop futa-base-rate min
+ futa-tax-rate futa-tax-offset-credit -
+ * ;
! No base rate for medicare; all wages subject
: medicare-tax-rate ( -- x ) DECIMAL: .0145 ; inline
From 4186034de6ab147970037c98087a84f64c15ebb7 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 23 May 2008 23:25:32 -0500
Subject: [PATCH 3/5] add if-seq and if-empty
---
extra/sequences/lib/lib-docs.factor | 20 ++++++++++++++++++++
extra/sequences/lib/lib-tests.factor | 6 ++++++
extra/sequences/lib/lib.factor | 6 ++++++
3 files changed, 32 insertions(+)
diff --git a/extra/sequences/lib/lib-docs.factor b/extra/sequences/lib/lib-docs.factor
index 6f4a173874..14fb6eaebf 100755
--- a/extra/sequences/lib/lib-docs.factor
+++ b/extra/sequences/lib/lib-docs.factor
@@ -37,3 +37,23 @@ HELP: count
"100 [1,b] [ even? ] count ."
"50"
} ;
+
+HELP: if-seq
+{ $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } }
+{ $description "Makes an implicit check if the sequence is empty. If the sequence has any elements, " { $snippet "quot1" } " is called on it. Otherwise, the empty sequence is dropped and " { $snippet "quot2" } " is called." }
+{ $example
+ "USING: kernel prettyprint sequences sequences.lib ;"
+ "{ 1 2 3 } [ sum ] [ \"empty sequence\" throw ] if-seq ."
+ "6"
+} ;
+
+HELP: if-empty
+{ $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } }
+{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and " { $snippet "quot1" } " is called. Otherwise, if the sequence has any elements, " { $snippet "quot2" } " is called on it." }
+{ $example
+ "USING: kernel prettyprint sequences sequences.lib ;"
+ "{ 1 2 3 } [ \"empty sequence\" ] [ sum ] if-empty ."
+ "6"
+} ;
+
+{ if-seq if-empty } related-words
diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor
index 99565e966c..019796c1a1 100755
--- a/extra/sequences/lib/lib-tests.factor
+++ b/extra/sequences/lib/lib-tests.factor
@@ -79,3 +79,9 @@ IN: sequences.lib.tests
[ ] [ { } 0 firstn ] unit-test
[ "a" ] [ { "a" } 1 firstn ] unit-test
+
+[ "empty" ] [ { } [ "not empty" ] [ "empty" ] if-seq ] unit-test
+[ { 1 } "not empty" ] [ { 1 } [ "not empty" ] [ "empty" ] if-seq ] unit-test
+
+[ "empty" ] [ { } [ "empty" ] [ "not empty" ] if-empty ] unit-test
+[ { 1 } "not empty" ] [ { 1 } [ "empty" ] [ "not empty" ] if-empty ] unit-test
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index b703bb55a0..b26acbc544 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -243,3 +243,9 @@ PRIVATE>
: short ( seq n -- seq n' )
over length min ; inline
+
+: if-seq ( seq quot1 quot2 -- )
+ [ f like ] 2dip if* ; inline
+
+: if-empty ( seq quot1 quot2 -- )
+ swap if-seq ; inline
From fad5df79dfa2a2dc41891f4d9b1e1b859e4ad821 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 23 May 2008 23:33:20 -0500
Subject: [PATCH 4/5] handle \r\n,\r like \n
---
extra/farkup/farkup-tests.factor | 8 ++++++++
extra/farkup/farkup.factor | 19 +++++++++++--------
2 files changed, 19 insertions(+), 8 deletions(-)
diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor
index 7176486f8e..b6e46cfe7d 100755
--- a/extra/farkup/farkup-tests.factor
+++ b/extra/farkup/farkup-tests.factor
@@ -16,10 +16,18 @@ IN: farkup.tests
[ "<p>**</p>" ] [ "\\**" convert-farkup ] unit-test
[ "" ] [ "\n\n" convert-farkup ] unit-test
+[ "" ] [ "\r\n\r\n" convert-farkup ] unit-test
+[ "" ] [ "\r\r\r\r" convert-farkup ] unit-test
+[ "\n" ] [ "\r\r\r" convert-farkup ] unit-test
[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test
[ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
+[ "<p>foo</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
+[ "<p>foo</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test
+[ "<p>foo</p><p>bar</p>" ] [ "foo\r\r\nbar" convert-farkup ] unit-test
[ "\n<p>bar\n</p>" ] [ "\nbar\n" convert-farkup ] unit-test
+[ "\n<p>bar\n</p>" ] [ "\rbar\r" convert-farkup ] unit-test
+[ "\n<p>bar\n</p>" ] [ "\r\nbar\r\n" convert-farkup ] unit-test
[ "<p>foo</p>\n<p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor
index 15b7b4b72c..51a5a10bd9 100755
--- a/extra/farkup/farkup.factor
+++ b/extra/farkup/farkup.factor
@@ -9,14 +9,14 @@ IN: farkup
<PRIVATE
: delimiters ( -- string )
- "*_^~%[-=|\\\n" ; inline
+ "*_^~%[-=|\\\r\n" ; inline
MEMO: text ( -- parser )
[ delimiters member? not ] satisfy repeat1
[ >string escape-string ] action ;
MEMO: delimiter ( -- parser )
- [ dup delimiters member? swap "\n=" member? not and ] satisfy
+ [ dup delimiters member? swap "\r\n=" member? not and ] satisfy
[ 1string ] action ;
: surround-with-foo ( string tag -- seq )
@@ -37,8 +37,11 @@ MEMO: emphasis ( -- parser ) "_" "em" delimited ;
MEMO: superscript ( -- parser ) "^" "sup" delimited ;
MEMO: subscript ( -- parser ) "~" "sub" delimited ;
MEMO: inline-code ( -- parser ) "%" "code" delimited ;
-MEMO: nl ( -- parser ) "\n" token ;
-MEMO: 2nl ( -- parser ) "\n\n" token hide ;
+MEMO: nl ( -- parser )
+ "\r\n" token [ drop "\n" ] action
+ "\r" token [ drop "\n" ] action
+ "\n" token 3choice ;
+MEMO: 2nl ( -- parser ) nl hide nl hide 2seq ;
MEMO: h1 ( -- parser ) "=" "h1" delimited ;
MEMO: h2 ( -- parser ) "==" "h2" delimited ;
MEMO: h3 ( -- parser ) "===" "h3" delimited ;
@@ -119,7 +122,7 @@ MEMO: list-item ( -- parser )
] seq* [ "li" surround-with-foo ] action ;
MEMO: list ( -- parser )
- list-item "\n" token hide list-of
+ list-item nl hide list-of
[ "ul" surround-with-foo ] action ;
MEMO: table-column ( -- parser )
@@ -151,8 +154,8 @@ MEMO: line ( -- parser )
MEMO: paragraph ( -- parser )
line
- "\n" token over 2seq repeat0
- "\n" token "\n" token ensure-not 2seq optional 3seq
+ nl over 2seq repeat0
+ nl nl ensure-not 2seq optional 3seq
[
dup [ dup string? not swap [ blank? ] all? or ] deep-all?
[ "<p>" swap "</p>" 3array ] unless
@@ -163,7 +166,7 @@ PRIVATE>
PEG: parse-farkup ( -- parser )
[
list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,
- ] choice* repeat0 "\n" token optional 2seq ;
+ ] choice* repeat0 nl optional 2seq ;
: write-farkup ( parse-result -- )
[ dup string? [ write ] [ drop ] if ] deep-each ;
From 7a408dcf5510891eaf70efa4def882bbed2655bd Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 23 May 2008 23:34:10 -0500
Subject: [PATCH 5/5] mmmm....upgrades better html analyzer
---
extra/html/parser/analyzer/analyzer.factor | 31 +++++++++++++---------
1 file changed, 19 insertions(+), 12 deletions(-)
diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor
index 42355f954e..9ce45b5c47 100755
--- a/extra/html/parser/analyzer/analyzer.factor
+++ b/extra/html/parser/analyzer/analyzer.factor
@@ -3,25 +3,27 @@ arrays shuffle unicode.case namespaces splitting http
sequences.lib accessors io combinators http.client ;
IN: html.parser.analyzer
+TUPLE: link attributes clickable ;
+
: scrape-html ( url -- vector )
http-get parse-html ;
: (find-relative)
- [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ;
+ [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; inline
: find-relative ( seq quot n -- i elt )
>r over [ find drop ] dip r> swap pick
- (find-relative) ;
+ (find-relative) ; inline
: (find-all) ( n seq quot -- )
2dup >r >r find-from [
dupd 2array , 1+ r> r> (find-all)
] [
r> r> 3drop
- ] if* ;
+ ] if* ; inline
: find-all ( seq quot -- alist )
- [ 0 -rot (find-all) ] { } make ;
+ [ 0 -rot (find-all) ] { } make ; inline
: (find-nth) ( offset seq quot n count -- obj )
>r >r [ find-from ] 2keep 4 npick [
@@ -33,14 +35,14 @@ IN: html.parser.analyzer
] if
] [
2drop r> r> 2drop
- ] if ;
+ ] if ; inline
: find-nth ( seq quot n -- i elt )
- 0 -roll 0 (find-nth) ;
+ 0 -roll 0 (find-nth) ; inline
: find-nth-relative ( seq quot n offest -- i elt )
>r [ find-nth ] 3keep 2drop nip r> swap pick
- (find-relative) ;
+ (find-relative) ; inline
: remove-blank-text ( vector -- vector' )
[
@@ -120,9 +122,14 @@ IN: html.parser.analyzer
[ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ]
find-between-all ;
+: <link> ( vector -- link )
+ [ first attributes>> ]
+ [ [ name>> { text "img" } member? ] filter ] bi
+ link boa ;
+
: link. ( vector -- )
- [ second text>> write bl ]
- [ first tag-link write nl ] bi ;
+ [ attributes>> "href" swap at write nl ]
+ [ clickable>> [ bl bl text>> print ] each nl ] bi ;
: find-by-text ( seq quot -- tag )
[ dup name>> text = ] prepose find drop ;
@@ -136,12 +143,12 @@ IN: html.parser.analyzer
: find-forms ( vector -- vector' )
"form" over find-opening-tags-by-name
- over [ >r first2 r> find-between* ] curry map
+ swap [ >r first2 r> find-between* ] curry map
[ [ name>> { "form" "input" } member? ] filter ] map ;
: find-html-objects ( string vector -- vector' )
- find-opening-tags-by-name
- over [ >r first2 r> find-between* ] curry map ;
+ [ find-opening-tags-by-name ] keep
+ [ >r first2 r> find-between* ] curry map ;
: form-action ( vector -- string )
[ name>> "form" = ] find nip