From 55df298df3cfe317f1da1942fb7b7bb6a9677f74 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 25 Aug 2022 10:54:02 -0400
Subject: [PATCH] =?utf8?q?sequences.extras:=20Add=20progress-index=20word?=
 =?utf8?q?=20like=20`=F0=9D=95=A8=20=E2=8A=92=20=F0=9D=95=A9:=20Progressiv?=
 =?utf8?q?e=20Index=20Of`=20in=20bqn?=
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

---
 extra/sequences/extras/extras-tests.factor | 12 +++++++++++
 extra/sequences/extras/extras.factor       | 23 +++++++++++++++++-----
 2 files changed, 30 insertions(+), 5 deletions(-)

diff --git a/extra/sequences/extras/extras-tests.factor b/extra/sequences/extras/extras-tests.factor
index e61844900f..e09445309b 100644
--- a/extra/sequences/extras/extras-tests.factor
+++ b/extra/sequences/extras/extras-tests.factor
@@ -272,6 +272,18 @@ strings tools.test ;
     { 2 7 1 8 1 7 1 8 2 8 4 } [ ] occurrence-count-by
 ] unit-test
 
+{ { 1 2 0 3 3 3 3 3 3 3 3 3 3 3 3 3 } } [
+    "cab" "abcdefghijklmnop" progressive-index nip
+] unit-test
+
+{ { 0 1 2 3 3 } } [
+    "aaa" "aaaaa" progressive-index nip
+] unit-test
+
+{ { 0 3 1 4 2 5 5 5 5 5 } } [
+    "aaabb" "ababababab" progressive-index nip
+] unit-test
+
 { { 0 1 2 3 } } [ 8 <iota> [ 4 < ] take-while >array ] unit-test
 { { } } [ { 15 16 } [ 4 < ] take-while >array ] unit-test
 { { 0 1 2 } } [ 3 <iota> [ 4 < ] take-while >array ] unit-test
diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor
index a780659c46..8463a90807 100644
--- a/extra/sequences/extras/extras.factor
+++ b/extra/sequences/extras/extras.factor
@@ -292,12 +292,28 @@ PRIVATE>
 : 0accumulate ( ... seq quot: ( ... prev elt -- ... next ) -- ... final newseq )
     over 0accumulate-as ; inline
 
-: occurrence-count-by ( seq quot: ( elt -- elt' ) -- hash seq )
+: occurrence-count-by ( seq quot: ( elt -- elt' ) -- hash seq' )
     '[ nip @ over inc-at* ] H{ } clone -rot 0accumulate ; inline
 
-: occurrence-count ( seq -- hash seq )
+: occurrence-count ( seq -- hash seq' )
     [ ] occurrence-count-by ; inline
 
+: nth-index ( n obj seq -- i )
+    [ = dup [ drop 1 - dup 0 < ] when ] with find drop nip ;
+
+: progressive-index-by-as ( seq1 seq2 quot exemplar -- hash seq' )
+    [
+        pick length '[
+            tuck [ @ over inc-at* ] 2dip swap nth-index _ or
+        ] [ H{ } clone ] 3dip with
+    ] dip map-as ; inline
+
+: progressive-index-by ( seq1 seq2 quot -- hash seq' )
+    { } progressive-index-by-as ; inline
+
+: progressive-index ( seq1 seq2 -- hash seq' )
+    [ ] progressive-index-by ; inline
+
 : 0reduce ( seq quot: ( prev elt -- next ) -- result )
     [ 0 ] dip reduce ; inline
 
@@ -925,6 +941,3 @@ M: virtual-zip-index nth-unsafe
     over [ seq>> nth-unsafe ] [ 2array ] bi* ; inline
 
 INSTANCE: virtual-zip-index immutable-sequence
-
-: nth-index ( n obj seq -- i )
-    [ = dup [ drop 1 - dup 0 < ] when ] with find drop nip ;
-- 
2.34.1