home *** CD-ROM | disk | FTP | other *** search
/ World of Shareware - Software Farm 2 / wosw_2.zip / wosw_2 / QBAS / BAS_SORT.ZIP / MWSSRT2.BAS < prev    next >
BASIC Source File  |  1989-06-28  |  4KB  |  109 lines
  1.         '
  2.         '    COPYRIGHT *c* 1989, Mike Shaffer - ALL RIGHTS RESERVED WORLDWIDE
  3.         '    AUTHOR GRANTS RIGHTS TO USE FREELY PROVIDED THIS COPYRIGHT NOTICE
  4.         '    IS INCLUDED
  5.         '
  6.         '
  7.         '       SUB:            XSORT2
  8.         '       AUTHOR:         Mike Shaffer (for Michael Welch)
  9.         '       CREATION DATE:  27-June-89
  10.         '       VERSION:        2.0
  11.         '       LAST REVISION:
  12.         '       PURPOSE:        This SUB will accept a string array and
  13.         '                       sort it. The sorted element number map
  14.         '                       is returned, and the source string array
  15.         '                       is unchanged.
  16.         '                       This program is based on a modified ripple 
  17.         '                       sort algorithm originally written by Richard 
  18.         '                       Ashwell III.
  19.         '                       Through judicious use of better QB 
  20.         '                       programming methods, I was able to speed 
  21.         '                       his program up by a factor of nearly 10 
  22.         '                       (e.g. to sort 2000 records, Quicksort 
  23.         '                       takes about 2.5 minutes, MNTSORT takes 46.25 
  24.         '                       seconds, while MWSSORT took 1.45 seconds!)
  25.         '
  26.         '       PASSED:         ar$()           => String array to be sorted
  27.         '                       arN%            => Number of elements to sort
  28.         '       RETURNS:        XSRTIME!        => Time it took to sort
  29.         '                       ar%()           => element numbers in order
  30.         '                       arn%            => will be trashed
  31.         '
  32.         '       CALLING CONV:   [CALL] XSORT2 [(] ar$(), arn%, ar%(), XSRTIME! [)]
  33.         '
  34.         '
  35.         '       MISC NOTES:     plane% and wave% should be dimensioned to the
  36.         '                       same number of elements contained in ar$ (or
  37.         '                       more). This is currently set up for a max of 
  38.         '                       2,000 entries.
  39.         '
  40.         '
  41.         SUB xsort2(ar$(1),arn%,ar%(1),xsrtime!) STATIC
  42.            '
  43.            DIM plane%(2000),wave%(2000)
  44.            FOR x%=1 TO 2000 : ar%(x%)=x% : NEXT
  45.            '
  46.            stime! = TIMER
  47.  
  48.            dreg%=1
  49.            plane%(dreg%)=1
  50.            wave%(dreg%)=arn%
  51.            ereg%=1
  52.            areg%=arn%
  53.  
  54. xsr2100:   IF (areg%-ereg%)<9 THEN GOTO xsr2230
  55.            breg%=ereg%:creg%=areg%
  56. xsr2120:   IF ar$(ar%(breg%))>ar$(ar%(creg%)) THEN GOTO xsr2170
  57. xsr2130:   creg%=creg%-1
  58.            IF creg%>breg% THEN GOTO xsr2120
  59.            creg%=creg%+1
  60. xsr2150:   dreg%=dreg%+1
  61.            IF (breg%-ereg%)<(areg%-creg%) THEN GOTO xsr2220
  62.            plane%(dreg%)=ereg%
  63.            wave%(dreg%)=breg%
  64.            ereg%=creg%
  65.            GOTO xsr2100
  66.  
  67. xsr2170:   tmp%=ar%(breg%)
  68.            ar%(breg%)=ar%(creg%)
  69.            ar%(creg%)=tmp%
  70.            goto xsr2190
  71. xsr2180:   IF ar$(ar%(creg%))<ar$(ar%(breg%)) THEN GOTO xsr2210
  72. xsr2190:   breg%=breg%+1
  73.            IF creg%>breg% THEN GOTO xsr2180
  74.            creg%=creg%+1
  75.            GOTO xsr2150
  76. xsr2210:   tmp%=ar%(breg%)
  77.            ar%(breg%)=ar%(creg%)
  78.            ar%(creg%)=tmp%
  79.            GOTO xsr2130
  80.  
  81. xsr2220:   plane%(dreg%)=creg%
  82.            wave%(dreg%)=areg%
  83.            areg%=breg%
  84.            GOTO xsr2100
  85. xsr2230:   IF (areg%-ereg%+1)=1 THEN GOTO xsr2270
  86.            FOR breg%=(ereg%+1) TO areg%
  87.               FOR creg%=ereg% TO (breg%-1)
  88.                  freg%=breg%-creg%+ereg%-1
  89.                  IF ar$(ar%(freg%))<=ar$(ar%(freg%+1)) THEN
  90.                     EXIT FOR
  91.                  ELSE
  92.                     tmp%=ar%(breg%)
  93.                     ar%(breg%)=ar%(creg%)
  94.                     ar%(creg%)=tmp%
  95.                  END IF
  96.               NEXT creg%
  97.            NEXT breg%
  98. xsr2270:   ereg%=plane%(dreg%)
  99.            areg%=wave%(dreg%)
  100.            dreg%=dreg%-1
  101.            IF dreg%<>0 THEN GOTO xsr2100
  102.  
  103.            etime! = TIMER
  104.            xsrtime! = etime! - stime!
  105.            '
  106.         END SUB
  107.  
  108. 
  109.