From c0a92f9b7409c79d423e59c8a7eaa662d05dac32 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Sun, 10 Sep 2023 12:31:35 -0700
Subject: [PATCH] sequences.extras: adding count=

---
 extra/sequences/extras/extras-docs.factor  | 8 ++++++++
 extra/sequences/extras/extras-tests.factor | 6 ++++++
 extra/sequences/extras/extras.factor       | 5 +++++
 3 files changed, 19 insertions(+)

diff --git a/extra/sequences/extras/extras-docs.factor b/extra/sequences/extras/extras-docs.factor
index d681ee2f55..b8c795fcf2 100644
--- 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 a9e8880646..c962ad6802 100644
--- 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 e6f24f6042..3a35fd629c 100644
--- 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 ;
-- 
2.34.1