Download code

Jump to: navigation, search

Back to Quicksort_(Forth)

Download for Windows: single file, zip

Download for UNIX: single file, zip, tar.gz, tar.bz2

quicksort.fs

 1 (* The authors of this work have released all rights to it and placed it
 2 in the public domain under the Creative Commons CC0 1.0 waiver
 3 (http://creativecommons.org/publicdomain/zero/1.0/).
 4 
 5 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
 6 EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
 7 MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
 8 IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
 9 CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
10 TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
11 SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
12 
13 Retrieved from: http://en.literateprograms.org/Quicksort_(Forth)?oldid=10824
14 *)
15 
16 -1 cells constant -cell
17 : cell-   -cell + ;
18 
19 defer lessthan ( a@ b@ -- ? )   ' < is lessthan
20 
21 : mid ( l r -- mid ) over - 2/ -cell and + ;
22 
23 : exch ( addr1 addr2 -- ) dup @ >r over @ swap ! r> swap ! ;
24 
25 : part ( l r -- l r r2 l2 )
26   2dup mid @ >r ( r: pivot )
27   2dup begin
28     swap begin dup @  r@ lessthan while cell+ repeat
29     swap begin r@ over @ lessthan while cell- repeat
30     2dup <= if 2dup exch >r cell+ r> cell- then
31   2dup > until  r> drop ;
32 
33 : qsort ( l r -- )
34   part  swap rot
35   \ 2over 2over - + < if 2swap then
36   2dup < if recurse else 2drop then
37   2dup < if recurse else 2drop then ;
38 
39 : sort ( array len -- )
40   dup 2 < if 2drop exit then
41   1- cells over + qsort ;
42 create test 4 , 7 ,  1 , 0 , 3 , 9 , 6 , 8 , 2 , 5 ,
43 
44 : main
45   test 10 sort
46   10 0 do test i cells + @ . loop cr ;
47 
48 main bye


hijacker
hijacker
hijacker
hijacker