Groups | Search | Server Info | Keyboard shortcuts | Login | Register [http] [https] [nntp] [nntps]
Groups > comp.lang.forth > #26377
| From | "Ed" <invalid@invalid.com> |
|---|---|
| Newsgroups | comp.lang.forth |
| Subject | Baden's recursive Quicksort revisited |
| Date | 2013-10-11 01:31 +1000 |
| Organization | Aioe.org NNTP Server |
| Message-ID | <l36drg$t8$1@speranza.aioe.org> (permalink) |
Finding a recursive Quicksort that (a) works and (b) works over the full address
range is harder than one might imagine...
(p.s. Win32F developers: There appears to be a bug in the Win32F console.
If the SHOW routine below is modified to print all 16000 sorted numbers,
the console locks up after the run and nothing can be entered at the keyboard.
No such problem with other Windows Forths tried.)
-----------------------------------------------------
\ The Recursive Quicksort "qsort.txt" on Wil Baden's website is
\ buggy (try it!). Below is the version originally published in
\ FD Vol.6 No.5 which does seem to work. Modified here to handle
\ cellsize other than 2. Tested on several 16/32-bit Forths.
\ 2013-10-10 Ed.
\ Comment out what you already have.
-1 CELLS CONSTANT -CELL
: CELL- ( a1 -- a2 ) [ -1 CELLS ] LITERAL + ;
\ : CELL+ ( a1 -- a2 ) [ 1 CELLS ] LITERAL + ;
: NOT ( f1 -- f2 ) 0= ; \ surely everyone has this by now
( C.A.R.HOARE'S QUICKSORT. WWB/WWB 811012 )
DEFER PRECEDES ( a1,a2 -- f ) ( vectored execution )
' < IS PRECEDES
: QUICK ( a[m],a[n] -- ) ( partition a[m]..a[n] )
2DUP OVER - 2/ -CELL AND + @ >R ( take middle value as pivot )
2DUP SWAP
BEGIN ( m,n,j,i ) ( m <= i <= j <= n )
BEGIN DUP @ R@ PRECEDES WHILE CELL+ REPEAT SWAP
BEGIN R@ OVER @ PRECEDES WHILE CELL- REPEAT SWAP
2DUP U< NOT
IF 2DUP 2DUP @ >R @ SWAP ! R> SWAP ! SWAP CELL- SWAP CELL+ THEN
2DUP U<
UNTIL R> DROP ( m,n,j,i ) ( a <= j < i <= n )
ROT ( i,j,i,n ) 2OVER 2OVER - + > IF 2SWAP ( i,n,m,j ) THEN
2DUP U< IF RECURSE ELSE 2DROP THEN ( shorter part )
2DUP U< IF RECURSE ELSE 2DROP THEN ( longer part ) ;
: SORT ( a,n -- ) ( order a[0]..a[n-1] by "PRECEDES". )
?DUP 0= ABORT" nothing to sort."
1- CELLS OVER + ( a[0],a[n-1] ) QUICK ;
\ : (SORTED) R> DUP 2+ >R @ IS PRECEDES SORT ;
\ : SORTED ( a,n --<relation> ) ( order a[0]..a[n-1] by <relation> )
\ STATE @
\ IF COMPILE (SORTED)
\ ELSE ' IS PRECEDES SORT THEN ; IMMEDIATE
1 [if] \ TESTING
\ Simple random number generator from 'Starting Forth'
variable RND 1 rnd !
: RAND ( -- U ) rnd @ 31421 * 6727 + dup rnd ! ;
16000 unused 1000 - 1 rshift min constant SIZE
create NUMS size cells allot
size 100 / 1 max constant STEP
: INIT ( -- ) size 0 do rand i cells nums + ! loop ;
: SHOW ( -- ) cr size 0 do i cells nums + @ . step +loop ;
: TEST ( -- )
cr ." <press any key to begin> " key drop
cr ." Sorting " size . ." numbers ... "
init nums size sort
cr ." Showing a sample of sorted numbers: "
show ;
TEST
[then]
-----------------------------------------------------
Back to comp.lang.forth | Previous | Next — Next in thread | Find similar | Unroll thread
Baden's recursive Quicksort revisited "Ed" <invalid@invalid.com> - 2013-10-11 01:31 +1000
Re: Baden's recursive Quicksort revisited albert@spenarnc.xs4all.nl (Albert van der Horst) - 2013-10-10 15:49 +0000
Re: Baden's recursive Quicksort revisited anton@mips.complang.tuwien.ac.at (Anton Ertl) - 2013-10-10 17:42 +0000
Re: Baden's recursive Quicksort revisited "Ed" <invalid@invalid.com> - 2013-10-18 15:16 +1000
Re: Baden's recursive Quicksort revisited Andrew Haley <andrew29@littlepinkcloud.invalid> - 2013-10-20 03:18 -0500
Re: Baden's recursive Quicksort revisited anton@mips.complang.tuwien.ac.at (Anton Ertl) - 2013-10-21 16:33 +0000
Re: Baden's recursive Quicksort revisited Hans Bezemer <the.beez.speaks@gmail.com> - 2013-10-11 12:03 +0200
Re: Baden's recursive Quicksort revisited Alex McDonald <blog@rivadpm.com> - 2013-10-11 05:15 -0700
Re: Baden's recursive Quicksort revisited "Ed" <invalid@invalid.com> - 2013-10-13 12:25 +1000
Re: Baden's recursive Quicksort revisited "Alex McDonald" <blog@rivadpm.com> - 2013-10-13 08:59 +0100
Re: Baden's recursive Quicksort revisited Andrew Haley <andrew29@littlepinkcloud.invalid> - 2013-10-13 04:50 -0500
Comparing addresses (was: Baden's recursive Quicksort revisited) anton@mips.complang.tuwien.ac.at (Anton Ertl) - 2013-10-15 15:17 +0000
Re: Comparing addresses Andrew Haley <andrew29@littlepinkcloud.invalid> - 2013-10-15 14:34 -0500
Re: Comparing addresses anton@mips.complang.tuwien.ac.at (Anton Ertl) - 2013-10-16 14:15 +0000
Re: Comparing addresses Andrew Haley <andrew29@littlepinkcloud.invalid> - 2013-10-20 02:51 -0500
Re: Comparing addresses anton@mips.complang.tuwien.ac.at (Anton Ertl) - 2013-10-22 11:18 +0000
Re: Comparing addresses albert@spenarnc.xs4all.nl (Albert van der Horst) - 2013-10-22 13:26 +0000
Re: Comparing addresses anton@mips.complang.tuwien.ac.at (Anton Ertl) - 2013-10-22 13:39 +0000
Re: Comparing addresses Andrew Haley <andrew29@littlepinkcloud.invalid> - 2013-10-22 13:30 -0500
Re: Comparing addresses anton@mips.complang.tuwien.ac.at (Anton Ertl) - 2013-10-23 07:48 +0000
Re: Comparing addresses m.a.m.hendrix@tue.nl - 2013-10-23 23:49 -0700
Re: Comparing addresses anton@mips.complang.tuwien.ac.at (Anton Ertl) - 2013-10-24 09:01 +0000
Re: Baden's recursive Quicksort revisited albert@spenarnc.xs4all.nl (Albert van der Horst) - 2013-10-13 12:06 +0000
Re: Baden's recursive Quicksort revisited all2001@spambog.com (Wolfgang Allinger) - 2013-10-13 11:42 -0400
Re: Baden's recursive Quicksort revisited "Ed" <invalid@invalid.com> - 2013-10-13 12:27 +1000
Re: Baden's recursive Quicksort revisited Hans Bezemer <the.beez.speaks@gmail.com> - 2013-10-16 10:35 +0200
Re: Baden's recursive Quicksort revisited Andrew Haley <andrew29@littlepinkcloud.invalid> - 2013-10-16 03:51 -0500
Re: Baden's recursive Quicksort revisited albert@spenarnc.xs4all.nl (Albert van der Horst) - 2013-10-16 10:50 +0000
Re: Baden's recursive Quicksort revisited anton@mips.complang.tuwien.ac.at (Anton Ertl) - 2013-10-16 14:27 +0000
Re: Baden's recursive Quicksort revisited "Ed" <invalid@invalid.com> - 2013-10-18 15:37 +1000
csiph-web