core/sorting/sorting.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs growable.private hashtables
   4 kernel kernel.private math math.order math.private sequences
   5 sequences.private vectors ;
   6 IN: sorting
   7
   8 ! Optimized merge-sort:
   9 !
  10 ! 1) only allocates 2 temporary arrays
  11
  12 ! 2) first phase (interchanging pairs x[i], x[i+1] where
  13 ! x[i] > x[i+1]) is handled specially
  14
  15 <PRIVATE
  16
  17 TUPLE: merge-state
  18 { seq    array }
  19 { accum  vector }
  20 { accum1 vector }
  21 { accum2 vector }
  22 { from1  array-capacity }
  23 { to1    array-capacity }
  24 { from2  array-capacity }
  25 { to2    array-capacity } ;
  26
  27 : l-elt ( merge -- elt ) [ from1>> ] [ seq>> ] bi nth-unsafe ; inline
  28
  29 : r-elt ( merge -- elt ) [ from2>> ] [ seq>> ] bi nth-unsafe ; inline
  30
  31 : l-done? ( merge -- ? ) [ from1>> ] [ to1>> ] bi eq? ; inline
  32
  33 : r-done? ( merge -- ? ) [ from2>> ] [ to2>> ] bi eq? ; inline
  34
  35 : dump-l ( merge -- )
  36     [ accum>> ] keep
  37     [
  38         [ to1>> ] [ from1>> fixnum-fast ] [ accum>> length integer>fixnum-strict ] tri
  39         [ fixnum+fast >>length ] 2keep
  40     ] [ seq>> ] [ from1>> roll dupd fixnum+fast ] tri
  41     copy-loop drop ; inline
  42
  43 : dump-r ( merge -- )
  44     [ accum>> ] keep
  45     [
  46         [ to2>> ] [ from2>> fixnum-fast ] [ accum>> length integer>fixnum-strict ] tri
  47         [ fixnum+fast >>length ] 2keep
  48     ] [ seq>> ] [ from2>> roll dupd fixnum+fast ] tri
  49     copy-loop drop ; inline
  50
  51 : l-next ( merge -- )
  52     [ l-elt ] [ [ 1 + ] change-from1 accum>> ] bi push-unsafe ; inline
  53
  54 : r-next ( merge -- )
  55     [ r-elt ] [ [ 1 + ] change-from2 accum>> ] bi push-unsafe ; inline
  56
  57 : decide? ( merge quot: ( elt1 elt2 -- <=> ) -- ? )
  58     [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
  59
  60 : (merge) ( merge quot: ( elt1 elt2 -- <=> ) -- )
  61     over r-done? [ drop dump-l ] [
  62         over l-done? [ drop dump-r ] [
  63             2dup decide?
  64             [ over r-next ] [ over l-next ] if
  65             (merge)
  66         ] if
  67     ] if ; inline recursive
  68
  69 : flip-accum ( merge -- )
  70     dup [ accum>> ] [ accum1>> ] bi eq? [
  71         dup accum1>> underlying>> >>seq
  72         dup accum2>> >>accum
  73     ] [
  74         dup accum1>> >>accum
  75         dup accum2>> underlying>> >>seq
  76     ] if
  77     dup accum>> 0 >>length 2drop ; inline
  78
  79 : <merge> ( seq -- merge )
  80     \ merge-state new
  81         over >vector >>accum1
  82         swap length <vector> >>accum2
  83         dup accum1>> underlying>> >>seq
  84         dup accum2>> >>accum ; inline
  85
  86 : compute-midpoint ( merge -- merge )
  87     dup [ from1>> ] [ to2>> ] bi + 2/ >>to1 ; inline
  88
  89 : merging ( from to merge -- )
  90     swap >>to2
  91     swap >>from1
  92     compute-midpoint
  93     dup [ to1>> ] [ seq>> length ] bi min >>to1
  94     dup [ to2>> ] [ seq>> length ] bi min >>to2
  95     dup to1>> >>from2
  96     drop ; inline
  97
  98 : nth-chunk ( n size -- from to ) [ * dup ] keep + ; inline
  99
 100 : chunks ( length size -- n ) [ align ] keep /i ; inline
 101
 102 : each-chunk ( length size quot -- )
 103     [ [ chunks ] keep ] dip
 104     [ nth-chunk ] prepose curry
 105     each-integer ; inline
 106
 107 : merge ( from to merge quot -- )
 108     [ [ merging ] keep ] dip (merge) ; inline
 109
 110 : sort-pass ( merge size quot -- )
 111     [
 112         over flip-accum
 113         over [ seq>> length ] 2dip
 114     ] dip
 115     [ merge ] 2curry each-chunk ; inline
 116
 117 : sort-loop ( merge quot -- )
 118     [ 2 over seq>> length [ over > ] curry ] dip
 119     [ [ 1 shift 2dup ] dip sort-pass ] curry
 120     while 2drop ; inline
 121
 122 : each-pair ( seq quot -- )
 123     [ [ length 1 + 2/ ] keep ] dip
 124     [ [ 1 shift dup 1 + ] dip ] prepose curry each-integer ; inline
 125
 126 : (sort-pairs) ( i1 i2 seq quot accum -- )
 127     [ 2dup length = ] 2dip rot [
 128         [ drop nip nth-unsafe ] dip push-unsafe
 129     ] [
 130         [
 131             [ [ nth-unsafe ] curry bi@ 2dup ] dip call +gt+ eq?
 132             [ swap ] when
 133         ] dip [ push-unsafe ] curry bi@
 134     ] if ; inline
 135
 136 : sort-pairs ( merge quot -- )
 137     [ [ seq>> ] [ accum>> ] bi ] dip swap
 138     [ (sort-pairs) ] 2curry each-pair ; inline
 139
 140 PRIVATE>
 141
 142 : sort-with ( seq quot: ( obj1 obj2 -- <=> ) -- sortedseq )
 143     [ <merge> ] dip
 144     [ sort-pairs ] [ sort-loop ] [ drop accum>> underlying>> ] 2tri ; inline
 145
 146 : inv-sort-with ( seq quot: ( obj1 obj2 -- <=> ) -- sortedseq )
 147     '[ @ invert-comparison ] sort-with ; inline
 148
 149 : sort ( seq -- sortedseq ) [ <=> ] sort-with ;
 150
 151 : inv-sort ( seq -- sortedseq ) [ >=< ] sort-with ;
 152
 153 : sort-by ( seq quot: ( elt -- key ) -- sortedseq )
 154     [ compare ] curry sort-with ; inline
 155
 156 : inv-sort-by ( seq quot: ( elt -- key ) -- sortedseq )
 157     [ compare invert-comparison ] curry sort-with ; inline
 158
 159 ALIAS: natural-sort sort ! temporary, deprecated
 160
 161 <PRIVATE
 162
 163 : check-bounds ( alist n -- alist )
 164     [ swap bounds-check 2drop ] curry dupd each ; inline
 165
 166 PRIVATE>
 167
 168 GENERIC: sort-keys ( obj -- sortedseq )
 169
 170 M: object sort-keys >alist sort-keys ;
 171
 172 M: sequence sort-keys
 173     0 check-bounds [ first-unsafe ] sort-by ;
 174
 175 M: hashtable sort-keys
 176     >alist [ { array } declare first-unsafe ] sort-by ;
 177
 178 GENERIC: inv-sort-keys ( obj -- sortedseq )
 179
 180 M: object inv-sort-keys >alist inv-sort-keys ;
 181
 182 M: sequence inv-sort-keys
 183     0 check-bounds [ first-unsafe ] inv-sort-by ;
 184
 185 M: hashtable inv-sort-keys
 186     >alist [ { array } declare first-unsafe ] inv-sort-by ;
 187
 188 GENERIC: sort-values ( obj -- sortedseq )
 189
 190 M: object sort-values >alist sort-values ;
 191
 192 M: sequence sort-values
 193     1 check-bounds [ second-unsafe ] sort-by ;
 194
 195 M: hashtable sort-values
 196     >alist [ { array } declare second-unsafe ] sort-by ;
 197
 198 : sort-pair ( a b -- c d ) 2dup after? [ swap ] when ;
 199
 200 GENERIC: inv-sort-values ( obj -- sortedseq )
 201
 202 M: object inv-sort-values >alist inv-sort-values ;
 203
 204 M: sequence inv-sort-values
 205     1 check-bounds [ second-unsafe ] inv-sort-by ;
 206
 207 M: hashtable inv-sort-values
 208     >alist [ { array } declare second-unsafe ] inv-sort-by ;