extra/sorting/quick/quick.factor

   1 ! Copyright (C) 2014 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: arrays kernel math math.order math.private sequences
   5 sequences.private strings vectors ;
   6
   7 IN: sorting.quick
   8
   9 <PRIVATE
  10
  11 :: quicksort ( seq from to quot: ( obj1 obj2 -- <=> ) -- )
  12     from to < [
  13         from to fixnum+fast 2/ seq nth-unsafe :> pivot
  14
  15         from to [ 2dup <= ] [
  16             [
  17                 over seq nth-unsafe pivot quot call
  18                 +lt+ eq?
  19             ] [ [ 1 fixnum+fast ] dip ] while
  20
  21             [
  22                 dup seq nth-unsafe pivot quot call
  23                 +gt+ eq?
  24             ] [ 1 fixnum-fast ] while
  25
  26             2dup <= [
  27                 [ seq exchange-unsafe ]
  28                 [ [ 1 fixnum+fast ] [ 1 fixnum-fast ] bi* ] 2bi
  29             ] when
  30         ] while
  31
  32         [ seq from ] dip quot quicksort
  33         [ seq ] dip to quot quicksort
  34     ] when ; inline recursive
  35
  36 : check-array-capacity ( n -- n )
  37     integer>fixnum-strict dup array-capacity?
  38     [ "too large" throw ] unless ; inline
  39
  40 PRIVATE>
  41
  42 : sort! ( seq quot: ( obj1 obj2 -- <=> ) -- )
  43     [ 0 over length check-array-capacity 1 - ] dip quicksort ; inline
  44
  45 : sort-with! ( seq quot: ( elt -- key ) -- )
  46     [ compare ] curry sort! ; inline
  47
  48 : inv-sort-with! ( seq quot: ( elt -- key ) -- )
  49     [ compare invert-comparison ] curry sort! ; inline
  50
  51 GENERIC: natural-sort! ( seq -- )
  52
  53 M: object natural-sort!  [ <=> ] sort! ;
  54 M: array natural-sort! [ <=> ] sort! ;
  55 M: vector natural-sort! [ <=> ] sort! ;
  56 M: string natural-sort! [ <=> ] sort! ;