1: \ .( Loading Bubble Sort benchmark...) cr
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>