CombSort

\ Combsort
\ Adapted from code by Wayne Conrad and Nick Estes

defer less

: newgap ( gap -- gap )
  10 13 */
  dup 9 11 within if
    drop 11
  then 1 max ;

: swap-by-pointer? ( p1 p2 -- flag )
  >r dup @ r@ @ less if
    r@ @ over @ r> ! swap ! -1 else
    r> 2drop 0 then ; 

: comb ( gap 0 array length -- flag )
  bounds ?do
    over i + i swap-by-pointer? or 
  1 cells +loop nip ;

: combsort ( array length -- ) 
  dup
  begin
    newgap dup >r cells
    0 2over r@ - cells comb
    r@ swap 0= r> 2 < and
  until
  drop 2drop ;

' < is less
10 Constant LENGTH
create array
1 , 6 , 5 , 3 , 8 , 9 , 7 , 2 , 4 , 0 ,

: .array ( array length -- )
  cells bounds ?do
    i @ .
  1 cells +loop ;

: main ( array length -- )
   2dup combsort
   .array
;

array 10 main

\ combsort with duplicates removed

defer less
defer equal

: newgap ( gap -- gap )
  10 13 */
  dup 9 11 within if
    drop 11
  then 1 max ;

: swap-by-pointer? ( p1 p2 -- 0 0 | -1 0 | p2 -1 )
  over @ over @ ( p1 p2 a b )
  2dup less if
    swap rot ! swap ! -1 0 else
    equal if nip -1 else 0 0 then
  then ;

: comb-and-remove ( gap 0 array length -- end-of-array flag )
  2>R begin
    over r'@ + r'@ swap-by-pointer? 
      if 
        dup cell+ swap r'@ over - move r'@ 1 cells - 2r> nip 2>r else
        or
      then 
    r> 1 cells + >R r@ r'@ u< 0= 
  until 2r> drop swap ;

: combsort ( array length -- ) 
  dup
  begin
    newgap dup >r cells
    0 2over r@ - cells comb
    2>r over r'@ - 1 cells / 
    r@ swap 0= r> 2 < and
  until
  drop 2drop ;