sorting.extras: adding bisect-right and bisect-left.

diff --git a/extra/sorting/extras/extras-tests.factor b/extra/sorting/extras/extras-tests.factor
index 4df1ac9e45a07e2438d6956260e45b4b12597ddd..4cadd81cdea792a4e418246bf44307f8c6bb7a65 100644 (file)
--- a/extra/sorting/extras/extras-tests.factor
+++ b/extra/sorting/extras/extras-tests.factor
@@ -10,3 +10,11 @@ IN: sorting.extras
     { "green" "blue" "purple" } [ length ] map-sort
 ] unit-test
 { 1 { 1 2 3 4 } } [ 1 { 4 2 1 3 } [ dupd + ] map-sort ] unit-test
+
+{ 0 } [ 0 { 1 } bisect-right ] unit-test
+{ 1 } [ 1 { 1 } bisect-right ] unit-test
+{ 1 } [ 2 { 1 } bisect-right ] unit-test
+
+{ 0 } [ 0 { 1 } bisect-left ] unit-test
+{ 0 } [ 1 { 1 } bisect-left ] unit-test
+{ 1 } [ 2 { 1 } bisect-left ] unit-test

diff --git a/extra/sorting/extras/extras.factor b/extra/sorting/extras/extras.factor
index 988c73e145d89b15b052a656a63c22d9b3c741e5..b9edf1796306cff394765e04953de8a357e329ec 100644 (file)
--- a/extra/sorting/extras/extras.factor
+++ b/extra/sorting/extras/extras.factor
@@ -1,5 +1,5 @@
-USING: arrays assocs kernel kernel.private sequences
-sequences.private sorting ;
+USING: arrays assocs kernel kernel.private locals math
+math.order sequences sequences.private sorting ;
 IN: sorting.extras
 
 : argsort ( seq quot: ( obj1 obj2 -- <=> ) -- sortedseq )
@@ -11,3 +11,21 @@ IN: sorting.extras
     [ map ] curry keep zip
     [ { array } declare first-unsafe ] sort-with
     [ { array } declare second-unsafe ] map ; inline
+
+:: bisect-left ( obj seq -- i )
+    0 seq length [ 2dup < ] [
+        2dup + 2/ dup seq nth-unsafe obj before?
+        [ swap [ nip 1 + ] dip ] [ nip ] if
+    ] while drop ;
+
+:: bisect-right ( obj seq -- i )
+    0 seq length [ 2dup < ] [
+        2dup + 2/ dup seq nth-unsafe obj after?
+        [ nip ] [ swap [ nip 1 + ] dip ] if
+    ] while drop ;
+
+: insort-left ( obj seq -- seq' )
+    [ bisect-left ] 2keep swapd insert-nth ;
+
+: insort-right ( obj seq -- seq' )
+    [ bisect-right ] 2keep swapd insert-nth ;