POINT Software Programming/PPROG1.ISO/pascal/swag/sorting.swg/0031_TIMESORT.PAS.pas

Pascal/Delphi Source File | 1993-05-28 | 8.8 KB | 313 lines

{I wrote a small Program to bench both sort routines we posted. It was an
interesting test, however it did raise a couple questions For me, which I'll
get to in a moment. (The following Program can be used as a skeleton For trying
other sort routines too.)

Needless to say, the routine you posted was dramatically faster than the one I
posted, even though both routines are non-recursive simple sorts.

The maximum efficient load of the routine you posted appears to be about 3000
elements. After that, additonal elements add time exponentially. For example,
it will sort 3000 elements in 5.1 seconds, but 5000 elements takes almost 16
seconds. The sort I posted became un-benchable [bearable] at about 3000
elements when it took over a minute to Complete. I didn't test it beyond this
point.

Here are the results from my 386 33Mhz machine-- your algorithm.

     500 Elements - 0.1   Seconds
    1000 Elements - 0.8   Seconds
    1500 Elements - 1.4   Seconds
    2000 Elements - 2.6   Seconds
    3000 Elements - 5.1   Seconds  <- Peak efficiency reached
    5000 Elements - 15.8  Seconds

Here is the Program I used to benchmark with. I made it so that you could
"tweak" portions of the sort and re-run the Program.

Incidentally, I also Compiled this Program under Stony Brook's Pascal Plus and
was suprised to find that it ran substantially slower. All optimizations on.

Range Checking ($R+) exactly Doubled the time it took to sort.

Changing "Span+1" to Succ(Span) and "total-1" to Pred(total) made the routine
about 3% faster. However the routine then neglected to sort that last two
elements. Adding "Inc(total,2)" solved the problem but I'm not sure why. I did
not expect this behavior. Perhaps someone could explain why?

I added a temporary Pointer Variable to your routine in place of the "NewStr('
...  ')" code you used to simplify it.

and one last thing... Using OPRO's OpInline Function called
"ExchangeLongInts()" to do the swapping instead of using a temporary Var
increased speed another 2% (Evident at > 2000 elements.) However I did not
include this so that anyone interested could Compile and run this without extra
Units.
}

{$A+,B-,D-,E-,F-,G-,I+,L+,N-,O-,P-,Q+,R-,S+,T-,V-,X-,Y+}
{$M 32768,0,655360}

Program Sort_Test;  { Sorting Benchmark Using P. Beeftink's Algorithm }

Type
   SmallArrPtr = ^SmallArr;
   SmallArr    = Array[1..10] of Char;   { Skip String & Length Byte }

   TTimeString = String[20];


Var
   SortArray : Array[1..5000] of SmallArrPtr; { A LARGE Array }

   TickCount : LongInt Absolute $0040:$006C;
 { TickCount : LongInt VOLATILE Absolute $0040:$006C; } { For Pascal+ }
   Tstart,
   Ttime     : LongInt;

{------------------------------------------------------------------------}
Procedure StartTiming;
begin
  TStart := TickCount;

  {start at the beginning of a tick!}
  Repeat Until TStart <> TickCount;

  TStart := TickCount;

end;
{------------------------------------------------------------------------}
Procedure StopTiming;
begin
  TTime := TickCount - TStart;
end;
{------------------------------------------------------------------------}
Function Elapsed : TTimeString;
Var Temp : TTimeString;
   Sec10 : LongInt;
begin

  Sec10 := TTime * 2470 div 4497;
  Str( Sec10 : 4, Temp );

  if Temp[1] = ' ' then Temp[1] := '0';

  Inc( Temp[0] );
  Temp[ Length(Temp) ] := Temp[ Pred( Length( Temp ) ) ];
  Temp[ Pred( length( Temp ) ) ] := '.';

  Elapsed := Temp;
end;
{------------------------------------------------------------------------}
Procedure MakeRandomStrings( NumtoMake : Word );
Var RNum,
    I,S  : Word;
    Temp : String;
begin

  Temp := '';
  Temp[0] := Chr( 10 );
  Randomize;

  For I := 1 to NumtoMake do
  begin

    For S := 1 to 10 do     { Create Random Strings 10 Chars in length }
    begin
      RNum := Random(26);
      Temp[S] := Chr( RNum + 65 );
    end;

    Move( Temp[1], SortArray[I]^, 10 );

  end;

end; { Proc }
{------------------------------------------------------------------------}
Procedure KDSort( total : Word );
  {-My simple sort routine as posted in Pascal Echo }
  { With 2 slight modifications                     }
Var
   i,j,
   Current : Word;
   TempPtr : Pointer;
begin

  For I := 1 to total do
  begin

    Current := I;

    For J := Succ(I) to total do
    begin
      if SortArray[J]^ < SortArray[Current]^ then
      begin
         TempPtr            := SortArray[j];
         SortArray[j]       := SortArray[Current];
         SortArray[Current] := TempPtr;
      end; {if}
    end; {For}

  end; {For}

end;
{------------------------------------------------------------------------}
Procedure PBSort(total : Integer);
  {-Peter Beeftink's Sort as Posted in Pascal Echo }
  { Also With slight modifications                 }
Var
   I,j     : Integer;
   Span    : Integer;
   TempPtr : Pointer;
begin

  Inc(total,2);   { Required to Compensate For PRED and SUCC ? }

  Span := total SHR $01;

  While Span > 0 do
  begin

    For I := Span to Pred(total) {total-1} do
    begin

      For j := (I - Succ(Span) {Span+1} ) Downto 1 do
        if (SortArray[j]^ <= SortArray[j+Span]^) then j := 1 else
        begin
          TempPtr           := SortArray[j];
          SortArray[j]      := SortArray[j+Span];
          SortArray[j+Span] := TempPtr;
        end;

    end; {For}

    Span := Span SHR $01; { This does help speed over Span div 2! }

  end; {WhIle}

end;
{------------------------------------------------------------------------}
Procedure Do_Sorting( SortAmount : Word );
begin

  MakeRandomStrings(SortAmount);

  Write('Sorting... ');

  StartTiming;

  PBSort(SortAmount); { Change to KDSort() to bench second sort routine }

  StopTiming;

  WriteLn(SortAmount:5,' Elements - ',Elapsed,' Seconds');

end;
{------------------------------------------------------------------------}
Var C : Word;

begin

  if MaxAvail < 5000 * Sizeof(SmallArr) then Halt; { not enough memory! }

  For C := 1 to 5000 do   { pre-allocate up front }
    GetMem(SortArray[C],Sizeof(SmallArr));


  Do_Sorting( 500   );   { Add more Do_Sorting()'s For whatever count }
  Do_Sorting( 1000  );   { you wish to test with.                     }
  Do_Sorting( 1500  );
  Do_Sorting( 2000  );
  Do_Sorting( 3000  );
  Do_Sorting( 5000  );


  { Un-comment the following if you wish to see the sorted output }

  {
  For C := 1 to 5000 do   { Change 5000 to the amount you sorted }
    WriteLn( SortArray[C]^ );


  For C := 1 to 5000 do
    FreeMem(SortArray[C],Sizeof(SmallArr));

end.
{
I plugged in a QuickSort algorithm in the "skeleton" Program in my previous
message to test perFormance. Here are the results:

     500 Elements - 0.1 Seconds
    1000 Elements - 0.2 Seconds
    1500 Elements - 0.4 Seconds
    2000 Elements - 0.6 Seconds
    3000 Elements - 0.9 Seconds
    5000 Elements - 1.8 Seconds

Very fast indeed. I modified the algorithm to sort only by Pointers, and
optimized a couple spots. Again, a slight speed increase is noted using OPRO's
ExchangeLongInts() in leu of using temporary Variables in 1 spot. if you have
OPRO, replace them and you reduce the number of instructions by 2 per
iteration.

This is a split-list recursive sort. Works by making a pass through the entire
Array first and moves all "small" data to the left, and all "Large" data to the
right. then it sorts each half seperately.

Take the following code segment and "plug" it into the skeleton in my previous
message. then change the "PBSort(SortAmount)" to "QuickSort(SortAmount)" to run
the tests.

Here is the code segment:

{------------------------------------------------------------------------}
Procedure QuickSort( total : Integer );
  {------------------------------------------}
  Procedure recQuickSort( L, R : Integer );
  Var K,I,J   : Integer;
      T,
      Temp    : Pointer;

  begin

    if L < R then
    begin
      T := SortArray[L];
      I := Pred(L);
      J := L;
      K := Succ(R);

      While Succ(J) < K do
       if SortArray[Succ(J)]^ < SmallArrPtr(T)^ then
       begin
         Inc(I,1);
         Inc(J,1);
         SortArray[I] := SortArray[J];
         SortArray[j] := T;
       end {if}
       else
       if SortArray[Succ(J)]^ > SmallArrPtr(T)^ then
       begin
         Dec(K,1);
         Temp := SortArray[K];
         SortArray[K] := SortArray[Succ(J)];
         SortArray[Succ(J)] := Temp;
       end {if}
       else
       Inc(J,1);

       recQuickSort(L,I);
       recQuickSort(K,R);

    end; { if L < R }

  end; { Proc recQuickSort }
  {------------------------------------------}

begin

  recQuickSort(1,total);

end;{QuickSort}
{------------------------------------------------------------------------}