home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / turbopas / qqsort.lbr / QQSORT.LZB / QQSORT.LIB
Text File  |  1987-03-22  |  2KB  |  99 lines
  1. PROCEDURE QQSORT( left, right : INTEGER );
  2. {
  3. + WRITTEN BY:    Richard C. Singleton
  4. + DATE WRITTEN:    Sept 17, 1968
  5. +
  6. + This procedure sorts the elements of array A[1..n] into
  7.   ascending order.  The method used is similar to QUICKERSORT
  8.   by R.S. Scowen, which in turn is similar to an algorithm given
  9.   by Hibbard and to Hoare's QUICKSORT.
  10. +
  11. + Modified 6 Oct 1980 for Pascal/Z.        +}
  12. {
  13. GLOBAL
  14.   TYPE
  15.     Index  = 1..N;
  16.     Scalar = <Some scalar type>
  17.   VAR
  18.     A : array [Index] of Scalar;
  19. }
  20. VAR
  21.   t, tt: Scalar;
  22.   ii, ij, k, L, m : integer;
  23.   IL, IU : array [0..20] of integer;{Permit sorting up to 2**(K+1)-1 elements}
  24.   i, j, ix    : integer;
  25.   alldone, d : BOOLEAN;
  26. BEGIN                 {$C-,M-,F-}
  27.   i := left;
  28.   j := right;
  29.   m := 0;
  30.   ii := i;
  31.   alldone := FALSE;
  32.   REPEAT
  33.      If ((j-i) > 10) OR ( (i = ii) and (i < j) ) then
  34.        BEGIN
  35.       ij := (i+j) DIV 2;
  36.       t := A[ij];
  37.       k := i;
  38.       L := j;
  39.       If (A[i] > t) then
  40.         begin
  41.           A[ij] := A[i]; A[i] := t; t := A[ij]
  42.         end;
  43.       If (A[j] < t) then
  44.         begin
  45.           A[ij] := A[j]; A[j] := t; t := A[ij];
  46.           If (A[i] > t) then
  47.         begin
  48.           A[ij] := A[i]; A[i] := t; t := A[ij]
  49.         end;
  50.         end;
  51.       d := FALSE;
  52.       REPEAT
  53.         REPEAT
  54.           L := L - 1;
  55.         UNTIL A[L] <= t;
  56.         REPEAT
  57.           k := k + 1;
  58.         UNTIL A[k] >= t;
  59.         If (k <= L) then
  60.           begin
  61.             tt := A[L]; A[L] := A[k]; A[k] := tt;
  62.           end
  63.         Else
  64.           d := TRUE;
  65.       UNTIL d;
  66.       If (L-i) > (j-k) then
  67.         begin  IL[m] := i; IU[m] := L; i := k end
  68.       Else
  69.         begin IL[m] := k; IU[m] := j; j := L end;
  70.       m := m + 1;
  71.        END
  72.      Else
  73.        BEGIN
  74.      For ix := (i+1) to j do
  75.        begin
  76.          t := A[ix];
  77.          k := ix - 1;
  78.          If A[k] > t then
  79.            begin
  80.          REPEAT
  81.            A[k+1] := A[k];
  82.            k := k - 1;
  83.          UNTIL A[k] <= t;
  84.          A[k+1] := t;
  85.            end;
  86.        end;{For ix}
  87.      m := m - 1;
  88.      If m >= 0 then
  89.        begin
  90.          i := IL[m];
  91.          j := IU[m];
  92.        end
  93.          Else
  94.        alldone := TRUE;
  95.        END;
  96.   UNTIL alldone;
  97. END;{of QQSORT}            {$C+,M+,F+}
  98.  
  99.