extra/sorting/extras/extras.factor

   1 USING: arrays assocs kernel kernel.private math math.order
   2 sequences sequences.extras sequences.private sorting ;
   3 IN: sorting.extras
   4
   5 : argsort ( seq quot: ( obj1 obj2 -- <=> ) -- sortedseq )
   6     [ zip-index ] dip
   7     [ [ first-unsafe ] bi@ ] prepose
   8     sort [ second-unsafe ] map! ; inline
   9
  10 : map-sort ( ... seq quot: ( ... elt -- ... key ) -- ... sortedseq )
  11     [ keep ] curry { } map>assoc
  12     [ { array } declare first-unsafe ] sort-with
  13     [ { array } declare second-unsafe ] map ; inline
  14
  15 :: bisect-left ( obj seq -- i )
  16     0 seq length [ 2dup < ] [
  17         2dup + 2/ dup seq nth-unsafe obj before?
  18         [ swap [ nip 1 + ] dip ] [ nip ] if
  19     ] while drop ;
  20
  21 :: bisect-right ( obj seq -- i )
  22     0 seq length [ 2dup < ] [
  23         2dup + 2/ dup seq nth-unsafe obj after?
  24         [ nip ] [ swap [ nip 1 + ] dip ] if
  25     ] while drop ;
  26
  27 : insort-left ( obj seq -- seq' )
  28     [ bisect-left ] 2keep swapd insert-nth ;
  29
  30 : insort-right ( obj seq -- seq' )
  31     [ bisect-right ] 2keep swapd insert-nth ;
  32
  33 : insort-left! ( obj seq -- seq )
  34     [ bisect-left ] 2keep swapd [ insert-nth! ] keep ;
  35
  36 : insort-right! ( obj seq -- seq )
  37     [ bisect-right ] 2keep swapd [ insert-nth! ] keep ;