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 [ from1>> ] [ seq>> ] bi nth-unsafe ; inline
46 : r-elt [ from2>> ] [ seq>> ] bi nth-unsafe ; inline
47 : l-done? [ from1>> ] [ to1>> ] bi number= ; inline
48 : r-done? [ from2>> ] [ to2>> ] bi number= ; inline
49 : dump-l [ [ from1>> ] [ to1>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
50 : dump-r [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
51 : l-next [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
52 : r-next [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
53 : decide [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
55 : (merge) ( merge quot: ( elt1 elt2 -- <=> ) -- )
56 over r-done? [ drop dump-l ] [
57 over l-done? [ drop dump-r ] [
59 [ over r-next ] [ over l-next ] if
62 ] if ; inline recursive
64 : flip-accum ( merge -- )
65 dup [ accum>> ] [ accum1>> ] bi eq? [
66 dup accum1>> underlying>> >>seq
70 dup accum2>> underlying>> >>seq
72 dup accum>> 0 >>length 2drop ; inline
74 : <merge> ( seq -- merge )
77 swap length <vector> >>accum2
78 dup accum1>> underlying>> >>seq
80 dup accum>> 0 >>length drop ; inline
82 : compute-midpoint ( merge -- merge )
83 dup [ from1>> ] [ to2>> ] bi + 2/ >>to1 ; inline
85 : merging ( from to merge -- )
89 dup [ to1>> ] [ seq>> length ] bi min >>to1
90 dup [ to2>> ] [ seq>> length ] bi min >>to2
94 : nth-chunk ( n size -- from to ) [ * dup ] keep + ; inline
96 : chunks ( length size -- n ) [ align ] keep /i ; inline
98 : each-chunk ( length size quot -- )
99 [ [ chunks ] keep ] dip
100 [ nth-chunk ] prepose curry
101 each-integer ; inline
103 : merge ( from to merge quot -- )
104 [ [ merging ] keep ] dip (merge) ; inline
106 : sort-pass ( merge size quot -- )
109 over [ seq>> length ] 2dip
111 [ merge ] 2curry each-chunk ; inline
113 : sort-loop ( merge quot -- )
114 [ 2 [ over seq>> length over > ] ] dip
115 [ [ 1 shift 2dup ] dip sort-pass ] curry
116 [ ] while 2drop ; inline
118 : each-pair ( seq quot -- )
119 [ [ length 1+ 2/ ] keep ] dip
120 [ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline
122 : (sort-pairs) ( i1 i2 seq quot accum -- )
123 [ 2dup length = ] 2dip rot [
124 [ drop nip nth ] dip push
127 [ tuck [ nth-unsafe ] 2bi@ 2dup ] dip call +gt+ eq?
129 ] dip tuck [ push ] 2bi@
132 : sort-pairs ( merge quot -- )
133 [ [ seq>> ] [ accum>> ] bi ] dip swap
134 [ (sort-pairs) ] 2curry each-pair ; inline
138 : sort ( seq quot -- sortedseq )
140 [ sort-pairs ] [ sort-loop ] [ drop accum>> underlying>> ] 2tri ;
143 : natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
145 : sort-keys ( seq -- sortedseq ) [ [ first ] compare ] sort ;
147 : sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ;
149 : sort-pair ( a b -- c d ) 2dup after? [ swap ] when ;