FASTQSORT.DPR

Program FastQSort;

// This is a generic array sorting program for Delphi (5). It's a mix of QuickSort and Simple Insertion
//   Sort. It doesn't contain any assembly routine.
// By leonardo maffi, May 15 2000, http://digilander.iol.it/maffia/leonardo/
// This is freeware. This is my quickest generic sorting routine. Does someone know how to improve it?

// Possible optimizations: if the QuickSort partitions are very disequal, then the datas are probably
//   very skewd. So a more stable algoritm, as HeapSort, can be used over the biggest partition.


{$APPTYPE CONSOLE}

uses MMSystem;

const
  n = 1000;      // Max = ~4 millions with 64MB of Ram. ~8millions without vd.
  Nc = 1000;     // How many times perform the sort.
  QualiDati = 1; // Type of datas to generate.

type
  data = single;
  tyvet = array[1..n] of data;

var
  Start,Stop,Time: LongInt;


procedure StartTime;
  begin
    Start := timeGetTime;
  end;

procedure StopTime;
  begin
    Stop := timeGetTime;
    Time := Stop - Start;
  end;


function Irand(min,max: integer):integer;
  // Random integer in [min, max].
  var k,n: integer;
  begin
    n:= succ( max - min );
    k:= trunc( n * random );
    if k=n then irand:= k + min - 1
           else irand:= k + min;
  end;


// #####################################################


procedure FQSort(var v:tyvet; inf,sup:integer);

   procedure QS(l, r:integer); // Raw (approximate) Quick Sort.
    const Tresh = 8;
    var
      a,aux: data;
      i,j,auxl: integer;
    begin
      auxl:= l; // To remove the tail recursion.

      while (r-auxl)>Tresh do begin // if the sub vector is too small, then the QuickSort doesn't sort it. 
                                    //   So, this isn't a sort algorithm, but a approximated-sort algorithm.
                                    // The SIS in the end perform the exact sorting.
        i:= (r+auxl) shr 1; // =  (r+auxl) div 2
        // This part is very useful to balance the partitions.
        if (v[auxl]>v[i]) then begin aux:= v[auxl]; v[auxl]:=v[i]; v[i]:= aux; end; // Tri-Median Methode!
        if (v[auxl]>v[r]) then begin aux:= v[auxl]; v[auxl]:=v[r]; v[r]:= aux; end;
        if (v[i]>v[r]) then begin aux:= v[i]; v[i]:=v[r]; v[r]:= aux; end;

        j:= pred(r); // pivot.
        aux:= v[i]; v[i]:=v[j]; v[j]:= aux;
        i:= auxl;
        a:= v[j];
        while true do begin
          repeat inc(i) until v[i]>=a;
          repeat dec(j) until v[j]<=a;
          if j<i then break;
          aux:= v[i]; v[i]:=v[j]; v[j]:= aux;
        end;
        aux:= v[i]; v[i]:=v[pred(r)]; v[pred(r)]:= aux;
        QS(auxl, j);

        auxl:= succ(i); // Tail recursion removed. The inner recursion is left because if I try to
                        //   remove it the program slow down.
      end;
    end;


  procedure SimpleInsertionSort(inf, n:integer); // The faster version possible?
    var
      i, j: integer;
      t,tt: data;
    begin
      for i:= succ(inf) to n do begin
        j:= i;
        t:= v[j];
        if j>inf then tt:= v[pred(j)]
                 else tt:= 0;  // To prevent a Delphi warning.
        while (j>inf) and (tt > t) do begin
          V[J]:= tt;
          dec(j);
          if j>inf then tt:= v[pred(j)];
        end;
        if i<>j then v[j]:= t;
      end;
    end;


  begin
    QS(inf,sup);
    SimpleInsertionSort(inf, sup); // Only ONE call to SIS!!
  end; // End FQSort


// ##################################################################

function TestSorted(var v:tyvet; inf,sup:integer): boolean;
  var
    pred, att: data;
    ok: boolean;
    i: integer;
  begin
    pred:= v[inf];
    ok:= true;
    for i:= inf+1 to sup do begin
      att:= v[i];
      ok:= ok and (pred<=att);
    end;
    if ok then writeln('Well sorted (duplications not controlled).')
          else writeln('******Error*****: Not well sorted.');
    Result:= ok;
  end;


function TestSortedPrecise(var v:tyvet; inf,sup:integer): boolean;
  var
    ok: boolean;
    i: integer;
  begin
    ok:= true;
    for i:= inf to sup do begin
      ok:= ok and (round(v[i])=i);
      if round(v[i])<>i then writeln(i,' ', v[i]:1:1);
    end;
    if ok then writeln('Perfecly sorted.')
          else writeln('******Error*****: not perfecly sorted.');
    Result:= ok;
  end;


var
  v,vd: TyVet;
  i, j: integer;
  aux: data;
begin // Principal.
  writeln('Num. data, Num. repeats= ',n,' ',nc);
  writeln;
  randomize;
  case QualiDati of // Some types of data to sort.
    1: for i:= 1 to n do vd[i]:= random;
    2: for i:= 1 to n do vd[i]:= i/(n+1);
    3: begin
         for i:= 1 to n do vd[i]:= random;
         for i:= 1 to n div 100 do vd[round(random * n)]:= random*100;
       end;
    4: for i:= 1 to n do vd[i]:= ln((random));
    5: for i:= 1 to n do vd[i]:= (n-i)/(n+1);
    6: begin
         for i:= 1 to n do vd[i]:= i;
         for i:= 1 to n do begin
           j:= irand(1, n);
           aux:= vd[i]; vd[i]:= vd[j]; vd[j]:= aux;
         end;
         // for i:= 1 to n do write(vd[i]:1:0,' ');   writeln;
       end;
    7: for i:= 1 to n do vd[i]:= i mod 10;
    8: for i:= 1 to n do vd[i]:= i div (n div 10);
    9: for i:= 1 to n do vd[i]:= i;
  end;

  StartTime;
  for i:=1 to nc do begin
    v:= vd;
    FQSort(v, 1, n); // It sorts 4 millions of uniform random single in [0,1] in ~7.5s on a K6-2 400MHz
                     //   whith Delphi5, whithout runtime errors catching.
  end;
  StopTime;
  writeln('Time FQSort: ',Time, ' milliseconds.');
  TestSorted(v, 1, n);
  if Qualidati=6 then TestSortedPrecise(v, 1, n);

  writeln;
  write('Press Enter to finish.');
  readln;
end.

Document generated by PasToWeb, a tool by Marco Cantù.
 
  Feb. 07 2003: Quick Sort is still improving, take a look at Robert Sedgewick site:
http://www.cs.princeton.edu/~rs/
Quicksort is optimal

- Torna all'indice -