sequences.extras: adding supremum-by* and infimum-by* that return indices.

diff --git a/extra/sequences/extras/extras-tests.factor b/extra/sequences/extras/extras-tests.factor
index d01f60752edee369e741d863cbe8a00219e414b9..65d27895accf44d11aecbaf587c681e853ba2afb 100644 (file)
--- a/extra/sequences/extras/extras-tests.factor
+++ b/extra/sequences/extras/extras-tests.factor
@@ -171,3 +171,7 @@ IN: sequences.extras.tests
 { "foo" " bar" } [ "foo bar" [ blank? ] cut-when ] unit-test
 
 { { 4 0 3 1 2 } } [ { 0 4 1 3 2 } 5 iota [ nth* ] curry map ] unit-test
+
+{ 1 "beef" } [ { "chicken" "beef" "moose" } [ length ] infimum-by* ] unit-test
+{ 0 "chicken" } [ { "chicken" "beef" "moose" } [ length ] supremum-by* ] unit-test
+{ 2 "moose" } [ { "chicken" "beef" "moose" } [ first ] supremum-by* ] unit-test

diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor
index 03b1fcda5c058fb676f899cba5cdfe9c6132d499..648bc7166e3f18672621b6dc31955e76a4bc97b7 100644 (file)
--- a/extra/sequences/extras/extras.factor
+++ b/extra/sequences/extras/extras.factor
@@ -1,6 +1,7 @@
-USING: accessors arrays assocs combinators fry grouping growable
-kernel locals make math math.order math.ranges sequences
-sequences.deep sequences.private sorting splitting vectors ;
+USING: accessors arrays assocs combinators fry generalizations
+grouping growable kernel locals make math math.order math.ranges
+sequences sequences.deep sequences.private sorting splitting
+vectors ;
 FROM: sequences => change-nth ;
 IN: sequences.extras
 
@@ -489,3 +490,25 @@ PRIVATE>
 
 : nth* ( n seq -- elt )
     [ length 1 - swap - ] [ nth ] bi ; inline
+
+: each-index-from ( ... seq quot: ( ... elt index -- ... ) i -- ... )
+    -rot (each-index) (each-integer) ; inline
+
+<PRIVATE
+
+: select-by* ( ... seq quot: ( ... elt -- ... x ) compare: ( obj1 obj2 -- ? ) -- ... i elt )
+    [
+        [ keep swap ] curry [ dip ] curry
+        [ [ first 0 ] dip call ] 2keep
+        [ 2curry 3dip 5 npick pick ] curry
+    ] [
+        [ [ 3drop ] [ [ 3drop ] 3dip ] if ] compose
+    ] bi* compose 1 each-index-from nip swap ; inline
+
+PRIVATE>
+
+: supremum-by* ( ... seq quot: ( ... elt -- ... x ) -- ... i elt )
+    [ after? ] select-by* ; inline
+
+: infimum-by* ( ... seq quot: ( ... elt -- ... x ) -- ... i elt )
+    [ before? ] select-by* ; inline