All pastes #269400 Raw Edit

partitionQ

public text v1 · immutable
·published 2006-12-06 15:45 UTC
rendered paste body
: exchange ( addr1 addr2 -- )  2dup  @ >r  @ swap !  r> swap ! ;
: cell- ( n -- n' )  [ 1 cells ] literal - ;

: select-pivot ( L R -- pivot )  nip @ ;

: partition ( L R -- L1 R1  L2 R2 )
  2dup  select-pivot >r
  2dup begin
            swap begin dup @ r@ > while  cell+ repeat
	swap begin r@ over @ > while  cell- repeat
  2dup <= if  2dup exchange  cell- swap  cell+ swap  then
  2dup > until  r> drop  swap rot ;

: shorter-segment ( L1 R1  L2 R2 -- L1 R1  L2 R2 | L2 R2  L1 R1 )
\ Bring the shorter of the two segments to the top of the stack.
  2over 2over  -  +  > if 2swap then ;

: qsort ( L R -- )  begin  2dup < while  partition shorter-segment recurse  repeat  2drop ;

: endpoints ( addr u -- L R )  1- cells over + ;

create a  2 , 4 , 6 , 3 , 1 , 0 , 9 , 7 , 8 , 120 ,
10 constant /a

: .a  /a 0 do a i cells + @ . loop cr ;

.a
a /a endpoints qsort
.a