File:  [gforth] / gforth / bubble.fs
Revision 1.2: download - view: text, annotated - select for diffs
Mon May 17 13:51:31 1999 UTC (24 years, 10 months ago) by jwilke
Branches: MAIN
CVS tags: v0-7-0, v0-6-2, v0-6-1, v0-6-0, v0-5-0, HEAD
Added cell definition to be ANS compatible.

    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: 1 cells Constant cell
   13: 
   14: variable seed ( -- addr)
   15: 
   16: : initiate-seed ( -- )  74755 seed ! ;
   17: : random  ( -- n )  seed @ 1309 * 13849 + 65535 and dup seed ! ;
   18: 
   19: 6000 constant elements ( -- int)
   20: 
   21: align create list elements cells allot
   22: 
   23: : initiate-list ( -- )
   24:   list elements cells + list do random i ! cell +loop
   25: ;
   26: 
   27: : dump-list ( -- )
   28:   list elements cells + list do i @ . cell +loop cr
   29: ;
   30: 
   31: : verify-list ( -- )
   32:   list elements 1- cells mybounds do
   33:     i 2@ > abort" bubble-sort: not sorted"
   34:   cell +loop
   35: ;
   36: 
   37: : bubble ( -- )
   38: \ ." bubbling..." cr
   39:   1 elements 1 do
   40:     list elements i - cells mybounds do
   41:       i 2@ > if i 2@ swap i 2! then
   42:     cell +loop 
   43:   loop
   44: ;
   45: 
   46: : bubble-sort ( -- )
   47:   initiate-seed
   48:   initiate-list
   49:   bubble
   50:   verify-list
   51: ;
   52: 
   53: : bubble-with-flag ( -- )
   54:   1 elements 1 do
   55:     -1 list elements i - cells mybounds do
   56:       i 2@ > if i 2@ swap i 2! drop 0 then
   57:     cell +loop 
   58:     if leave then
   59:   loop
   60: ;
   61:   
   62: : bubble-sort-with-flag ( -- )
   63:   initiate-seed
   64:   initiate-list
   65:   bubble-with-flag
   66:   verify-list
   67: ;
   68: 
   69: : main	( -- )
   70: 	bubble-sort
   71: \	bubble-sort-with-flag
   72: ;
   73: 
   74: 

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