File:  [gforth] / gforth / bubble.fs
Mon Nov 13 18:38:35 1995 UTC (25 years, 10 months ago) by anton
Branches: MAIN
CVS tags: v0-4-0, v0-3-0, v0-2-1, v0-2-0, gforth-0_1beta, HEAD

2:
3: \ A classical benchmark of an O(n**2) algorithm; Bubble sort
4: \
5: \ Part of the programs gathered by John Hennessy for the MIPS
6: \ RISC project at Stanford. Translated to forth by Marty Fraeman
7: \ Johns Hopkins University/Applied Physics Laboratory.
8:
9: \ MM forth2c doesn't have it !
10: : mybounds  over + swap ;
11:
12: variable seed ( -- addr)
13:
14: : initiate-seed ( -- )  74755 seed ! ;
15: : random  ( -- n )  seed @ 1309 * 13849 + 65535 and dup seed ! ;
16:
17: 6000 constant elements ( -- int)
18:
19: align create list elements cells allot
20:
21: : initiate-list ( -- )
22:   list elements cells + list do random i ! cell +loop
23: ;
24:
25: : dump-list ( -- )
26:   list elements cells + list do i @ . cell +loop cr
27: ;
28:
29: : verify-list ( -- )
30:   list elements 1- cells mybounds do
31:     i 2@ > abort" bubble-sort: not sorted"
32:   cell +loop
33: ;
34:
35: : bubble ( -- )
36: \ ." bubbling..." cr
37:   1 elements 1 do
38:     list elements i - cells mybounds do
39:       i 2@ > if i 2@ swap i 2! then
40:     cell +loop
41:   loop
42: ;
43:
44: : bubble-sort ( -- )
45:   initiate-seed
46:   initiate-list
47:   bubble
48:   verify-list
49: ;
50:
51: : bubble-with-flag ( -- )
52:   1 elements 1 do
53:     -1 list elements i - cells mybounds do
54:       i 2@ > if i 2@ swap i 2! drop 0 then
55:     cell +loop
56:     if leave then
57:   loop
58: ;
59:
60: : bubble-sort-with-flag ( -- )
61:   initiate-seed
62:   initiate-list
63:   bubble-with-flag
64:   verify-list
65: ;
66:
67: : main	( -- )
68: 	bubble-sort
69: \	bubble-sort-with-flag
70: ;
71:
72:

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>