From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 15 Sep 2022 20:22:42 +0000 (-0400)
Subject: sequences.extras: Add more reduce/accumulate words like 1reduce and reduce-of
X-Git-Tag: 0.99~581
X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=31907b5ae5a882f68d1e5ef92a819b4441d57cbe

sequences.extras: Add more reduce/accumulate words like 1reduce and reduce-of
---

diff --git a/extra/sequences/extras/extras-tests.factor b/extra/sequences/extras/extras-tests.factor
index 1a21799bf2..b144ca6c4c 100644
--- a/extra/sequences/extras/extras-tests.factor
+++ b/extra/sequences/extras/extras-tests.factor
@@ -292,6 +292,14 @@ strings tools.test ;
 
 { 0 } [ { } [ + ] 0reduce ] unit-test
 { 107 } [ { 100 1 2 4 } [ + ] 0reduce ] unit-test
+{ 0 } [ { 100 1 2 4 } [ * ] 0reduce ] unit-test
+
+{ f } [ { } [ + ] 1reduce ] unit-test
+{ 107 } [ { 100 1 2 4 } [ + ] 1reduce ] unit-test
+{ 800 } [ { 100 1 2 4 } [ * ] 1reduce ] unit-test
+
+{ 800 } [ { 100 1 2 4 } [ * ] 1 reduce-of ] unit-test
+{ 800 { 1 100 100 200 } } [ { 100 1 2 4 } [ * ] 1 accumulate-of ] unit-test
 
 { { } } [ { } [ + ] 0accumulate ] unit-test
 { { 100 101 103 107 } } [ { 100 1 2 4 } [ + ] 0accumulate ] unit-test
diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor
index d9d751c774..f94e748286 100644
--- a/extra/sequences/extras/extras.factor
+++ b/extra/sequences/extras/extras.factor
@@ -320,6 +320,18 @@ PRIVATE>
 : 0reduce ( seq quot: ( prev elt -- next ) -- result )
     [ 0 ] dip reduce ; inline
 
+: ?unclip ( seq -- rest/f first/f )
+    [ f f ] [ unclip ] if-empty ;
+
+: 1reduce ( seq quot: ( prev elt -- next ) -- result )
+    [ ?unclip ] dip reduce ; inline
+
+: reduce-of ( seq quot: ( prev elt -- next ) identity -- result )
+    swap reduce ; inline
+
+: accumulate-of ( seq quot: ( prev elt -- next ) identity -- result )
+    swap accumulate ; inline
+
 <PRIVATE
 
 : push-map-when* ( ..a elt quot: ( ..a elt -- ..b obj ? ) accum -- ..b )