diff --git a/basis/db/tester/tester.factor b/basis/db/tester/tester.factor index 4e53ad3df7..490f6bbef5 100644 --- a/basis/db/tester/tester.factor +++ b/basis/db/tester/tester.factor @@ -46,12 +46,17 @@ test-2 "TEST2" { : db-tester2 ( test-db -- ) [ - [ test-1 recreate-table ] with-db - ] [ [ - 2 [ - 10 random 100 random 100 random 100 random test-1 boa - insert-tuple yield - ] parallel-each + test-1 ensure-table + test-2 ensure-table ] with-db + ] [ + [ + 10 [ + 10 [ + f 100 random 100 random 100 random test-1 boa + insert-tuple yield + ] times + ] parallel-each + ] with-pooled-db ] bi ; diff --git a/basis/http/http.factor b/basis/http/http.factor index 0aeb771c11..4702f88830 100644 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -45,8 +45,8 @@ IN: http : check-header-string ( str -- str ) #! http://en.wikipedia.org/wiki/HTTP_Header_Injection - dup "\r\n\"" intersect empty? - [ "Header injection attack" throw ] unless ; + dup "\r\n\"" intersects? + [ "Header injection attack" throw ] when ; : write-header ( assoc -- ) >alist sort-keys [ @@ -97,8 +97,8 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s ] { } make ; : check-cookie-string ( string -- string' ) - dup "=;'\"\r\n" intersect empty? - [ "Bad cookie name or value" throw ] unless ; + dup "=;'\"\r\n" intersects? + [ "Bad cookie name or value" throw ] when ; : unparse-cookie-value ( key value -- ) { diff --git a/basis/regexp/dfa/dfa.factor b/basis/regexp/dfa/dfa.factor index 0abd1c2edc..c3e98ae1ec 100644 --- a/basis/regexp/dfa/dfa.factor +++ b/basis/regexp/dfa/dfa.factor @@ -57,7 +57,7 @@ IN: regexp.dfa dup [ nfa-table>> final-states>> keys ] [ dfa-table>> transitions>> states ] bi - [ intersect empty? not ] with filter + [ intersects? ] with filter swap dfa-table>> final-states>> [ conjoin ] curry each ; diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 0f16863a79..c17db13b01 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -68,8 +68,8 @@ ERROR: bad-email-address email ; : validate-address ( string -- string' ) #! Make sure we send funky stuff to the server by accident. - dup "\r\n>" intersect empty? - [ bad-email-address ] unless ; + dup "\r\n>" intersects? + [ bad-email-address ] when ; : mail-from ( fromaddr -- ) validate-address @@ -170,8 +170,8 @@ M: plain-auth send-auth ERROR: invalid-header-string string ; : validate-header ( string -- string' ) - dup "\r\n" intersect empty? - [ invalid-header-string ] unless ; + dup "\r\n" intersects? + [ invalid-header-string ] when ; : write-header ( key value -- ) [ validate-header write ] diff --git a/basis/validators/validators.factor b/basis/validators/validators.factor index 78e01fdaf7..a70e20d7b6 100644 --- a/basis/validators/validators.factor +++ b/basis/validators/validators.factor @@ -69,8 +69,8 @@ IN: validators : v-one-line ( str -- str ) v-required - dup "\r\n" intersect empty? - [ "must be a single line" throw ] unless ; + dup "\r\n" intersects? + [ "must be a single line" throw ] when ; : v-one-word ( str -- str ) v-required diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index 5f7f4acf7a..428bf10401 100644 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -13,6 +13,8 @@ $nl { $subsection diff } { $subsection intersect } { $subsection union } +"Set-theoretic predicates:" +{ $subsection intersects? } { $subsection subset? } { $subsection set= } "A word used to implement the above:" @@ -104,9 +106,15 @@ HELP: union { diff intersect union } related-words +HELP: intersects? +{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "seq1" } " and " { $snippet "seq2" } " have any elements in common." } +{ $notes "If one of the sequences is empty, the result is always " { $link f } "." } ; + HELP: subset? { $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } } -{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." } ; +{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." } +{ $notes "If " { $snippet "seq1" } " is empty, the result is always " { $link t } "." } ; HELP: set= { $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } } diff --git a/core/sets/sets-tests.factor b/core/sets/sets-tests.factor index b6e6443afa..838a0a82b8 100644 --- a/core/sets/sets-tests.factor +++ b/core/sets/sets-tests.factor @@ -21,3 +21,11 @@ IN: sets.tests [ V{ 1 2 3 } ] [ 3 V{ 1 3 2 } clone [ adjoin ] keep ] unit-test + +[ t ] [ { 1 2 } { 1 3 } intersects? ] unit-test + +[ f ] [ { 4 2 } { 1 3 } intersects? ] unit-test + +[ f ] [ { } { 1 } intersects? ] unit-test + +[ f ] [ { 1 } { } intersects? ] unit-test diff --git a/core/sets/sets.factor b/core/sets/sets.factor index c411bfcdcd..88dffa6777 100644 --- a/core/sets/sets.factor +++ b/core/sets/sets.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov, Doug Coleman. +! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: assocs hashtables kernel sequences vectors ; IN: sets @@ -31,17 +31,26 @@ IN: sets : all-unique? ( seq -- ? ) dup length [ (all-unique?) ] curry all? ; + + : intersect ( seq1 seq2 -- newseq ) - unique [ key? ] curry filter ; + tester filter ; + +: intersects? ( seq1 seq2 -- newseq ) + tester contains? ; : diff ( seq1 seq2 -- newseq ) - unique [ key? not ] curry filter ; + tester [ not ] compose filter ; : union ( seq1 seq2 -- newseq ) append prune ; : subset? ( seq1 seq2 -- ? ) - unique [ key? ] curry all? ; + tester all? ; : set= ( seq1 seq2 -- ? ) [ unique ] bi@ = ; diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 29fee2e5c3..a2a302d995 100644 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -48,12 +48,12 @@ IN: splitting : split ( seq separators -- pieces ) [ split, ] { } make ; : string-lines ( str -- seq ) - dup "\r\n" intersect empty? [ - 1array - ] [ + dup "\r\n" intersects? [ "\n" split [ but-last-slice [ "\r" ?tail drop "\r" split ] map ] keep peek "\r" split suffix concat + ] [ + 1array ] if ;