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

db4
Eduardo Cavazos 2008-05-25 05:16:00 -05:00
commit 299bb1fb16
15 changed files with 87 additions and 35 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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