\ -*- mode: forth -*-
\ $Id: heapsort.gforth,v 1.1 2001/05/26 16:07:27 doug Exp $
\ http://www.bagley.org/~doug/shootout/
\ from Anton Ertl

0. argc @ 1- arg >number 2drop drop constant NUM

139968 constant IM
  3877 constant IA 
 29573 constant IC 

variable SEED
42 SEED !


: format-float  
  f$ dup >r 0<=
  IF    '0 emit
  ELSE  scratch r@ min type  r@ precision - zeros  THEN
  '. emit r@ negate zeros
  scratch r> 0 max /string 0 max -zeros type ;

: gen_random 
  IA SEED @ * IC + IM mod dup SEED ! s>d d>f
  f* [ IM s>d d>f ] fliteral f/ ;

: heap-sort 
    swap { ra }
    dup 2/ 1+ begin 
    dup 1 > if  
        1- dup floats ra + f@ 
    else
        over floats ra + dup >r f@ 
        1 floats ra + f@ r> f! 
        swap 1- dup 1 = if 
        1 floats ra + f!
        2drop exit
        endif
        swap endif 
    { ir l } 
    l l 2* begin 
        dup ir <=
    while 
        dup ir < if
        dup floats ra + dup f@ float+ f@ f< if
            1+
        endif
        endif
        dup floats ra + f@ fover fover f< if 
        over floats ra + f!
        nip dup 2*
        else
        fdrop drop ir 1+
        endif
    repeat
    drop floats ra + f!
    ir l
    again ;

: main 
    NUM 1+ floats allocate throw 
    dup NUM floats bounds ?do
    1e gen_random i f!
    1 floats +loop
     dup NUM heap-sort
    NUM floats + f@ format-float cr ;

10 set-precision main bye