ANEW --NRQKSORT--                             \  Wil Baden  2003-02-21

\  *******************************************************************
\  *                                                                 *
\  *  Wil Baden 1981-07-04 1983-11-26                                *
\  *                                                                 *
\  *          Non-Recursive QUICKSORT                                *
\  *                                                                 *
\  *  This is the sort used in most Forth benchmarks.  It has        *
\  *  an environmental dependency that `1 CELLS` is a power of 2.    *
\  *                                                                 *
\  *  It was originally written for figForth and Forth-83, before    *
\  *  Standard Forth.                                                *
\  *                                                                 *
\  *******************************************************************

\  Knuth, _Sorting and Searching_, 2nd Edition, p. 113

\    The basic method of [Quicksort] is to take one record,
\    say _R[1]_, and to move it to the final position that it
\    should occupy in the sorted file, say position _s_.  While
\    determining this final position, we will also rearrange
\    the other records so there will be none with greater keys
\    to the left of position _s_, and none with smaller keys
\    to the right.  Thus the file will have been partitioned
\    in such a way that the original sorting problem is
\    reduced to two simpler problems, namely to sort _R[1]_
\    ... _R[s-1]_, and (independently) _R[s+1]_ ... _R[N]_.

\    We can apply the same technique to each of these
\    subfiles, until the job is done.

\  This implementation uses several improvements to Hoare's
\  original formulation.

\  SORT                ( a n -- )
\     Order array _a_ _n_.

\  PRECEDES            ( pointer pointer -- flag )
\     Deferred comparison routine.  This will usually be used to
\     sort pointers.

\  Example.

\     : CPRECEDES  ( ptr ptr -- flag )
\        >R COUNT R> COUNT COMPARE 0< ;

\        ' CPRECEDES IS PRECEDES

\  THRESHOLD           ( -- <n cells> )
\     The boundary where  `QUICKSORT` should not
\     be used.  When sorting pointers to strings, for me 8 CELLS
\     has tested a little better than the original 7 CELLS.

\  EXCHANGE            ( addr1 addr2 -- )
\     Exchange contents of two addresses.

\  Both-Ends           ( f l pivot -- f l )
\     Put lower values on left, higher values on right.

\  Order3              ( f l -- f l pivot )
\     Order the first, last, and middle elements before
\     doing a partition.  The pivot for the partition is the
\     median of these three.

\  Partition           ( f l -- f l' f' l )
\     Split array into two partitions.

\  Sink                ( f key where -- f )
\     The innermost loop of insertion sort.

\  Insertion           ( f l -- )
\     Insertion sort to be used with small sets.

\  Hoarify             ( f l -- ... )
\     Partition until size is less than `THRESHOLD`.
\     The smaller partition is taken next.

\  QUICK               ( f l -- f l' f' l )
\     Partition until done.

\  CELL                ( -- <1 cells> )
\     Used in address arithmetic.

\  -CELL               ( -- <-1 cells> )
\     Used in address arithmetic.

8 CELLS CONSTANT THRESHOLD

DEFER PRECEDES   ' U< IS PRECEDES

 1 CELLS CONSTANT CELL
-1 CELLS CONSTANT -CELL

: EXCHANGE  ( a a -- )  2dup  @ SWAP @ ROT !  SWAP ! ;

: Both-Ends         ( f l pivot -- f l )
    >R                    ( f l)( R: pivot)
        BEGIN  over @ R@ PRECEDES WHILE
               CELL 0 D+
        REPEAT
        BEGIN  R@ over @ PRECEDES WHILE
               CELL -
        REPEAT
    R> DROP ;

: Order3            ( f l -- f l pivot )
    2dup over - 2/ -CELL AND + >R ( R: pivot)
        dup @ R@ @ PRECEDES IF
            dup R@ EXCHANGE
        THEN

        over @ R@ @ SWAP PRECEDES IF
            over R@ EXCHANGE
            dup @ R@ @ PRECEDES IF
                dup R@ EXCHANGE
        THEN THEN
    R> ;

: Partition         ( f l -- f l' f' l )
    Order3 @ >R
        2dup  CELL -CELL D+  ( f l f' l')
        BEGIN  R@ Both-Ends 2dup 1+ U< IF
                  2dup EXCHANGE
                  CELL -CELL D+
               THEN
        2dup SWAP U< UNTIL
        SWAP ROT             ( f l' f' l)
    R> DROP ;

: Sink              ( f key where -- f )
    ROT >R                ( key where)( R: f)
        BEGIN  CELL -  2dup @ PRECEDES WHILE
               dup @ over CELL+ !
               dup R@ = IF
                   ! R>   ( f)
               EXIT THEN  ( key where -- )
        REPEAT
        CELL+ !           ( )
    R> ( f) ;

: Insertion         ( f l -- )
    2dup U< IF
         CELL+ over CELL+ DO ( f)
               I @ I Sink
         CELL +LOOP DROP
    ELSE 2DROP
    THEN ( ) ;

: Hoarify           ( f l -- ... )
    BEGIN  2dup THRESHOLD 0 D+ U< WHILE
           Partition ( ... f l' f' l)
           2dup - >R  2over - R> > IF
                2SWAP
           THEN
    REPEAT           ( ... f l)
    Insertion ( ...) ;

: QUICK             ( f l -- )
    DEPTH >R
        BEGIN  Hoarify  DEPTH R@ < UNTIL
    R> DROP ;

: SORT              ( a n -- )
    DUP 0= ABORT" Nothing to sort "
    1- CELLS  OVER + ( f l) QUICK ;

\\   //   \\   //   \\   //   \\   //   \\   //   \\   //   \\   //   \\