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

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

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

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
 

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
 

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 ;

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 

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

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

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 ;
 

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 }

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

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

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

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

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