\  QSORT

0 [IF] =======================================================
From
URL: http://home.earthlink.net/~neilbawd/qsort.txt
                                          Wil Baden 1999-04-13

        QSORT from _Forth Dimensions_ vol.5

Leo Wong resurrected a version of Quicksort that I published
in 1983. I no longer had a copy, and had forgotten it. I
recall that a design constraint was to fit in one screen.

It doesn't do median-of-three or insertion sort under a
threshold. It is recursive.

To my shock it has been 20-25 percent faster in tests than my
"improved" version.

------------------------------------------------------- [THEN]
0 [IF] =======================================================

PRECEDES            ( addr_1 addr_2 -- flag )
    Defer-word for comparison.  Return TRUE for "lower".
SPRECEDES           ( addr_1 addr_2 -- flag )
    String comparison for `PRECEDES`.
EXCHANGE            ( addr_1 addr_2 -- )
    Exchange contents of two addresses.
-CELL               ( -- n )
    Negative of size of cell.
CELL-               ( addr -- addr' )
    Decrement address.
PARTITION           ( lo hi -- lo_1 hi_1 lo_2 hi_2 )
    Partition array around its median.
QSORT               ( lo hi -- )
    Partition array until done.
SORT                ( addr n -- )
    Setup array for recursive partitioning.

------------------------------------------------------- [THEN]

\  Set PRECEDES for different datatypes or sort order.
DEFER PRECEDES  ' < IS PRECEDES

\  For sorting character strings in increasing order:
: SPRECEDES         ( addr addr -- flag )
    >R COUNT R> COUNT COMPARE 0< ;
  ' SPRECEDES IS PRECEDES

: EXCHANGE          ( addr_1 addr_2 -- )
    DUP @ >R  OVER @ SWAP !  R> SWAP ! ;

: -CELL ( -- n )  -1 CELLS ;

: CELL-  ( addr -- addr' )  1 CELLS - ;

: PARTITION         ( lo hi -- lo_1 hi_1 lo_2 hi_2 )
    2DUP OVER - 2/  -CELL AND +  @ >R  ( R: median)
    2DUP BEGIN      ( lo_1 hi_2 lo_2 hi_1)
         SWAP BEGIN  DUP @ R@  PRECEDES WHILE  CELL+  REPEAT
         SWAP BEGIN  R@ OVER @  PRECEDES WHILE  CELL-  REPEAT
         2DUP > NOT IF  2DUP EXCHANGE  >R CELL+ R> CELL-  THEN
    2DUP > UNTIL    ( lo_1 hi_2 lo_2 hi_1)
    R> DROP                            ( R: )
    SWAP ROT        ( lo_1 hi_1 lo_2 hi_2)
    ;

: QSORT             ( lo hi -- )
    PARTITION                ( lo_1 hi_1 lo_2 hi_2)
    2OVER 2OVER  - +         ( . . . . lo_1 hi_1+lo_2-hi_2)
        < IF  2SWAP  THEN    ( lo_1 hi_1 lo_2 hi_2)
    2DUP < IF  RECURSE  ELSE  2DROP  THEN
    2DUP < IF  RECURSE  ELSE  2DROP  THEN ;

: SORT              ( addr n -- )
    DUP 2 < IF  2DROP  EXIT THEN
    1- CELLS OVER + ( addr addr+{n-1}cells) QSORT ( ) ;