\ This was originally part of the novice.4th package, but then I decided to only include heap-sort there, as it is adequate.
\ The SORT.4TH file is included to allow the novice to experiment with sort algorithms.

\ Needs NOVICE.4TH already loaded.


marker sort.4th


\ ****** 
\ ****** This is the framework for a sort of an array.
\ ****** It is not reentrant; the comparer function can't do a SORT of its own.
\ ****** Our array record size must be a multiple of W. This is assured if FIELD is used for creating the record.
\ ****** 

item array      \ adr of array
item limit      \ number of elements in array
item recsiz     \ size of a record
item 'comparer  \ xt of compare function ( adrX adrY -- X>Y? )

defer <sort>  ( -- )                    \ the above items must already be set

\ <SORT> is deferred in order to allow the user to write his own sort routine.
\ I have HEAP-SORT written already, but there are a wide variety of algorithms available.
\ HEAP-SORT is not the fastest algorithm, but it is pretty consistent --- you don't get any occasional slow runs.

macro: adr ( index -- adr )             \ needs ARRAY and RECSIZ set
    recsiz *  array + ;

: sort ( adr lim siz 'comparer -- )
    to 'comparer
    to recsiz
    to limit
    to array
    recsiz  [ w 1- ] literal  and  abort" *** SORT: record size must be a multiple of the cell size ***"
    <sort> ;    

    
\ ****** 
\ ****** This tests SORT.
\ ****** 

create aaa  2 , 9 , 3 , 6 , 1 , 4 , 5 , 7 , 0 , 8 ,

: print-aaa ( limit -- )
    cells aaa +  aaa do  I @ .  w +loop ;

: int> ( adrX adrY -- X>Y? )
    swap @  swap @  > ;
    
: test-sort ( limit -- )
    cr  dup print-aaa
    aaa  over  w  ['] int>  sort 
    cr  print-aaa ;    
        
    
\ ****** 
\ ****** This sets <SORT> to HEAP-SORT.
\ ****** This code was ported from C++ at: http://www.snippets.24bytes.com/2010/06/heap-sort.html
\ ****** 

: left ( x -- y )       2*  1+ ;
    
: right ( x -- y )      2*  2 + ;    

: heapify ( x -- )
    dup >r  begin   \ r: -- great
        dup left    dup limit < if      dup adr  rover adr  'comparer execute if    rdrop  dup >r   then then  drop
        dup right   dup limit < if      dup adr  r@ adr     'comparer execute if    rdrop  dup >r   then then  drop
        dup r@ <> while
            adr  r@ adr  recsiz exchange
            r@ repeat
    drop rdrop ;
                
: build-max-heap ( -- )
    limit 1- 2/  begin  dup 0>= while  dup heapify  1- repeat drop ;
    
: heap-sort ( -- )
    build-max-heap
    begin  limit while  -1 +to limit
        0 adr  limit adr  recsiz exchange
        0 heapify  repeat ;
        
' heap-sort is <sort>        


\ ****** 
\ ****** This sets <SORT> to QUICK-SORT.
\ ****** This code was ported from C++ at: http://www.snippets.24bytes.com/2010/06/quick-sort.html
\ ****** 

char & comment  \ we use heap-sort as our default and comment out the quick-sort code

\ This is a pretty simple implementation of quick-sort, which is why we aren't using it.
\ It is inefficient to do the recursion all the way to the bitter end.
\ Better is to switch to another algorithm for the small partitions, especially if 'COMPARER is very time-consuming.
\ There are optimized sorting algorithms for small arrays, such as 7 elements or less.
\ Also, we are just using the last value in the array as our pivot value.
\ Better is to pick three values and use the median, to increase the chance of having roughly equal partitions.

\ Upgrading QUICK-SORT will be left as an exercise of the reader. Until then, we will just use HEAP-SORT for sorting.

: partition ( lft rht -- mid )                      \ use the last element in the partition as the pivot
    >r >r                                           \ --                        \r: -- rht lft
    rr@ adr  r@ 1-  2r> do                          \ -- last low               \r: --
        over  I adr  'comparer execute if
            1+                                      \ -- last low+1
            dup adr  I adr  recsiz exchange  then
        loop
    1+ tuck  adr  recsiz exchange ;
        
: <quick-sort> ( lft rht -- )    
    2dup < if
        2dup partition 2>r                          \ -- lft                    \r: -- rht mid
        r@ 1-  recurse
        2r>  1+  swap recurse  exit then
    2drop ;
            
: quick-sort ( -- )            
    0  limit 1-  <quick-sort> ;

' quick-sort is <sort>    

&