File:  [gforth] / gforth / bubble.fs
Revision 1.1: download - view: text, annotated - select for diffs
Mon Nov 13 18:38:35 1995 UTC (28 years, 4 months ago) by anton
Branches: MAIN
CVS tags: v0-4-0, v0-3-0, v0-2-1, v0-2-0, gforth-0_1beta, HEAD
added benchmark files

    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>