From 3b861a5986e6ac764271185832c797a0dd43e5e0 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 24 Aug 2022 22:11:48 -0400
Subject: [PATCH] sequences: add 0reduce, 0accumulate that use their first
 element as the idenity

---
 core/sequences/sequences-tests.factor      |  4 +--
 core/sequences/sequences.factor            |  2 +-
 extra/sequences/extras/extras-tests.factor |  6 ++++
 extra/sequences/extras/extras.factor       | 40 ++++++++++++----------
 4 files changed, 31 insertions(+), 21 deletions(-)

diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor
index c28e5c7bc0..0eada182af 100644
--- a/core/sequences/sequences-tests.factor
+++ b/core/sequences/sequences-tests.factor
@@ -30,11 +30,11 @@ IN: sequences.tests
 ] unit-test
 
 { 21 } [
-    { 1 2 3 } { 4 5 6 } 0 [ + + ] 0 2reduce-from
+    { 1 2 3 } { 4 5 6 } 0 [ + + ] [ 0 ] 4dip 2reduce-from
 ] unit-test
 
 { 16 } [
-    { 1 2 3 } { 4 5 6 } 0 [ + + ] 1 2reduce-from
+    { 1 2 3 } { 4 5 6 } 0 [ + + ] [ 1 ] 4dip 2reduce-from
 ] unit-test
 
 { -541365 } [
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 86f25581a6..130513de13 100644
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -1161,7 +1161,7 @@ PRIVATE>
 
 : 2map-reduce ( ..a seq1 seq2 map-quot: ( ..a elt1 elt2 -- ..a intermediate ) reduce-quot: ( ..a prev intermediate -- ..a next ) -- ..a result )
     [ [ [ [ first ] bi@ ] 2keep ] dip [ 2dip ] keep ] dip
-    '[ rot _ dip swap @ ] 1 2each-from ; inline
+    '[ rot _ dip swap @ ] 1 -roll 2each-from ; inline
 
 <PRIVATE
 
diff --git a/extra/sequences/extras/extras-tests.factor b/extra/sequences/extras/extras-tests.factor
index a294ae4c94..d3ca984448 100644
--- a/extra/sequences/extras/extras-tests.factor
+++ b/extra/sequences/extras/extras-tests.factor
@@ -245,6 +245,12 @@ strings tools.test ;
 
 { 120000 } [ { 10 20 30 40 50 60 } 1 [ * ] 3 reduce-from ] unit-test
 
+{ 0 } [ { } [ + ] 0reduce ] unit-test
+{ 107 } [ { 100 1 2 4 } [ + ] 0reduce ] unit-test
+
+{ { } } [ { } [ + ] 0accumulate ] unit-test
+{ { 100 101 103 107 } } [ { 100 1 2 4 } [ + ] 0accumulate ] 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 b6a3bb2c83..30bbaf65b3 100644
--- a/extra/sequences/extras/extras.factor
+++ b/extra/sequences/extras/extras.factor
@@ -6,12 +6,6 @@ IN: sequences.extras
 : find-all ( ... seq quot: ( ... elt -- ... ? ) -- ... elts )
     [ <enumerated> ] dip '[ nip @ ] assoc-filter ; inline
 
-: reduce-from ( ... seq identity quot: ( ... prev elt -- ... next ) i -- ... result )
-    [ swap ] 2dip each-from ; inline
-
-: 2reduce-from ( ... seq1 seq2 identity quot: ( ... prev elt1 elt2 -- ... next ) i -- ... result )
-    [ -rot ] 2dip 2each-from ; inline
-
 :: subseq* ( from to seq -- subseq )
     seq length :> len
     from [ dup 0 < [ len + ] when ] [ 0 ] if*
@@ -272,25 +266,35 @@ PRIVATE>
 : map-with-previous ( ... seq quot: ( ... elt prev/f -- ... newelt ) -- ... newseq )
     over map-with-previous-as ; inline
 
-<PRIVATE
-
-: (setup-each-from) ( i seq -- n quot )
-    [ length over [-] swap ] keep '[ _ + _ nth-unsafe ] ; inline
-
-: setup-each-from ( i seq quot -- n quot' )
-    [ (setup-each-from) ] dip compose ; inline
-
-PRIVATE>
+: setup-each-from ( seq quot -- n quot )
+    [ [ length ] keep [ nth-unsafe ] curry ] dip compose ; inline
 
-: map-from-as ( ... seq quot: ( ... elt -- ... newelt ) i exemplar -- ... newseq )
-    [ -rot setup-each-from ] dip map-integers-as ; inline
+: map-from-as ( ... from seq quot: ( ... elt -- ... newelt ) exemplar -- ... newseq )
+    [ sequence-operator ] dip map-integers-as ; inline
 
-: map-from ( ... seq quot: ( ... elt -- ... newelt ) i -- ... newseq )
+: map-from ( ... from seq quot: ( ... elt -- ... newelt ) -- ... newseq )
     pick map-from-as ; inline
 
 : map-if ( ... seq if-quot: ( ... elt -- ... ? ) map-quot: ( ... elt -- ... newelt ) -- ... newseq )
     '[ dup @ _ when ] map ; inline
 
+: reduce-from ( ... seq identity quot: ( ... prev elt -- ... next ) from -- ... result )
+    [ swap ] 2dip each-from ; inline
+
+: 0accumulate-as ( ... seq quot: ( ... prev elt -- ... next ) exemplar -- ... newseq )
+    pick empty? [
+        2nip clone
+    ] [
+        [ 0 ] 2dip
+        [ swapd [ dup ] compose ] dip map-as nip
+    ] if ; inline
+
+: 0accumulate ( ... seq quot: ( ... prev elt -- ... next ) -- ... final newseq )
+    over 0accumulate-as ; inline
+
+: 0reduce ( seq quot: ( prev elt -- next ) -- result )
+    [ 0 ] dip reduce ; inline
+
 <PRIVATE
 
 : push-map-if ( ..a elt filter-quot: ( ..a elt -- ..b ? ) map-quot: ( ..a elt -- ..b newelt ) accum -- ..b )
-- 
2.34.1