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 1a21799bf2606762a89b715b2608e83b93920d00..b144ca6c4cd6028898e9cbc89c2b516b62488408 100644 (file)
--- 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 d9d751c7747217a0f7f1f0bea9ce22a7d5b3d28f..f94e748286287d67f18870d0e8b3b7ba1e4d55e9 100644 (file)
--- 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 )