diff --git a/extra/sorting/extras/extras-tests.factor b/extra/sorting/extras/extras-tests.factor index 4df1ac9e45..4cadd81cde 100644 --- 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 988c73e145..b9edf17963 100644 --- 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 ;