samples/qsort.f

   1 \ ANEW --QSORT--                                \  Wil Baden  1999-04-13
   2
   3 \          QSORT from _Forth Dimensions_ vol.5
   4
   5 \  Leo Wong resurrected a version of Quicksort that I published
   6 \  in 1983. I no longer had a copy, and had forgotten it. I
   7 \  recall that a design constraint was to fit in one screen.
   8
   9 \  It doesn't do median-of-three or insertion sort under a
  10 \  threshold. It is recursive.
  11
  12 \  To my shock it has been 20-25 percent faster in tests than my
  13 \  "improved" version.
  14
  15 \  PRECEDES            ( addr_1 addr_2 -- flag )
  16 \      Defer-word for comparison.  Return TRUE for "lower".
  17
  18 \  SPRECEDES           ( addr_1 addr_2 -- flag )
  19 \      String comparison for `PRECEDES`.
  20
  21 \  EXCHANGE            ( addr_1 addr_2 -- )
  22 \      Exchange contents of two addresses.
  23
  24 \  CELL-               ( addr -- addr' )
  25 \      Decrement address.
  26
  27 \  PARTITION           ( lo hi -- lo_1 hi_1 lo_2 hi_2 )
  28 \      Partition array around its median.
  29
  30 \  QSORT               ( lo hi -- )
  31 \      Partition array until done.
  32
  33 \  SORT                ( addr n -- )
  34 \      Setup array for recursive partitioning.
  35
  36 \  Set PRECEDES for different datatypes or sort order.
  37
  38 DEFER-NOT-YET PRECEDES  ' < IS PRECEDES
  39
  40 \  For sorting character strings in increasing order:
  41
  42 (*
  43 : SPRECEDES                 ( addr addr -- flag )
  44     >R COUNT R> COUNT COMPARE 0< ;
  45
  46   ' SPRECEDES IS PRECEDES
  47 *)
  48
  49 : exchange  ( addr_1 addr_2 -- )  dup @ >r  over @ swap !  r> swap ! ;
  50
  51 : partition  ( lo hi -- lo_1 hi_1 lo_2 hi_2 )
  52   2dup over - bytes->cells 2u/ +cells @ >r  ( R: median)
  53   2dup begin                      ( lo_1 hi_2 lo_2 hi_1)
  54     swap begin dup @ r@  precedes while cell+ repeat
  55     swap begin r@ over @ precedes while cell- repeat
  56     2dup > ifnot 2dup exchange  >r cell+ r> cell- endif
  57   2dup > until                    ( lo_1 hi_2 lo_2 hi_1)
  58   r> drop                         ( R: )
  59   swap rot                        ( lo_1 hi_1 lo_2 hi_2)
  60 ;
  61
  62 : qsort  ( lo hi -- )
  63   partition                       ( lo_1 hi_1 lo_2 hi_2)
  64   2over 2over  - +                ( . . . . lo_1 hi_1+lo_2-hi_2)
  65        < if  2swap  then          ( lo_1 hi_1 lo_2 hi_2)
  66   2dup < if  recurse  else  2drop  then
  67   2dup < if  recurse  else  2drop  then ;
  68
  69 : sort  ( addr n -- )
  70   dup 2 < if  2drop  exit then
  71   1- cells over + ( addr addr+{n-1}cells) qsort ( )
  72 ;
  73
  74 \\  *************************  End of QSORT  *************************
  75
  76 1 [IF]
  77 \ create test-array here 10 , 50 , 40 , 32 , 666 , 69 , 42 , here swap - create; bytes->cells constant #test-array
  78 24 constant #test-array
  79 #test-array cells buffer: test-array
  80
  81 : gen-random-array  ( addr n -- )
  82   2>r prng:gen-dseed prng:pcg32-seed-u64 2r> for
  83     >r prng:pcg32-next 32767 and r@ ! r> cell+
  84   endfor drop 2drop
  85 ;
  86 test-array #test-array gen-random-array
  87
  88 : check-array  ( addr n -- )
  89   dup 2 < if 2drop exit endif
  90   1- for dup @ over cell+ @ <= not-?abort" sortbug" cell+ endfor drop
  91 ;
  92
  93
  94 : dump-array  ( addr n -- )
  95   endcr for dup @ . cell+ loop drop cr
  96 ;
  97
  98 test-array #test-array dump-array
  99 test-array #test-array sort
 100 test-array #test-array dump-array
 101 test-array #test-array check-array
 102
 103 [ENDIF]
 104
 105 .stack
 106 bye