
SCR # 21
  0 ( 16 bit Numerical Sort Demo                      20AUG82MIM)   
  1
  2 FORTH DEFINITIONS  HEX
  3 7000 CONSTANT ARRAY1      ( address of data array)
  4 VARIABLE #ELEMENTS     ( number of 16 bit elements)
  5 VARIABLE DISTANCE      ( distance between elements)    
  6 VARIABLE VI            ( temporary indexes for nested DO's)
  7 VARIABLE VJ
  8 VARIABLE SEED   HERE SEED !
  9
 10 : RND           ( random # generator)   ( n --- )
 11    SEED @ 103 * 3 + 7FFF AND
 12      DUP SEED !  7FFF */ ;
 13 : CLRS PAGE CR CR 17 SPACES ." FORTH SORTING DEMO" CR ;
 14 : KEYMSG  ." any key continues.." CR KEY DROP ;
 15




SCR # 22
  0 ( 16 bit Numerical Sort Demo                      20AUG82MIM)
  1                                                   
  2 : RANDOM                  ( create random pattern in ARRAY1)
  3    #ELEMENTS @ 2* 0      ( set loop limit and initial index)
  4       DO 3E8 RND         ( fetch random # between 0 and 999)
  5          I 3 MOD 0= IF NEGATE      ( negate 1 out of three)
  6       THEN I ARRAY1 + !               ( store in array)
  7          2 +LOOP ;                    ( increment loop)
  8
  9 : REVERSE               ( create reversed pattern in ARRAY1)
 10    #ELEMENTS @ 0         ( set loop limit and initial index)
 11       DO #ELEMENTS @ I -               ( compute value)
 12          I 2* ARRAY1 + !              ( store in array)
 13       LOOP ;                          ( decrement loop)
 14
 15





SCR # 23
  0 ( 16 bit Numerical Sort Demo                      20AUG82MIM)
  1
  2 : NUM(I) @ ARRAY1 + ;            ( array fetch)
  3 : NUMI@ NUM(I) @ ;               ( and store)
  4 : NUMI! NUM(I) ! ;               ( operators)
  5
  6 : COMPARE VI NUMI@ VJ NUMI@ > ;     ( true if #I > #J)
  7
  8 : NUMSWAP          ( swap elements of array)   ( --- )
  9    VI NUMI@ VJ NUMI@ VI NUMI! VJ NUMI! ;
 10
 11 : NUMLIST             ( output number array)   ( --- )
 12    #ELEMENTS @ 2* 0 DO I DUP
 13       1A MOD 0= IF CR THEN ARRAY1 + @
 14          6 .R 2 +LOOP CR CR ;
 15




SCR # 24
  0 ( 16 bit Numerical Sort Demo                      20AUG82MIM)
  1
  2 : BUBBLESORT              ( sort data array)   ( --- )
  3    #ELEMENTS @ 1- 2* 0 DO I VI !
  4       #ELEMENTS @ 2* I 2+ DO I VJ !
  5          COMPARE IF NUMSWAP
  6       THEN 2 +LOOP 2 +LOOP ;
  7
  8 : SHUTTLESORT             ( sort data array)   ( --- )
  9    #ELEMENTS @ 1- 2* 0 DO
 10       -2 I DO I DUP VI ! 2+ VJ !
 11          COMPARE IF NUMSWAP ELSE LEAVE
 12       THEN -2 +LOOP 2 +LOOP ;
 13
 14 ( For decending sorts change > in COMPARE to <)
 15





SCR #25
  0 ( 16 bit Numerical Sort demo                      20AUG82MIM)
  1
  2 : SETDIST              ( set initial distance)    ( --- )
  3    1 BEGIN 2* DUP #ELEMENTS @ >
  4        UNTIL 2- DISTANCE ! ;
  5
  6 : DECDIST             ( decrement distance)   ( --- flag)
  7     DISTANCE @ 2/ 2/ 2* DUP DISTANCE ! 2 < ;
  8
  9     ( Shell-Metzner sort)
 10 : SHELLSORT  SETDIST BEGIN    ( sort data array)  ( --- )
 11    #ELEMENTS @ 2* DISTANCE @ - 0 DO -2 I DO
 12       I DUP VI ! DISTANCE @ + VJ ! COMPARE IF
 13          NUMSWAP ELSE LEAVE THEN DISTANCE @ NEGATE
 14             +LOOP 2 +LOOP DECDIST UNTIL ;
 15




SCR # 26
  0 ( 16 bit Numerical Sort Demo                      20AUG82MIM)
  1    ( benchmark it)
  2 : #ELEMENTS?  CR ." How many elements?  " QUERY CR CR
  3    INTERPRET #ELEMENTS ! ." random array" RANDOM NUMLIST ;
  4 : REVIT  CR ." reversed array" REVERSE NUMLIST ;
  5
  6 : BUBBS  #ELEMENTS? ." random bubblesort.." CR BEEP
  7    BUBBLESORT BEEP NUMLIST KEYMSG ." sorting sorted array.."
  8    CR BEEP BUBBLESORT BEEP KEYMSG REVIT
  9    ." reverse bubblesort.." CR BEEP BUBBLESORT BEEP
 10    NUMLIST KEYMSG ;
 11 : SHUTS  #ELEMENTS? ." random shuttlesort.." CR BEEP
 12    SHUTTLESORT BEEP NUMLIST KEYMSG ." sorting sorted array.."
 13    CR BEEP SHUTTLESORT BEEP KEYMSG REVIT
 14    ." reverse shuttlesort.." CR BEEP SHUTTLESORT BEEP
 15    NUMLIST KEYMSG ;





SCR # 27
  0 ( 16 bit Numerical Sort Demo                      20AUG82MIM)
  1
  2 : SHELS  #ELEMENTS? ." random shellsort.." CR BEEP
  3    SHELLSORT BEEP NUMLIST KEYMSG ." sorting sorted array.."
  4    CR BEEP SHELLSORT BEEP KEYMSG REVIT
  5    ." reverse shellsort.." BEEP SHELLSORT BEEP
  6    NUMLIST KEYMSG ;
  7 : DECODE  DUP 31 = IF BUBBS ELSE DUP 32 = IF SHUTS ELSE
  8    DUP 33 = IF SHELS ELSE 34 = IF QUIT THEN THEN THEN THEN ;
  9 : MENU  CR CR ." Specify sort algorithm:" CR
 10    ." 1 - Bubblesort" CR ." 2 - Shuttlesort" CR
 11       ." 3 - Shellsort" CR ." 4 - Exit demo " BEGIN
 12    KEY DUP 30 > OVER 35 < AND NOT WHILE DROP REPEAT ;
 13
 14 : DEMO  BEGIN CLRS MENU DUP DECODE AGAIN ;
 15         DECIMAL