\ The first idea was to represent the state of the sort as a sequence
\ of boundaries between subarrays; i.e., x 0 3 5 would mean that
\ x[0]..x[2] needs to be sorted and that x[3]..x[4] needs to be
\ sorted.  But it turns out that that's not so great when many keys
\ compare equal, so now we have a sequence of boundary pairs.  The one
\ above would be x 0 3 3 5, but it's also possible to have sequences
\ like 0 3 6 9, which would mean that x[3]..x[5] are already in the
\ right place and don't need to be sorted.

Variable seed 123456789 seed !


$10450405 Constant generator

: rnd  ( -- n )  seed @ generator um* drop 1+ dup seed ! ;

: choose ( n -- 0..n-1 )  rnd um* nip ;

s" gforth" environment? [if] 2drop
[else]
    : ]L ] postpone literal ;
    : th cells + ;
    : u>= u< 0= ;
    : u<= u> 0= ;
    : <= > 0= ;
    : -rot rot rot ;
[then]

[undefined] cell- [if]
    -1 cells 0 +field cell- ( n1 -- n2 ) drop
[then]

: exchange ( addr1 addr2 -- )
    over @ over @ >r swap ! r> swap ! ;

: order-partitions ( al1 ah1 al2 ah2 -- al3 ah3 al4 ah4 )
    \ put the smaller partition on top
    2over 2over swap - >r swap - r> u< if \ smaller on top
        2swap
    then ;

: partition ( al ah -- al1 ah1 al2 ah2 )
    \ assert( dup aligned dup = )
    over 2/ over 2/ + [ -1 cells ]L and @ >r
    2dup cell- begin ( al ah l r )
	2dup u<= while
	    swap begin
		dup @ r@ < while
		    cell+ repeat
	    swap begin
		dup @ r@ > while
		    cell- repeat
	    2dup u<= if
		2dup exchange swap cell+ swap cell- then
    repeat
    r> drop
    cell+ swap rot
    [defined] arrange-partitions [if]
        order-partitions
    [then] ;


\ iterative
: sorti ( addr u -- )
    cells over + 0 -rot begin ( 0 al1 ah1 .. aln ahn )
	begin
	    over cell+ over u>= while
		2drop dup 0= if
		    drop exit then
	repeat
	partition
    again ;

: sorti2 ( addr u -- )
    cells over + 0 -rot begin ( 0 al1 ah1 .. aln ahn )
	over cell+ over u< if
	    partition
	else
	    2drop
	then
    dup 0= until
    drop ;

[defined] contof [if]
    : sorti3 ( addr u -- )
        cells over + 0 -rot case ( 0 al1 ah1 .. aln ahn )
            over cell+ over u< ?of partition contof
            2drop dup ?of contof
        endcase ;
[then]

: sorti4 ( addr u -- )
    cells over + 0 -rot begin ( 0 al1 ah1 .. aln ahn )
        begin
            over cell+ over u< while
                partition
        repeat
        2drop
    dup 0= until
    drop ;

: sortd ( addr u -- )
    depth 2 - >r
    cells over + begin ( al1 ah1 .. aln ahn )
	over cell+ over u< if
	    partition
	else
	    2drop
	then
    depth r@ <= until
    r> drop ;

\ recursive (with explicit tail recursion)
: sort1 ( al ah -- )
    over cell+ over u< if
	partition recurse recurse
    else
	2drop
    then ;

: sortr ( addr u -- )
    cells over + sort1 ;

\ recursive (tail recursion converted to loop)
: sort2 ( al ah -- )
    begin
	over cell+ over u< while
	    partition recurse
    repeat
    2drop ;

: sortm ( addr u -- )
    cells over + sort2 ;

defer sort ( addr u -- )

\ sortm for the first levels of the call tree, sortm for the rest
256 1024 * constant order-limit \ L2 size on Skylake

: sort2a ( al ah -- )
    begin
	over order-limit + over u< while
	    partition order-partitions recurse
    repeat
    sort2 ;

: sortm2 ( addr u -- )
    cells over + sort2a ;






: fill-random { addr u -- }
    addr u th addr ?do
	u choose i !
    1 cells +loop ;

: print-array { addr u -- }
    addr u th addr ?do
	i @ 5 .r
    1 cells +loop ;

: bench ( usize uit -- )
    over cells allocate throw -rot
    0 ?do ( addr usize )
	2dup fill-random
	2dup sort
    loop
    2drop ;

\ 10000 constant N
\  
\ create a N cells allot
\ a N fill-random
\ cr a N print-array
\ cr a n sortd
\ cr a n print-array
\ .s cr