From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 16 Aug 2022 23:05:07 +0000 (-0500)
Subject: sequences.extras: Add each-prior and map-prior
X-Git-Tag: 0.99~1129
X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=458848d43c085d649c58f0fbb399c4b6608f892f

sequences.extras: Add each-prior and map-prior

named from Q language (kx)
---

diff --git a/extra/sequences/extras/extras-tests.factor b/extra/sequences/extras/extras-tests.factor
index 185ad060df..430e82ea33 100644
--- a/extra/sequences/extras/extras-tests.factor
+++ b/extra/sequences/extras/extras-tests.factor
@@ -1,6 +1,5 @@
 USING: accessors arrays ascii io io.streams.string kernel make
-math math.vectors random sequences sequences.extras strings
-tools.test vectors vocabs ;
+math prettyprint sequences sequences.extras strings tools.test ;
 
 { V{ { 0 104 } { 2 108 } { 3 108 } } } [ "hello" [ even? ] find-all ] unit-test
 
@@ -300,3 +299,27 @@ tools.test vectors vocabs ;
 { { { 100 0 } { 200 1 } { 300 2 } { 400 3 } } } [
     { 100 200 300 400 } <zip-index> >array
 ] unit-test
+
+{ } [
+    { } [ - . ] each-prior
+] unit-test
+
+{ } [
+    { 5 16 42 103 } [ - . ] each-prior
+] unit-test
+
+{ { } } [
+    { } [ - ] map-prior
+] unit-test
+
+{ V{ 5 11 26 61 } } [
+    V{ 5 16 42 103 } [ - ] map-prior
+] unit-test
+
+{ V{ } } [
+    { } [ - ] V{ } map-prior-as
+] unit-test
+
+{ { 5 11 26 61 } } [
+    V{ 5 16 42 103 } [ - ] { } map-prior-as
+] unit-test
\ No newline at end of file
diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor
index fbe65dc2ee..f47ebc5650 100644
--- a/extra/sequences/extras/extras.factor
+++ b/extra/sequences/extras/extras.factor
@@ -801,6 +801,18 @@ INSTANCE: step-slice virtual-sequence
         [ [ push ] curry compose 3nested-each ] keep
     ] keep like ; inline
 
+: each-prior ( ... seq quot: ( ... prior elt -- ... ) -- ... )
+    '[ [ swap @ ] keep ]
+    sequence-operator 0 -rot each-integer-from drop ; inline
+
+: map-prior-as ( ... seq quot: ( ... prior elt -- elt' ) exemplar -- seq' )
+    [
+        '[ [ swap @ ] keep swap ] length-operator 0 -rot
+    ] dip map-integers-as nip ; inline
+
+: map-prior ( ... seq quot: ( ... prior elt -- elt' ) -- seq' )
+    over map-prior-as ; inline
+
 TUPLE: virtual-zip-index seq ;
 
 C: <zip-index> virtual-zip-index