home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / TURBO.ZIP / QLSORT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1984-07-03  |  4.1 KB  |  118 lines
  1. const max = 1000;   {max array size}
  2. type standardarray = array[0..max] of string[8];
  3. type pointarray    = array[0..max] of integer;
  4. var  words     : standardarray; {numeric array}
  5.      pointer   : pointarray;
  6.      last,i    : integer;
  7.  
  8.  
  9. procedure swap( var a,b: integer );
  10. var t: integer;
  11. begin
  12.     t := a;
  13.     a := b;
  14.     b := t
  15. end;
  16.  
  17.  
  18. procedure bsort( start, top: integer;
  19.                  var arry: standardarray;
  20.                  var pointer: pointarray );
  21. {bubble sort procedure. sorts array from start to top inclusive}
  22. var index:    integer;
  23.     switched: boolean;
  24. begin {bsort}
  25.     repeat
  26.          switched := false;
  27.          for index := start to top-1 do
  28.              begin
  29.                  if arry[pointer[index]] > arry[pointer[index+1]] then
  30.                     begin
  31.                         swap( pointer[index], pointer[index+1] );
  32.                         switched := true;
  33.                     end
  34.              end;
  35.     until switched = false;
  36. end; {bsort}
  37.  
  38. procedure findmedian( start, top: integer;
  39.                        var arry: standardarray;
  40.                        var pointer : pointarray );
  41. {procedure to find a good median value in array and place it}
  42. var middle: integer;
  43.     sorted: standardarray;
  44. begin {findmedian}
  45.     middle    := (start + top) div 2;
  46.     sorted[1] := arry[pointer[start]];
  47.     sorted[2] := arry[pointer[top]];
  48.     sorted[3] := arry[pointer[middle]];
  49.  
  50.     if (sorted[2] > sorted[1]) and (sorted[2] < sorted[3]) then
  51.        swap( pointer[start], pointer[middle] )
  52.     else if (sorted[3] > sorted[1]) and (sorted[3] < sorted[2])  then
  53.        swap( pointer[start], pointer[top] );
  54. end; {findmedian}
  55.  
  56. procedure sortsection( start, top: integer;
  57.                        var arry: standardarray;
  58.                        var pointer : pointarray);
  59. {procedure to sort a section of the main array, and }
  60. {then divide it into two partitions to be sorted    }
  61. var swapup: boolean;
  62.     s,e,m:  integer;
  63. begin {sortsection}
  64.     if top - start < 6 then {sort small sections with bsort}
  65.        bsort( start, top, arry , pointer )
  66.     else
  67.        begin
  68.            findmedian( start, top, arry , pointer );
  69.            swapup := true;
  70.            {start scanning from array top}
  71.            s := start;  {lower comparison limit}
  72.            e := top;    {upper comparison limit}
  73.            m := start;  {location of comparison value}
  74.            while e > s do
  75.                begin
  76.                    if swapup = true then
  77.                       {scan downward from partition top}
  78.                       {and exchange if smaller than median}
  79.                       begin
  80.                           while( arry[pointer[e]] >= arry[pointer[m]] )
  81.                                      and (e > m)  do
  82.                               e := e - 1;
  83.                           if e > m then
  84.                              begin
  85.                                  swap( pointer[e], pointer[m] );
  86.                                  m := e;
  87.                              end;
  88.                           swapup := false;
  89.                       end
  90.                    else
  91.                       {scan upward from a partition start}
  92.                       {and exchange if larger than median}
  93.                       begin
  94.                           while( arry[pointer[s]] <= arry[pointer[m]] )
  95.                                   and (s < m) do
  96.                               s := s + 1;
  97.                           if s < m then
  98.                              begin
  99.                                  swap( pointer[s], pointer[m] );
  100.                                  m := s;
  101.                              end;
  102.                           swapup := true;
  103.                       end
  104.                end;
  105.                 {sort lower half of partition}
  106.            sortsection( start, m-1, arry , pointer );
  107.                 {sort upper half of partition}
  108.            sortsection( m+1, top, arry , pointer);
  109.            end
  110. end; {sortsection}
  111.  
  112. begin {qsort - main program}
  113.     for i := 1 to max do
  114.        pointer[i]  := i;
  115.  
  116.     sortsection( 1, max , words , pointer );
  117. end. {qsort}
  118.