home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / OSK / EFFO / pd6.lzh / TST / tree_sort.tst < prev   
Text File  |  1989-12-21  |  3KB  |  119 lines
  1. .( Loading Tree Sort benchmark...) cr
  2.  
  3. \ A classical benchmark of an O(log n) algorithm; Tree Sort
  4. \
  5. \ Part of the programs gathered by John Hennessy for the MIPS
  6. \ RISC project at Stanford. Translated to forth by Matin Freamen,
  7. \ Johns Hopkins University/Applied Physics Laboratory.
  8.  
  9. 4 constant cell
  10.  
  11. : cells ( n -- m)  cell * ;
  12. : align ( -- ) here cell 1- and allot ;
  13.  
  14. : exchange ( x y -- ) dup @ rot dup @ >r ! r> swap ! ;
  15.  
  16. variable seed
  17.  
  18. : initiate-seed ( -- )  74755 seed ! ;
  19. : random  ( -- n )  seed @ 1309 * 13849 + 65535 and dup seed ! ;
  20.  
  21. \ These structure access words were originally developed by
  22. \ at JHU/APL by Ben Ballard and John Hayes
  23. \ Structure access words
  24. \ Examples of use:
  25. \ structure foo  \ declare a structure named foo
  26. \       wrd: .thing1 \ with a one word field named .thing1
  27. \    2 wrds: .thing2 \ and a two word field named .thing2
  28. \ endstructure
  29. \
  30. \ structure foobar \ another structure
  31. \           wrd: .thing
  32. \    foo struct: .blah \ nested structure
  33. \ endstructure
  34. \
  35. \ foobar makestruct test \ allocate space for a structure instance
  36. \ 1234 test .blah .thing1 ! \ access structure
  37.  
  38. : structure ( --- structure offset0)
  39.   create
  40.     here 0 , 0
  41.   does> ( structure -- size)
  42.     @ ;
  43.  
  44. : struct: ( offset1 size --- offset2)
  45.   create
  46.     over , +
  47.   does> ( structure field -- field-addr)
  48.     @ + ; 
  49.  
  50. : wrds: ( offset1 size --- offset2)  cells struct: ;
  51. : wrd: ( offset1 --- offset2)  cell struct: ;
  52. : endstructure ( structure size --- ) swap ! ;
  53. : makestruct ( size --- )  create allot ;
  54. : malloc  ( structure -- instance)  here swap allot ;
  55.  
  56. \ The Tree Sort definitions:
  57.  
  58. structure node ( -- )
  59.  wrd: .left
  60.  wrd: .right
  61.  wrd: .val
  62. endstructure
  63.  
  64. 5000 constant tree-size
  65. variable tree
  66.  
  67. : create-node ( n t -- )
  68.   node malloc dup >r swap !
  69.   r@ .val !
  70.   nil r@ .left !
  71.   nil r> .right ! ;
  72.  
  73. : insert-node ( n t -- )
  74.   over over .val @ >
  75.   if dup .left @ nil =
  76.     if over over .left create-node
  77.     else over over .left @ recurse then
  78.     else over over .val @ <
  79.       if dup .right @ nil =
  80.        if over over .right create-node
  81.        else over over .right @ recurse then
  82.       then
  83.     then
  84.  drop drop ;
  85.  
  86. : verify-tree ( t -- f)
  87.   true >r dup .left @ nil = not
  88.   if dup .left @ .val @ over .val @ > not
  89.     if r> drop false >r 
  90.     else dup .left @ recurse r> and >r then
  91.   then 
  92.   dup .right @ nil = not
  93.   if dup .right @ .val @ over .val @ < not
  94.     if r> drop false >r
  95.     else dup .right @ recurse r> and >r then
  96.  then
  97.  drop r> ;
  98.  
  99. : dump-tree ( t -- )
  100.   dup nil = not
  101.   if dup .right @ recurse
  102.     dup .val @ .
  103.     dup .left @ recurse
  104.   then
  105.   drop ;
  106.  
  107. : tree-sort   ( -- )
  108.   initiate-seed
  109.   random tree create-node
  110.   tree @
  111.   tree-size 0 do
  112.     random over insert-node
  113.   loop
  114.   verify-tree not abort" trees: wrong result" ;
  115.  
  116.   forth only
  117.   
  118.  
  119.