1 ! Copyright (C) 2005, 2007 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 ;
11 : <iterator> 0 tail-slice ; inline
13 : this ( slice -- obj )
14 dup slice-from swap slice-seq nth-unsafe ; inline
16 : next ( iterator -- )
17 dup slice-from 1+ swap set-slice-from ; inline
19 : smallest ( iter1 iter2 quot -- elt )
20 >r over this over this r> call +lt+ eq?
21 -rot ? [ this ] keep next ; inline
23 : (merge) ( iter1 iter2 quot accum -- )
30 3dup smallest r> [ push ] keep (merge)
34 : merge ( sorted1 sorted2 quot -- result )
35 >r [ [ <iterator> ] bi@ ] 2keep r>
36 rot length rot length + <vector>
37 [ (merge) ] [ underlying>> ] bi ; inline
39 : conquer ( first second quot -- result )
40 [ tuck >r >r sort r> r> sort ] keep merge ; inline
44 : sort ( seq quot -- sortedseq )
46 [ drop ] [ over >r >r halves r> conquer r> like ] if ;
49 : natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
51 : sort-keys ( seq -- sortedseq ) [ [ first ] compare ] sort ;
53 : sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ;
55 : sort-pair ( a b -- c d ) 2dup after? [ swap ] when ;
57 : midpoint ( seq -- elt )
58 [ midpoint@ ] keep nth-unsafe ; inline
60 : partition ( seq n -- slice )
61 +gt+ eq? not swap halves ? ; inline
63 : (binsearch) ( elt quot seq -- i )
67 [ midpoint swap call ] 3keep roll dup +eq+ eq?
68 [ drop dup slice-from swap midpoint@ + 2nip ]
69 [ partition (binsearch) ] if
72 : binsearch ( elt seq quot -- i )
74 [ 3drop f ] [ <flat-slice> (binsearch) ] if ; inline
76 : binsearch* ( elt seq quot -- result )
77 over >r binsearch [ r> ?nth ] [ r> drop f ] if* ; inline