core/sorting/sorting.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays kernel math sequences vectors math.order
   4 sequences sequences.private math.order ;
   5 IN: sorting
   6
   7 ! Optimized merge-sort:
   8 !
   9 ! 1) only allocates 2 temporary arrays
  10
  11 ! 2) first phase (interchanging pairs x[i], x[i+1] where
  12 ! x[i] > x[i+1]) is handled specially
  13
  14 <PRIVATE
  15
  16 TUPLE: merge
  17 { seq    array }
  18 { accum  vector }
  19 { accum1 vector }
  20 { accum2 vector }
  21 { from1  array-capacity }
  22 { to1    array-capacity }
  23 { from2  array-capacity }
  24 { to2    array-capacity } ;
  25
  26 : dump ( from to seq accum -- )
  27     #! Optimize common case where to - from = 1, 2, or 3.
  28     [ 2dup swap - ] 2dip pick 1 =
  29     [ [ [ 2drop ] dip nth-unsafe ] dip push ] [
  30         pick 2 = [
  31             [
  32                 [ 2drop dup 1+ ] dip
  33                 [ nth-unsafe ] curry bi@
  34             ] dip [ push ] curry bi@
  35         ] [
  36             pick 3 = [
  37                 [
  38                     [ 2drop dup 1+ dup 1+ ] dip
  39                     [ nth-unsafe ] curry tri@
  40                 ] dip [ push ] curry tri@
  41             ] [ [ nip subseq ] dip push-all ] if
  42         ] if
  43     ] if ; inline
  44
  45 : l-elt ( merge -- elt ) [ from1>> ] [ seq>> ] bi nth-unsafe ; inline
  46
  47 : r-elt ( merge -- elt ) [ from2>> ] [ seq>> ] bi nth-unsafe ; inline
  48
  49 : l-done? ( merge -- ? ) [ from1>> ] [ to1>> ] bi eq? ; inline
  50
  51 : r-done? ( merge -- ? ) [ from2>> ] [ to2>> ] bi eq? ; inline
  52
  53 : dump-l ( merge -- )
  54     [ [ from1>> ] [ to1>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
  55
  56 : dump-r ( merge -- )
  57     [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
  58
  59 : l-next ( merge -- )
  60     [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
  61
  62 : r-next ( merge -- )
  63     [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
  64
  65 : decide ( merge -- ? )
  66     [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
  67
  68 : (merge) ( merge quot: ( elt1 elt2 -- <=> ) -- )
  69     over r-done? [ drop dump-l ] [
  70         over l-done? [ drop dump-r ] [
  71             2dup decide
  72             [ over r-next ] [ over l-next ] if
  73             (merge)
  74         ] if
  75     ] if ; inline recursive
  76
  77 : flip-accum ( merge -- )
  78     dup [ accum>> ] [ accum1>> ] bi eq? [
  79         dup accum1>> underlying>> >>seq
  80         dup accum2>> >>accum
  81     ] [
  82         dup accum1>> >>accum
  83         dup accum2>> underlying>> >>seq
  84     ] if
  85     dup accum>> 0 >>length 2drop ; inline
  86
  87 : <merge> ( seq -- merge )
  88     \ merge new
  89         over >vector >>accum1
  90         swap length <vector> >>accum2
  91         dup accum1>> underlying>> >>seq
  92         dup accum2>> >>accum
  93         dup accum>> 0 >>length drop ; inline
  94
  95 : compute-midpoint ( merge -- merge )
  96     dup [ from1>> ] [ to2>> ] bi + 2/ >>to1 ; inline
  97
  98 : merging ( from to merge -- )
  99     swap >>to2
 100     swap >>from1
 101     compute-midpoint
 102     dup [ to1>> ] [ seq>> length ] bi min >>to1
 103     dup [ to2>> ] [ seq>> length ] bi min >>to2
 104     dup to1>> >>from2
 105     drop ; inline
 106
 107 : nth-chunk ( n size -- from to ) [ * dup ] keep + ; inline
 108
 109 : chunks ( length size -- n ) [ align ] keep /i ; inline
 110
 111 : each-chunk ( length size quot -- )
 112     [ [ chunks ] keep ] dip
 113     [ nth-chunk ] prepose curry
 114     each-integer ; inline
 115
 116 : merge ( from to merge quot -- )
 117     [ [ merging ] keep ] dip (merge) ; inline
 118
 119 : sort-pass ( merge size quot -- )
 120     [
 121         over flip-accum
 122         over [ seq>> length ] 2dip
 123     ] dip
 124     [ merge ] 2curry each-chunk ; inline
 125
 126 : sort-loop ( merge quot -- )
 127     [ 2 [ over seq>> length over > ] ] dip
 128     [ [ 1 shift 2dup ] dip sort-pass ] curry
 129     while 2drop ; inline
 130
 131 : each-pair ( seq quot -- )
 132     [ [ length 1+ 2/ ] keep ] dip
 133     [ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline
 134
 135 : (sort-pairs) ( i1 i2 seq quot accum -- )
 136     [ 2dup length = ] 2dip rot [
 137         [ drop nip nth ] dip push
 138     ] [
 139         [
 140             [ [ nth-unsafe ] curry bi@ 2dup ] dip call +gt+ eq?
 141             [ swap ] when
 142         ] dip [ push ] curry bi@
 143     ] if ; inline
 144
 145 : sort-pairs ( merge quot -- )
 146     [ [ seq>> ] [ accum>> ] bi ] dip swap
 147     [ (sort-pairs) ] 2curry each-pair ; inline
 148
 149 PRIVATE>
 150
 151 : sort ( seq quot -- sortedseq )
 152     [ <merge> ] dip
 153     [ sort-pairs ] [ sort-loop ] [ drop accum>> underlying>> ] 2tri ;
 154     inline
 155
 156 : natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
 157
 158 : sort-keys ( seq -- sortedseq ) [ [ first ] compare ] sort ;
 159
 160 : sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ;
 161
 162 : sort-pair ( a b -- c d ) 2dup after? [ swap ] when ;