From 6de8367223cea84e31a75e81dc672919f7391d76 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Sat, 21 Sep 2013 15:22:12 -0700
Subject: [PATCH] sequences.extras: adding supremum-by* and infimum-by* that
return indices.
---
extra/sequences/extras/extras-tests.factor | 4 +++
extra/sequences/extras/extras.factor | 29 +++++++++++++++++++---
2 files changed, 30 insertions(+), 3 deletions(-)
diff --git a/extra/sequences/extras/extras-tests.factor b/extra/sequences/extras/extras-tests.factor
index d01f60752e..65d27895ac 100644
--- 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 03b1fcda5c..648bc7166e 100644
--- 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