ANEW --HEAPSORT--  DECIMAL                    \  Wil Baden  2002-05-25

\  *******************************************************************
\  *                                                                 *
\  *        HEAPSORT                                                 *
\  *                                                                 *
\  *    HEAPSORT can be converted directly to Standard Forth from    *
\  *    Knuth's description in TAOCP with no other definition but    *
\  *    PRECEDES (and NOT).                                          *
\  *                                                                 *
\  *******************************************************************

\  This is a direct translation of HEAPSORT from Knuth's _The Art of
\  Computer Programming_, section 5.2.3.

\  Normallly the data is an array of addresses of records.  The
\  deferred PRECEDES function, used in two places, should compare the
\  keys within a pair of records.  The test is for negative value.

\  For debugging, an array of numbers can be used, and "<" may be the
\  PRECEDES behavior.

TRUE 0<> [IF]     \  Comment out redundant definitions.

    VARIABLE REVISION   REVISION OFF

    : ---  REVISION @    IF  postpone \  THEN ; IMMEDIATE
    : +++  REVISION @ 0= IF  postpone \  THEN ; IMMEDIATE

[THEN]

REVISION OFF       \  On for debug.

REVISION @ [IF]

    \  Knuth's Example.  This will display the data of Table 2.

    CREATE A
    503 , 087 , 512 , 061 ,  908 , 170 , 897 , 275 ,
    653 , 426 , 154 , 509 ,  612 , 677 , 765 , 703 ,

    HERE A -  1 CELLS /  CONSTANT  N

    : IDUMP                         ( a n -- )
        0 ?DO
            I 16 MOD 0= IF  CR  THEN
            dup @ 4 .R  SPACE  CELL+
        LOOP DROP ;

[THEN]

\  HEAPSORT                 ( a n -- )
\     [Addresses of] records _R_1_,...,_R_N_ are rearranged in place.
\     After sorting is complete, their keys will be in order,
\     _K_1_,...,_K_N_. First we rearrange the file so it forms a heap,
\     then we repeatedly remove the top of the heap and transfer it to
\     the proper position.

DEFER PRECEDES   +++  ' < IS PRECEDES

: HEAPSORT                  ( a n -- )
    dup 2 < IF  2DROP  EXIT THEN
    SWAP >R                         ( n)
    \ H1.  Initialize.
    dup 2/ CELLS  SWAP  1- CELLS    ( l r)
    BEGIN
        \ H2.  Decrease _l_ or _r_.
+++     A N IDUMP  SPACE  over 1 CELLS / 1+ .  dup 1 CELLS / 1+ .
        over IF
            >R  1 CELLS -  R>
            over R@ + @  R> 2>R
        ELSE
            dup R@ + @  R> 2>R
            R@ @ over R@ + !
            1 CELLS -
            dup 0= IF  2DROP  2R> !  EXIT THEN
        THEN
        \ H3.  Prepare for siftup.
        over                        ( l r j)
        BEGIN
            \ H4.  Advance downward.
            dup 2* CELL+            ( l r i j)
            2 PICK over ( r j) < NOT
        WHILE
            \ H5.  Find larger child.
            2 PICK over ( r j) > IF
                dup R@ + @  over CELL+ R@ + @  PRECEDES 0<
                    IF  CELL+  THEN
            THEN
            \ H6.  Larger than _K_?
            2R@ DROP  over R@ + @  PRECEDES 0<
        WHILE
            \ H7.  Move it up.
            dup R@ + @  ROT R@ + !  ( l r j)
        REPEAT THEN                 ( l r i j)
        \ H8.  Store _R_.
        DROP                        ( l r i)
        2R> >R  SWAP R@ + !         ( l r)
    AGAIN ;

+++ A N HEAPSORT
+++ A N IDUMP

+++ REVISION OFF

\\  *************************  End of HEAPSORT  *************************

 503   87  512   61  908  170  897  275  653  426  154  509  612  677  765  703  9 16 
 503   87  512   61  908  170  897  703  653  426  154  509  612  677  765  275  8 16 
 503   87  512   61  908  170  897  703  653  426  154  509  612  677  765  275  7 16 
 503   87  512   61  908  612  897  703  653  426  154  509  170  677  765  275  6 16 
 503   87  512   61  908  612  897  703  653  426  154  509  170  677  765  275  5 16 
 503   87  512  703  908  612  897  275  653  426  154  509  170  677  765   61  4 16 
 503   87  897  703  908  612  765  275  653  426  154  509  170  677  512   61  3 16 
 503  908  897  703  426  612  765  275  653   87  154  509  170  677  512   61  2 16 
 908  703  897  653  426  612  765  275  503   87  154  509  170  677  512   61  1 16 
 897  703  765  653  426  612  677  275  503   87  154  509  170   61  512  908  1 15 
 765  703  677  653  426  612  512  275  503   87  154  509  170   61  897  908  1 14 
 703  653  677  503  426  612  512  275   61   87  154  509  170  765  897  908  1 13 
 677  653  612  503  426  509  512  275   61   87  154  170  703  765  897  908  1 12 
 653  503  612  275  426  509  512  170   61   87  154  677  703  765  897  908  1 11 
 612  503  512  275  426  509  154  170   61   87  653  677  703  765  897  908  1 10 
 512  503  509  275  426   87  154  170   61  612  653  677  703  765  897  908  1 9 
 509  503  154  275  426   87   61  170  512  612  653  677  703  765  897  908  1 8 
 503  426  154  275  170   87   61  509  512  612  653  677  703  765  897  908  1 7 
 426  275  154   61  170   87  503  509  512  612  653  677  703  765  897  908  1 6 
 275  170  154   61   87  426  503  509  512  612  653  677  703  765  897  908  1 5 
 170   87  154   61  275  426  503  509  512  612  653  677  703  765  897  908  1 4 
 154   87   61  170  275  426  503  509  512  612  653  677  703  765  897  908  1 3 
  87   61  154  170  275  426  503  509  512  612  653  677  703  765  897  908  1 2 
  61   87  154  170  275  426  503  509  512  612  653  677  703  765  897  908