core/collections/sequence-sort.factor

   1 IN: sequences-internals
   2 USING: arrays generic kernel math sequences ;
   3
   4 : midpoint@ length 2 /i ; inline
   5
   6 : midpoint [ midpoint@ ] keep nth-unsafe ; inline
   7
   8 TUPLE: sorter seq start end mid ;
   9
  10 C: sorter ( seq start end -- sorter )
  11     [ >r 1+ rot <slice> r> set-sorter-seq ] keep
  12     dup sorter-seq midpoint over set-sorter-mid
  13     dup sorter-seq length 1- over set-sorter-end
  14     0 over set-sorter-start ; inline
  15
  16 : s*/e* dup sorter-start swap sorter-end ; inline
  17 : s*/e dup sorter-start swap sorter-seq length 1- ; inline
  18 : s/e* 0 swap sorter-end ; inline
  19 : sorter-exchange dup s*/e* rot sorter-seq exchange-unsafe ; inline
  20 : compare over sorter-seq nth-unsafe swap sorter-mid rot call ; inline
  21 : >start> dup sorter-start 1+ swap set-sorter-start ; inline
  22 : <end< dup sorter-end 1- swap set-sorter-end ; inline
  23
  24 : sort-up ( quot sorter -- )
  25     dup s*/e < [
  26         [ dup sorter-start compare 0 < ] 2keep rot
  27         [ dup >start> sort-up ] [ 2drop ] if
  28     ] [
  29         2drop
  30     ] if ; inline
  31
  32 : sort-down ( quot sorter -- )
  33     dup s/e* < [
  34         [ dup sorter-end compare 0 > ] 2keep rot
  35         [ dup <end< sort-down ] [ 2drop ] if
  36     ] [
  37         2drop
  38     ] if ; inline
  39
  40 : sort-step ( quot sorter -- )
  41     dup s*/e* <= [
  42         2dup sort-up 2dup sort-down dup s*/e* <= [
  43             dup sorter-exchange dup >start> dup <end< sort-step
  44         ] [
  45             2drop
  46         ] if
  47     ] [
  48         2drop
  49     ] if ; inline
  50
  51 : (nsort) ( quot seq start end -- )
  52     2dup < [
  53         <sorter> 2dup sort-step
  54         [ dup sorter-seq swap s/e* (nsort) ] 2keep
  55         [ dup sorter-seq swap s*/e (nsort) ] 2keep
  56     ] [
  57         2drop
  58     ] if 2drop ; inline
  59
  60 : partition ( -1/1 seq -- seq )
  61     dup midpoint@ rot 1 < [ head-slice ] [ tail-slice ] if ;
  62     inline
  63
  64 : (binsearch) ( elt quot seq -- i )
  65     dup length 1 <= [
  66         2nip slice-from
  67     ] [
  68         3dup >r >r >r midpoint swap call dup zero? [
  69             r> r> 3drop r> dup slice-from swap slice-to + 2 /i
  70         ] [
  71             r> swap r> swap r> partition (binsearch)
  72         ] if
  73     ] if ; inline
  74
  75 : flatten-slice ( seq -- slice )
  76     #! Binsearch returns an index relative to the sequence
  77     #! being sliced, so if we are given a slice as input,
  78     #! unexpected behavior will result.
  79     dup slice? [ >array ] when 0 over length rot <slice> ;
  80     inline
  81
  82 IN: sequences
  83
  84 : nsort ( seq quot -- )
  85     swap dup length 1 <=
  86     [ 2drop ] [ 0 over length 1- (nsort) ] if ; inline
  87
  88 : sort ( seq quot -- sortedseq )
  89     swap [ >array [ swap nsort ] keep ] keep like ; inline
  90
  91 : natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
  92
  93 : sort-keys ( alist -- alist )
  94     [ [ first ] 2apply <=> ] sort ;
  95
  96 : sort-values ( alist -- alist )
  97     [ [ second ] 2apply <=> ] sort ;
  98
  99 : binsearch ( elt seq quot -- i )
 100     swap dup empty?
 101     [ 3drop -1 ] [ flatten-slice (binsearch) ] if ; inline
 102
 103 : binsearch* ( elt seq quot -- result )
 104     over >r binsearch dup -1 = [ r> 2drop f ] [ r> nth ] if ;
 105     inline