Merge branch 'master' of git://factorcode.org/git/factor
Conflicts: extra/sequences/lib/lib-tests.factor extra/sequences/lib/lib.factordb4
Daniel Ehrenberg
commit
353d4e2ab0
|
|
@ -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 } }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -47,15 +47,9 @@ TUPLE: entry time data ;
|
|||
|
||||
SYMBOL: NX
|
||||
|
||||
: cache-nx ( query ttl -- )
|
||||
ttl->time NX entry boa
|
||||
table-add ;
|
||||
: cache-nx ( query ttl -- ) ttl->time NX entry boa table-add ;
|
||||
|
||||
: nx? ( obj -- ? )
|
||||
dup entry?
|
||||
[ data>> NX = ]
|
||||
[ drop f ]
|
||||
if ;
|
||||
: nx? ( obj -- ? ) dup entry? [ data>> NX = ] [ drop f ] if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -72,27 +66,15 @@ SYMBOL: NX
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: entry-expired? ( entry -- ? ) time>> time->ttl 0 <= ;
|
||||
: expired? ( entry -- ? ) time>> time->ttl 0 <= ;
|
||||
|
||||
: cache-get ( query -- result )
|
||||
dup table-get ! query result
|
||||
{
|
||||
{
|
||||
[ dup f = ] ! not in the cache
|
||||
[ 2drop f ]
|
||||
}
|
||||
{
|
||||
[ dup entry-expired? ] ! here but expired
|
||||
[ drop table-rem f ]
|
||||
}
|
||||
{
|
||||
[ dup nx? ] ! negative result has been cached
|
||||
[ 2drop NX ]
|
||||
}
|
||||
{
|
||||
[ t ]
|
||||
[ query+entry->rrs ]
|
||||
}
|
||||
{ [ dup f = ] [ 2drop f ] } ! not in the cache
|
||||
{ [ dup expired? ] [ drop table-rem f ] } ! here but expired
|
||||
{ [ dup nx? ] [ 2drop NX ] } ! negative result cached
|
||||
{ [ t ] [ query+entry->rrs ] } ! good to go
|
||||
}
|
||||
cond ;
|
||||
|
||||
|
|
@ -114,22 +96,10 @@ SYMBOL: NX
|
|||
: cache-add ( query rr -- )
|
||||
over table-get ! query rr entry
|
||||
{
|
||||
{
|
||||
[ dup f = ] ! not in the cache
|
||||
[ drop rr->entry table-add ]
|
||||
}
|
||||
{
|
||||
[ dup nx? ]
|
||||
[ drop over table-rem rr->entry table-add ]
|
||||
}
|
||||
{
|
||||
[ dup entry-expired? ]
|
||||
[ drop rr->entry table-add ]
|
||||
}
|
||||
{
|
||||
[ t ]
|
||||
[ rot drop add-rr-to-entry ]
|
||||
}
|
||||
{ [ dup f = ] [ drop rr->entry table-add ] }
|
||||
{ [ dup nx? ] [ drop over table-rem rr->entry table-add ] }
|
||||
{ [ dup expired? ] [ drop rr->entry table-add ] }
|
||||
{ [ t ] [ rot drop add-rr-to-entry ] }
|
||||
}
|
||||
cond ;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,6 +6,8 @@ IN: dns.resolver
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! Need to cache records even in the case of name error
|
||||
|
||||
: cache-message ( message -- message )
|
||||
dup dup rcode>> NAME-ERROR =
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -80,4 +80,12 @@ IN: sequences.lib.tests
|
|||
[ ] [ { } 0 firstn ] unit-test
|
||||
[ "a" ] [ { "a" } 1 firstn ] unit-test
|
||||
|
||||
<<<<<<< HEAD:extra/sequences/lib/lib-tests.factor
|
||||
[ { { 1 1 } { 1 2 } { 2 0 } } ] [ { { 2 0 } { 1 1 } { 1 2 } } dup [ first ] insertion-sort ] 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
|
||||
>>>>>>> 299bb1fb1692a4427f5b46f70dbbcefd6aa57163:extra/sequences/lib/lib-tests.factor
|
||||
|
|
|
|||
|
|
@ -257,3 +257,9 @@ PRIVATE>
|
|||
: insertion-sort ( seq quot -- )
|
||||
! quot is a transformation on elements
|
||||
over length [ insert ] 2with each ; inline
|
||||
|
||||
: if-seq ( seq quot1 quot2 -- )
|
||||
[ f like ] 2dip if* ; inline
|
||||
|
||||
: if-empty ( seq quot1 quot2 -- )
|
||||
swap if-seq ; inline
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue