sequences: add map-prior-as, map-prior-from, and map-prior with custom identity

diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 98e363b2e5776585139d95ba16e3a1e38bc5e45a..4dde5b95e9eafc32e172123503913160798d3a9e 100644 (file)
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -213,12 +213,19 @@ PRIVATE>
 : first4 ( seq -- first second third fourth )
     3 swap bounds-check nip first4-unsafe ; inline
 
+: ??nth ( n seq -- elt/f ? )
+    2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; inline
+
 : ?nth ( n seq -- elt/f )
-    2dup bounds-check? [ nth-unsafe ] [ 2drop f ] if ; inline
+    ??nth drop ; inline
 
 : ?set-nth ( elt n seq -- )
     2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ; inline
 
+: ?nth-of ( seq n -- elt/f ) swap ?nth ; inline
+
+: ??nth-of ( seq n -- elt ? ) swap ??nth ; inline
+
 : index-or-length ( seq n -- seq n' ) over length min ; inline
 
 : index-of-last ( seq -- n seq ) [ length 1 - ] keep ; inline

diff --git a/extra/sequences/extras/extras-tests.factor b/extra/sequences/extras/extras-tests.factor
index 1dfb3ec5c4a9b82f6964745ddeb8d7e6da6afa37..b590f5cf429aed135a268a8bbea52efc69b023be 100644 (file)
--- a/extra/sequences/extras/extras-tests.factor
+++ b/extra/sequences/extras/extras-tests.factor
@@ -307,10 +307,19 @@ math prettyprint sequences sequences.extras strings tools.test ;
     { } [ - . ] each-prior
 ] unit-test
 
+{ } [
+    1000 { } [ - . ] each-prior-from
+] unit-test
+
 { } [
     { 5 16 42 103 } [ - . ] each-prior
 ] unit-test
 
+{ } [
+    1 { 5 16 42 103 } [ - . ] each-prior-from
+] unit-test
+
+
 { { } } [
     { } [ - ] map-prior
 ] unit-test
@@ -331,3 +340,7 @@ math prettyprint sequences sequences.extras strings tools.test ;
 { 0 } [ 0 CHAR: a "abba" nth-index ] unit-test
 { 3 } [ 1 CHAR: a "abba" nth-index ] unit-test
 { f } [ 2 CHAR: a "abba" nth-index ] unit-test
+
+{ { -995 11 26 61 } } [
+    1000 V{ 5 16 42 103 } [ - ] { } map-prior-identity-as
+] unit-test

diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor
index d447e30374a8e38e8cdfb6215bce25ea1b456fc5..7b5563c01eda1f92214ed2788b48c63d53ef7489 100644 (file)
--- a/extra/sequences/extras/extras.factor
+++ b/extra/sequences/extras/extras.factor
@@ -807,14 +807,42 @@ INSTANCE: step-slice virtual-sequence
         [ [ push ] curry compose 3nested-each ] keep
     ] keep like ; inline
 
-: each-prior ( ... seq quot: ( ... prior elt -- ... ) -- ... )
+: prev ( n seq -- obj ) [ 1 - ] dip nth ; inline
+: ?prev ( n seq -- obj/f ) [ 1 - ] dip ?nth ; inline
+: ??prev ( n seq -- obj/f ? ) [ 1 - ] dip ??nth ; inline
+: prev-of ( seq n -- obj ) 1 - nth-of ; inline
+: ?prev-of ( seq n -- obj/f ) 1 - ?nth-of ; inline
+: ??prev-of ( seq n -- obj/f ) 1 - ??nth-of ; inline
+
+: prev-identity ( i seq -- identity i seq )
+    2dup ??prev [ drop 0 ] unless -rot ; inline
+
+: each-prior-identity-from ( ... identity i seq quot: ( ... prior elt -- ... ) -- ... )
     '[ [ swap @ ] keep ]
-    sequence-operator 0 -rot each-integer-from drop ; inline
+    length-operator each-integer-from drop ; inline
 
-: map-prior-as ( ... seq quot: ( ... prior elt -- elt' ) exemplar -- seq' )
+: each-prior-from ( ... i seq quot: ( ... prior elt -- ... ) -- ... )
+    [ prev-identity ] dip each-prior-identity-from ; inline
+
+: each-prior ( ... seq quot: ( ... prior elt -- ... ) -- ... )
+    0 -rot each-prior-from ; inline
+
+: map-prior-identity-from-as ( ... identity i seq quot: ( ... prior elt -- elt' ) exemplar -- seq' )
     [
-        '[ [ swap @ ] keep swap ] length-operator 0 -rot
-    ] dip map-integers-as nip ; inline
+        '[ [ swap @ ] keep swap ] length-operator
+    ] dip map-integers-from-as nip ; inline
+
+: map-prior-identity-as ( ... identity seq quot: ( ... prior elt -- elt' ) exemplar -- seq' )
+    [ 0 ] 3dip map-prior-identity-from-as ; inline
+
+: map-prior-from-as ( ... i seq quot: ( ... prior elt -- elt' ) exemplar -- seq' )
+    [ prev-identity ] 2dip map-prior-identity-from-as ; inline
+
+: map-prior-as ( ... seq quot: ( ... prior elt -- elt' ) exemplar -- seq' )
+    0 -roll map-prior-from-as ; inline
+
+: map-prior-from ( ... seq quot: ( ... prior elt -- elt' ) i -- seq' )
+    pick map-prior-from-as ; inline
 
 : map-prior ( ... seq quot: ( ... prior elt -- elt' ) -- seq' )
     over map-prior-as ; inline