extra/sorting/quick/quick.factor

   1 ! Copyright (C) 2014 John Benediktsson
   2 ! See https://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-with! ( seq quot: ( obj1 obj2 -- <=> ) -- )
  43     [ 0 over length check-array-capacity 1 - ] dip quicksort ; inline
  44
  45 : inv-sort-with! ( seq quot: ( obj1 obj2 -- <=> ) -- )
  46     '[ @ invert-comparison ] sort-with! ; inline
  47
  48 : sort-by! ( seq quot: ( elt -- key ) -- )
  49     [ compare ] curry sort-with! ; inline
  50
  51 : inv-sort-by! ( seq quot: ( elt -- key ) -- )
  52     [ compare invert-comparison ] curry sort-with! ; inline
  53
  54 GENERIC: sort! ( seq -- )
  55
  56 M: object sort! [ <=> ] sort-with! ;
  57 M: array sort! [ <=> ] sort-with! ;
  58 M: vector sort! [ <=> ] sort-with! ;
  59 M: string sort! [ <=> ] sort-with! ;
  60
  61 GENERIC: inv-sort! ( seq -- )
  62
  63 M: object inv-sort! [ <=> ] inv-sort-with! ;
  64 M: array inv-sort! [ <=> ] inv-sort-with! ;
  65 M: vector inv-sort! [ <=> ] inv-sort-with! ;
  66 M: string inv-sort! [ <=> ] inv-sort-with! ;