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