core/sorting/sorting.factor

   1 ! Copyright (C) 2005, 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays kernel math sequences vectors math.order
   4 sequences sequences.private growable math.order ;
   5 IN: sorting
   6
   7 DEFER: sort
   8
   9 <PRIVATE
  10
  11 : <iterator> 0 tail-slice ; inline
  12
  13 : this ( slice -- obj )
  14     dup slice-from swap slice-seq nth-unsafe ; inline
  15
  16 : next ( iterator -- )
  17     dup slice-from 1+ swap set-slice-from ; inline
  18
  19 : smallest ( iter1 iter2 quot -- elt )
  20     >r over this over this r> call +lt+ eq?
  21     -rot ? [ this ] keep next ; inline
  22
  23 : (merge) ( iter1 iter2 quot accum -- )
  24     >r pick empty? [
  25         drop nip r> push-all
  26     ] [
  27         over empty? [
  28             2drop r> push-all
  29         ] [
  30             3dup smallest r> [ push ] keep (merge)
  31         ] if
  32     ] if ; inline
  33
  34 : merge ( sorted1 sorted2 quot -- result )
  35     >r [ [ <iterator> ] bi@ ] 2keep r>
  36     rot length rot length + <vector>
  37     [ (merge) ] keep underlying ; inline
  38
  39 : conquer ( first second quot -- result )
  40     [ tuck >r >r sort r> r> sort ] keep merge ; inline
  41
  42 PRIVATE>
  43
  44 : sort ( seq quot -- sortedseq )
  45     over length 1 <=
  46     [ drop ] [ over >r >r halves r> conquer r> like ] if ;
  47     inline
  48
  49 : natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
  50
  51 : sort-keys ( seq -- sortedseq ) [ [ first ] compare ] sort ;
  52
  53 : sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ;
  54
  55 : sort-pair ( a b -- c d ) 2dup after? [ swap ] when ;
  56
  57 : midpoint ( seq -- elt )
  58     [ midpoint@ ] keep nth-unsafe ; inline
  59
  60 : partition ( seq n -- slice )
  61     +gt+ eq? not swap halves ? ; inline
  62
  63 : (binsearch) ( elt quot seq -- i )
  64     dup length 1 <= [
  65         slice-from 2nip
  66     ] [
  67         [ midpoint swap call ] 3keep roll dup +eq+ eq?
  68         [ drop dup slice-from swap midpoint@ + 2nip ]
  69         [ partition (binsearch) ] if
  70     ] if ; inline
  71
  72 : binsearch ( elt seq quot -- i )
  73     swap dup empty?
  74     [ 3drop f ] [ <flat-slice> (binsearch) ] if ; inline
  75
  76 : binsearch* ( elt seq quot -- result )
  77     over >r binsearch [ r> ?nth ] [ r> drop f ] if* ; inline