sequences.extras: adding count=

diff --git a/extra/sequences/extras/extras-docs.factor b/extra/sequences/extras/extras-docs.factor
index d681ee2f5583bce06d4ea77cc2bd1e219e5debd3..b8c795fcf222faca33604006d65bf0ffc1a60c13 100644 (file)
--- a/extra/sequences/extras/extras-docs.factor
+++ b/extra/sequences/extras/extras-docs.factor
@@ -681,6 +681,14 @@ HELP: count-tail
 }
 { $description "Count the number of values from the end of " { $snippet "seq" } " that return a truthy value when passed into " { $snippet "quot" } "." } ;
 
+HELP: count=
+{ $values
+    { "seq" sequence } { "quot" quotation } { "n" integer }
+    { "?" boolean }
+}
+{ $description "Returns " { $link t } " if the sequence has exactly " { $snippet "n" } " elements where " { $snippet "quot" } " returns true, otherwise returns " { $link f } "." } ;
+
+
 HELP: cut-when
 { $values
     { "seq" sequence } { "quot" quotation }

diff --git a/extra/sequences/extras/extras-tests.factor b/extra/sequences/extras/extras-tests.factor
index a9e8880646de1ceb139dddebd71b39f61c50d4ae..c962ad68022f62750f8022c4c74bab253bd6c568 100644 (file)
--- a/extra/sequences/extras/extras-tests.factor
+++ b/extra/sequences/extras/extras-tests.factor
@@ -377,6 +377,12 @@ strings tools.test ;
 { 2 } [ { 1 2 3 4 } [ 2 > ] count-tail ] unit-test
 { 4 } [ { 1 2 3 4 } [ 5 < ] count-tail ] unit-test
 
+{ t } [ { 1 2 3 4 } [ 5 > ] 0 count= ] unit-test
+{ f } [ { 1 2 3 4 } [ 5 > ] 1 count= ] unit-test
+{ 1 t } [ 1 { 1 1 3 4 } [ dupd = ] 2 count= ] unit-test
+{ 1 f } [ 1 { 1 1 3 4 } [ dupd = ] 3 count= ] unit-test
+{ 4 t } [ 0 { 1 1 3 4 } [ [ 1 + dup ] dip = ] 3 count= ] unit-test
+
 { SBUF" aco" SBUF" ftr"  } [ SBUF" factor" dup [ even? ] extract! ] unit-test
 
 { 25 5 1 } [ { 4 5 6 } [ sq ] [ 20 > ] find-pred ] unit-test

diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor
index e6f24f60427846fce81e69bae380ceb059e0888f..3a35fd629ca52077bc0b05163d25a61e567384cf 100644 (file)
--- a/extra/sequences/extras/extras.factor
+++ b/extra/sequences/extras/extras.factor
@@ -990,6 +990,11 @@ PRIVATE>
     [ not ] compose [ find-last drop ] keepd
     length swap [ - 1 - ] when* ; inline
 
+: count= ( ... seq quot: ( ... elt -- ... ? ) n -- ... ? )
+    [ 0 ] 3dip [
+        '[ swap _ dip swap [ 1 + ] when dup _ >= ] find 2drop
+    ] keep = ; inline
+
 :: shorten* ( vector n -- seq )
     vector n tail
     n vector shorten ;