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 ;
7 ! Optimized merge-sort:
9 ! 1) only allocates 2 temporary arrays
11 ! 2) first phase (interchanging pairs x[i], x[i+1] where
12 ! x[i] > x[i+1]) is handled specially
21 { from1 array-capacity }
22 { to1 array-capacity }
23 { from2 array-capacity }
24 { to2 array-capacity } ;
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 ] [
33 [ nth-unsafe ] curry bi@
34 ] dip [ push ] curry bi@
38 [ 2drop dup 1+ dup 1+ ] dip
39 [ nth-unsafe ] curry tri@
40 ] dip [ push ] curry tri@
41 ] [ [ nip subseq ] dip push-all ] if
45 : l-elt ( merge -- elt ) [ from1>> ] [ seq>> ] bi nth-unsafe ; inline
47 : r-elt ( merge -- elt ) [ from2>> ] [ seq>> ] bi nth-unsafe ; inline
49 : l-done? ( merge -- ? ) [ from1>> ] [ to1>> ] bi eq? ; inline
51 : r-done? ( merge -- ? ) [ from2>> ] [ to2>> ] bi eq? ; inline
54 [ [ from1>> ] [ to1>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
57 [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
60 [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
63 [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
65 : decide ( merge -- ? )
66 [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
68 : (merge) ( merge quot: ( elt1 elt2 -- <=> ) -- )
69 over r-done? [ drop dump-l ] [
70 over l-done? [ drop dump-r ] [
72 [ over r-next ] [ over l-next ] if
75 ] if ; inline recursive
77 : flip-accum ( merge -- )
78 dup [ accum>> ] [ accum1>> ] bi eq? [
79 dup accum1>> underlying>> >>seq
83 dup accum2>> underlying>> >>seq
85 dup accum>> 0 >>length 2drop ; inline
87 : <merge> ( seq -- merge )
90 swap length <vector> >>accum2
91 dup accum1>> underlying>> >>seq
93 dup accum>> 0 >>length drop ; inline
95 : compute-midpoint ( merge -- merge )
96 dup [ from1>> ] [ to2>> ] bi + 2/ >>to1 ; inline
98 : merging ( from to merge -- )
102 dup [ to1>> ] [ seq>> length ] bi min >>to1
103 dup [ to2>> ] [ seq>> length ] bi min >>to2
107 : nth-chunk ( n size -- from to ) [ * dup ] keep + ; inline
109 : chunks ( length size -- n ) [ align ] keep /i ; inline
111 : each-chunk ( length size quot -- )
112 [ [ chunks ] keep ] dip
113 [ nth-chunk ] prepose curry
114 each-integer ; inline
116 : merge ( from to merge quot -- )
117 [ [ merging ] keep ] dip (merge) ; inline
119 : sort-pass ( merge size quot -- )
122 over [ seq>> length ] 2dip
124 [ merge ] 2curry each-chunk ; inline
126 : sort-loop ( merge quot -- )
127 [ 2 [ over seq>> length over > ] ] dip
128 [ [ 1 shift 2dup ] dip sort-pass ] curry
129 [ ] while 2drop ; inline
131 : each-pair ( seq quot -- )
132 [ [ length 1+ 2/ ] keep ] dip
133 [ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline
135 : (sort-pairs) ( i1 i2 seq quot accum -- )
136 [ 2dup length = ] 2dip rot [
137 [ drop nip nth ] dip push
140 [ tuck [ nth-unsafe ] 2bi@ 2dup ] dip call +gt+ eq?
142 ] dip tuck [ push ] 2bi@
145 : sort-pairs ( merge quot -- )
146 [ [ seq>> ] [ accum>> ] bi ] dip swap
147 [ (sort-pairs) ] 2curry each-pair ; inline
151 : sort ( seq quot -- sortedseq )
153 [ sort-pairs ] [ sort-loop ] [ drop accum>> underlying>> ] 2tri ;
156 : natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
158 : sort-keys ( seq -- sortedseq ) [ [ first ] compare ] sort ;
160 : sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ;
162 : sort-pair ( a b -- c d ) 2dup after? [ swap ] when ;