Jump to content
FHannes

Sorting Algorithms

Recommended Posts

BubbleSort:

Every time it loops through the array, it moves the largest item it can find to the back of unsorted area of the array, it repeats this until all items have been sorted. It moves the largest item to the back until it finds a larger item on the way with which it continues until it's moving the largest item in the array.

 

procedure BubbleSort(var Arr: TIntArray);
var
 CurIndex, TmpIndex, Hi: Integer;
begin
 Hi := High(Arr);
 for CurIndex := 0 to Hi do
   for TmpIndex := 1 to Hi - CurIndex do
     if Arr[TmpIndex - 1] > Arr[TmpIndex] then
       Swap(Arr[TmpIndex - 1], Arr[TmpIndex]);
end;

var
 TIA: TIntArray;

begin
 TIA := [1, 6, 2, 4, 3, 5, 1, 2, 7, 1];
 WriteLn(TIAToStr(TIA));
 BubbleSort(TIA);
 WriteLn(TIAToStr(TIA));
end.

 

SelectionSort:

Loops through the array, it finds the smallest item in the array and swaps it with the item at it's current index.

 

procedure SelectionSort(var Arr: TIntArray);
var
 CurIndex, TmpIndex, Hi, Min: Integer;
begin
 Hi := High(Arr);
 for CurIndex := 0 to Hi do
 begin
   Min := CurIndex;
   for TmpIndex := CurIndex + 1 to Hi do
     if Arr[Min] > Arr[TmpIndex] then
       Min := TmpIndex;
   Swap(Arr[Min], Arr[CurIndex]);
 end;
end;

var
 TIA: TIntArray;

begin
 TIA := [1, 6, 2, 4, 3, 5, 1, 2, 7, 1];
 WriteLn(TIAToStr(TIA));
 SelectionSort(TIA);
 WriteLn(TIAToStr(TIA));
end.

 

InsertionSort:

Loops through the array, moves every item it encounters up in the array towards the start until it's placed before every larger item that has been encountered so far.

 

procedure InsertionSort(var Arr: TIntArray);
var
 CurIndex, TmpIndex, Hi, Min: Integer;
begin
 Hi := High(Arr);
 for CurIndex := 1 to Hi do
   for TmpIndex := CurIndex downto 1 do
   begin
     if not (Arr[TmpIndex] < Arr[TmpIndex - 1]) then
       Break;
     Swap(Arr[TmpIndex - 1], Arr[TmpIndex]);
   end;
end;

var
 TIA: TIntArray;

begin
 TIA := [1, 6, 2, 4, 3, 5, 1, 2, 7, 1];
 WriteLn(TIAToStr(TIA));
 InsertionSort(TIA);
 WriteLn(TIAToStr(TIA));
end.

 

MergeSort:

Divides up the array into 2 parts recursively until it can no longer be divided because there's only a single item left in the sub-array. After doing this it recurses back up, merging the 2 sorted sub-arrays by looping through the 2 parts, placing the smallest item currently in either one first in the resulting array. The 2 sub-arrays in the lowest recursion level is always sorted as it contains a single item.

 

procedure Merge(var Arr, Aux: TIntArray; const Lo, Mid, Hi: Integer);
var
 LHalf, RHalf, Index: Integer;
begin
 LHalf := Lo;
 RHalf := Mid + 1;

 for Index := Lo to Hi do
   Aux[index] := Arr[index];

 for Index := Lo to Hi do
   if LHalf > Mid then
   begin
     Arr[index] := Aux[RHalf];
     Inc(RHalf);
   end else if RHalf > Hi then
   begin
     Arr[index] := Aux[LHalf];
     Inc(LHalf);
   end else if Aux[RHalf] < Aux[LHalf] then
   begin
     Arr[index] := Aux[RHalf];
     Inc(RHalf);
   end else
   begin
     Arr[index] := Aux[LHalf];
     Inc(LHalf);
   end;
end;

procedure Sort(var Arr, Aux: TIntArray; const Lo, Hi: Integer);
var
 Mid: Integer;
begin
 if Lo >= Hi then Exit;

 Mid := Lo + (Hi - Lo) div 2;

 Sort(Arr, Aux, Lo, Mid);
 Sort(Arr, Aux, Mid + 1, Hi);
 Merge(Arr, Aux, Lo, Mid, Hi);
end;

procedure MergeSort(var Arr: TIntArray);
var
 Len: Integer;
 Aux: TIntArray;
begin
 Len := Length(Arr);
 if Len <= 1 then Exit;
 SetLength(Aux, Len);
 Sort(Arr, Aux, 0, Len - 1);
end;

var
 TIA: TIntArray;

begin
 TIA := [1, 6, 2, 4, 3, 5, 1, 2, 7, 1];
 WriteLn(TIAToStr(TIA));
 MergeSort(TIA);
 WriteLn(TIAToStr(TIA));
end.

 

Bottom-Up MergeSort:

The previous version of MergeSort is the most commonly referenced one, it is a top-down version of the algorithm as it starts at the top of your merging tree, then splits up into 2 smaller sub-arrays and goes on until it can no longer split up the sub-arrays. The bottom-up version does the exact opposite, it starts at the bottom and merges together in groups of 2, then doubles that group size up until everything is sorted, which is achieved when the size of the groups exceeds the size of the array.

 

procedure Merge(var Arr, Aux: TIntArray; const Lo, Mid, Hi: Integer);
var
 LHalf, RHalf, Index: Integer;
begin
 LHalf := Lo;
 RHalf := Mid + 1;

 for Index := Lo to Hi do
   Aux[index] := Arr[index];

 for Index := Lo to Hi do
   if LHalf > Mid then
   begin
     Arr[index] := Aux[RHalf];
     Inc(RHalf);
   end else if RHalf > Hi then
   begin
     Arr[index] := Aux[LHalf];
     Inc(LHalf);
   end else if Aux[RHalf] < Aux[LHalf] then
   begin
     Arr[index] := Aux[RHalf];
     Inc(RHalf);
   end else
   begin
     Arr[index] := Aux[LHalf];
     Inc(LHalf);
   end;
end;

procedure MergeSort(var Arr: TIntArray);
var
 Len, Size, Lo: Integer;
 Aux: TIntArray;
begin
 Len := Length(Arr);
 if Len <= 1 then Exit;
 SetLength(Aux, Len);

 Size := 1;
 while Size < Len do
 begin
   Lo := 0;
   while Lo < Len - Size do
   begin
     Merge(Arr, Aux, Lo, Lo + Size - 1, Min(Lo + Size * 2 - 1, Len - 1));
     IncEx(Lo, Size * 2);
   end;
   IncEx(Size, Size);
 end;
end;

var
 TIA: TIntArray;

begin
 TIA := [1, 6, 2, 4, 3, 5, 1, 2, 7, 1];
 WriteLn(TIAToStr(TIA));
 MergeSort(TIA);
 WriteLn(TIAToStr(TIA));
end.

 

ShellSort:

A special form of InsertionSort where the based on the size of the input data, the items are swapped to the top of the array the same way as with InsertionSort, but in large jumps which shrinks by dividing it by 3 until it reaches 1 which sorts the remaining array the same way InsertionSort does, however, at this point the array is already sorted to a certain degree, making the work required to finish sorting a lot easier than by running InsertionSort on the entire array.

 

procedure ShellSort(var Arr: TIntArray);
var
 X, CurIndex, TmpIndex, Len: Integer;
begin
 Len := Length(Arr);

 X := 0;
 while X < Len div 3 do
   X := X * 3 + 1;

 while X >= 1 do
 begin
   for CurIndex := X to Len - 1 do
   begin
     TmpIndex := CurIndex;
     while (TmpIndex >= X) and (Arr[TmpIndex] < Arr[TmpIndex - X]) do
     begin
       Swap(Arr[TmpIndex], Arr[TmpIndex - X]);
       DecEx(TmpIndex, X);
     end;
   end;
   X := X div 3;
 end;
end;

var
 TIA: TIntArray;

begin
 TIA := [1, 6, 2, 4, 3, 5, 1, 2, 7, 1];
 WriteLn(TIAToStr(TIA));
 ShellSort(TIA);
 WriteLn(TIAToStr(TIA));
end.

 

QuickSort:

This algorithm is somewhat similar to MergeSort, it also divides up the problem and solves it recursively. The concept is fairly straightforward. You start with an array, you take the first item of this array and compare it from both left and right to the other items in the array. From the left you want to find an item that is larger or equal to this first value, and from the right smaller or equal. If you find these, you swap them and resume from the current position until you've swapped them to a point where both your positions have crossed each other. What has happened is that you have moved all values larger than the first value to the right and all the ones smaller to the left. When the algorithm stops partitioning, your right position will be at the index where the last smaller value is located. This is swapped with the first value. Now you have this first value in a position where all values left of it are smaller and all values right of it are larger. Now you apply the same function recursively to these 2 sub-arrays of smaller and larger values until you reach a point where you're trying to sort single values which are obviously sorted as there's only 1 value. Once the recursion is complete, the entire array will be sorted.

 

function Partition(var Arr: TIntArray; const Lo, Hi: Integer): Integer;
var
 LSide, RSide, Val: Integer;
begin
 Val := Arr[Lo];
 LSide := Lo;
 RSide := Hi + 1;

 while True do
 begin
   repeat
     Inc(LSide);
     if (Val < Arr[LSide]) or (LSide = Hi) then Break;
   until False;
   repeat
     Dec(RSide);
     if (Val > Arr[RSide]) or (RSide = Lo) then Break;
   until False;
   if LSide >= RSide then Break;
   Swap(Arr[LSide], Arr[RSide]);
 end;

 Swap(Arr[RSide], Arr[Lo]);
 Result := RSide;
end;

procedure Sort(var Arr: TIntArray; const Lo, Hi: Integer);
var
 Mid: Integer;
begin
 if Lo >= Hi then Exit;
 Mid := Partition(Arr, Lo, Hi);
 Sort(Arr, Lo, Mid - 1);
 Sort(Arr, Mid + 1, Hi);
end;

procedure QuickSort(var Arr: TIntArray);
begin
 Sort(Arr, 0, Length(Arr) - 1);
end;

var
 TIA: TIntArray;

begin
 TIA := [1, 6, 2, 4, 3, 5, 1, 2, 7, 1];
 WriteLn(TIAToStr(TIA));
 QuickSort(TIA);
 WriteLn(TIAToStr(TIA));
end.

 

3-Way QuickSort

QuickSort with 3-way partitioning still divides up the array into subarrays like the regular QuickSort algorithm does, however, rather than dividing it up into 2 arrays stretching the entire array, it will split it up into 2 arrays containing all items smaller than the first value of the array and a second larger than this item, all values equal to the first value are moved to the middle and left untouched any further. This process continues recursively until the array is sorted.

 

procedure Sort(var Arr: TIntArray; const Lo, Hi: Integer);
var
 LSide, RSide, Pos, Val: Integer;
begin
 if Lo >= Hi then Exit;
 Val := Arr[Lo];
 LSide := Lo;
 RSide := Hi;
 Pos := Lo + 1;

 while Pos <= RSide do
   if Arr[Pos] < Val then
   begin
     Swap(Arr[LSide], Arr[Pos]);
     Inc(Pos);
     Inc(LSide);
   end else if Arr[Pos] > Val then
   begin
     Swap(Arr[RSide], Arr[Pos]);
     Dec(RSide);
   end else
     Inc(Pos);

 Sort(Arr, Lo, LSide - 1);
 Sort(Arr, RSide + 1, Hi);
end;

procedure QuickSort(var Arr: TIntArray);
begin
 Sort(Arr, 0, Length(Arr) - 1);
end;

var
 TIA: TIntArray;

begin
 TIA := [1, 6, 2, 4, 3, 5, 1, 2, 7, 1];
 WriteLn(TIAToStr(TIA));
 QuickSort(TIA);
 WriteLn(TIAToStr(TIA));
end.

 

HeapSort:

The HeapSort algorithm first transforms your array into a binary heap by sinking down smaller elements for all nodes that have child nodes in the tree. Next it switches the first element with the last element in the array and decreases the size of the unsorted area by 1. The element now at the top is sunk down the remaining tree which moves the largest element currently present to the top of the tree. Now the process repeats.

procedure Sink(var Arr: TIntArray; const Idx, LvlEnd, Len: Integer);
var
 Tmp, Pos, SwapIdx: Integer;
begin
 Pos := Idx;   
 while Pos <= LvlEnd do
 begin
   SwapIdx := Pos;     
   Tmp := Pos * 2 + 1;
   if (Arr[Pos] < Arr[Tmp]) then SwapIdx := Tmp;
   Inc(Tmp);
   if (Tmp < Len) and (Arr[swapIdx] < Arr[Tmp]) then SwapIdx := Tmp;
   if SwapIdx <> Pos then    
   begin
     Swap(Arr[swapIdx], Arr[Pos]);  
     Pos := SwapIdx; 
   end else Break;
 end;
end;

procedure HeapSort(var Arr: TIntArray);
var
 Len, Idx, LvlEnd: Integer;
begin
 Len := Length(Arr);      
 LvlEnd := (Len - 1) div 2 - 1;
 for Idx := LvlEnd downto 0 do
   Sink(Arr, Idx, LvlEnd, Len);       
 while Len > 0 do
 begin
   Swap(Arr[0], Arr[Len - 1]);
   Dec(Len);
   Sink(Arr, 0, (Len - 1) div 2 - 1, Len);
 end;
end;

var
 TIA: TIntArray;

begin
 TIA := [1, 6, 2, 4, 3, 5, 1, 2, 7, 1];
 WriteLn(TIAToStr(TIA));
 HeapSort(TIA);
 WriteLn(TIAToStr(TIA));
end.

Edited by Freddy
Link to comment
Share on other sites

Nice work with the sorting algorithms, Freddy!

Thanks and cheers for sharing em here.

 

Are you planning to add SelectionSort, InsertionSort, MergeSort/Bottom-Up MergeSort and HeapSort to the SCAR's default functions in the future? :)

Would be great to have em built-in! ..pssshtt, maybe for 3.31?...

 

-Jani

Link to comment
Share on other sites

I've added QuickSort with 3-way partitioning :)

 

EDIT: To show you why I use ShellSort in SCAR, you could take a look at this page, which demonstrates most of the algorithms in this thread. HeapSort is sometimes slightly faster than ShellSort, but overall ShellSort is very fast no matter the input data, where for example HeapSort is a lot slower when the data is nearly sorted.

Edited by Freddy
Link to comment
Share on other sites

EDIT: Freddy fixed those 2 algorithms, much appreciated man!

 

Here you go, time for some good ol' Gravediggin'... :D

 

Bumping this awesome topic up because, I found out that HeapSort and QuickSort aren't working always correctly (most of the time).

 

Also, I wrote couple custom sorting algorithms, called as JnlbSort() and JnlbSort2W(). :P They are sooo freaking SLOW, though.

It was a funny little challenge for me anyways, because I just wanted to come up with a new way for sorting arrays - way that hasn't been released or possibly even discovered, by anyone else (as far as I know)!

 

Here is my testing script, by running it we can also easily/clearly see the issues with those 2 algorithms that are not working correctly:

 

type
 TSortAlgorithm = (sa_BubbleSort, sa_HeapSort, sa_InsertionSort,
                   sa_MergeSort, sa_MergeSortBU, sa_SelectionSort,
                   sa_ShellSort, sa_QuickSort, sa_QuickSort3W,
                   sa_JnlbSort, sa_JnlbSort2W);

procedure JnlbSort(var TIA: TIntArray; order: (so_LowToHigh, so_HighToLow));
var
 a, x, i, l, lo: Integer;
begin
 l := Length(TIA);
 if (l > 1) then
 begin
   case order of
     so_LowToHigh:
     for i := 0 to (l - 2) do
     begin       
       lo := i;            
       a := lo;                     
       for x := (i + 1) to (l - 1) do
         if (TIA[x] < TIA[lo]) then
           lo := x;
       if (lo > a) then
         Swap(TIA[a], TIA[lo]);
     end;  
     so_HighToLow:
     for i := 0 to (l - 1) do
     begin       
       lo := i;            
       a := lo;                     
       for x := (i + 1) to l do
         if (TIA[x] < TIA[lo]) then
           lo := x;
       if (lo > a) then
         Swap(TIA[a], TIA[lo]);
     end;    
   end;  
 end; 
end;

procedure JnlbSort2W(var TIA: TIntArray; order: (so_LowToHigh, so_HighToLow));
var
 a, b, x, i, l, hi, lo, s: Integer;
begin
 l := Length(TIA);
 if (l > 1) then
 begin
   s := ((l - 1) div 2);
   case order of
     so_LowToHigh:
     for i := 0 to s do
     begin       
       lo := i;            
       hi := ((l - 1) - i);
       a := lo;
       b := hi;                      
       if (TIA[hi] < TIA[lo]) then
         Swap(TIA[hi], TIA[lo]); 
       for x := (a + 1) to (b - 1) do
         if (TIA[x] < TIA[lo]) then
           lo := x
         else
           if (TIA[x] > TIA[hi]) then
             hi := x;
       if (lo > a) then
         Swap(TIA[a], TIA[lo]);
       if (hi < b) then
         Swap(TIA[b], TIA[hi]);
     end;  
     so_HighToLow: 
     for i := 0 to s do
     begin       
       lo := i;            
       hi := ((l - 1) - i);
       a := lo;
       b := hi;                      
       if (TIA[hi] > TIA[lo]) then
         Swap(TIA[hi], TIA[lo]); 
       for x := (a + 1) to (b - 1) do
         if (TIA[x] > TIA[lo]) then
           lo := x
         else
           if (TIA[x] < TIA[hi]) then
             hi := x;
       if (lo < a) then
         Swap(TIA[a], TIA[lo]);
       if (hi > b) then
         Swap(TIA[b], TIA[hi]);
     end;    
   end;  
 end; 
end;

function TIAByRange2bit(aStart, aFinish: Integer): TIntArray;
{==============================================================================]   
 Explanation: Returns a TIA that contains all the value from start value (aStart)
              to finishing value (aFinish)..
              Works with 2-bit method, that cuts loop in half.                   
[==============================================================================}
var
 g, l, i, s, f: Integer;
begin
 if (aStart <> aFinish) then
 begin 
   s := Integer(aStart);
   f := Integer(aFinish);
   l := (IAbs(aStart - aFinish) + 1);             
   SetLength(Result, l);     
   g := ((l - 1) div 2);  
   case (aStart < aFinish) of
     True:
     begin
       for i := 0 to g do
       begin                       
         Result[i] := (s + i);
         Result[((l - 1) - i)] := (f - i);
       end;
       if ((l mod 2) <> 0) then
         Result[i] := (s + i);   
     end;
     False:
     begin
       for i := 0 to g do
       begin                       
         Result[i] := (s - i);
         Result[((l - 1) - i)] := (f + i);
       end;
       if ((l mod 2) <> 0) then
         Result[i] := (s - i);  
     end;  
   end;     
 end else
   Result := [integer(aStart)];
end;

var
 original: TIntArray;

procedure ShellSort(var Arr: TIntArray);
var
 X, CurIndex, TmpIndex, Len: Integer;
begin
 Len := Length(Arr);
 X := 0;
 while X < Len div 3 do
   X := X * 3 + 1;
 while X >= 1 do
 begin
   for CurIndex := X to Len - 1 do
   begin
     TmpIndex := CurIndex;
     while (TmpIndex >= X) and (Arr[TmpIndex] < Arr[TmpIndex - X]) do
     begin
       Swap(Arr[TmpIndex], Arr[TmpIndex - X]);
       DecEx(TmpIndex, X);
     end;
   end;
   X := X div 3;
 end;
end;

procedure BubbleSort(var Arr: TIntArray);
var
 CurIndex, TmpIndex, Hi: Integer;
begin
 Hi := High(Arr);
 for CurIndex := 0 to Hi do
   for TmpIndex := 1 to Hi - CurIndex do
     if Arr[TmpIndex - 1] > Arr[TmpIndex] then
       Swap(Arr[TmpIndex - 1], Arr[TmpIndex]);
end;

procedure SelectionSort(var Arr: TIntArray);
var
 CurIndex, TmpIndex, Hi, Min: Integer;
begin
 Hi := High(Arr);
 for CurIndex := 0 to Hi do
 begin
   Min := CurIndex;
   for TmpIndex := CurIndex + 1 to Hi do
     if Arr[Min] > Arr[TmpIndex] then
       Min := TmpIndex;
   Swap(Arr[Min], Arr[CurIndex]);
 end;
end;

procedure InsertionSort(var Arr: TIntArray);
var
 CurIndex, TmpIndex, Hi, Min: Integer;
begin
 Hi := High(Arr);
 for CurIndex := 1 to Hi do
   for TmpIndex := CurIndex downto 1 do
   begin
     if not (Arr[TmpIndex] < Arr[TmpIndex - 1]) then
       Break;
     Swap(Arr[TmpIndex - 1], Arr[TmpIndex]);
   end;
end;

procedure Merge(var Arr, Aux: TIntArray; const Lo, Mid, Hi: Integer);
var
 LHalf, RHalf, Index: Integer;
begin
 LHalf := Lo;
 RHalf := Mid + 1;

 for Index := Lo to Hi do
   Aux[index] := Arr[index];

 for Index := Lo to Hi do
   if LHalf > Mid then
   begin
     Arr[index] := Aux[RHalf];
     Inc(RHalf);
   end else if RHalf > Hi then
   begin
     Arr[index] := Aux[LHalf];
     Inc(LHalf);
   end else if Aux[RHalf] < Aux[LHalf] then
   begin
     Arr[index] := Aux[RHalf];
     Inc(RHalf);
   end else
   begin
     Arr[index] := Aux[LHalf];
     Inc(LHalf);
   end;
end;

procedure Sort(var Arr, Aux: TIntArray; const Lo, Hi: Integer);
var
 Mid: Integer;
begin
 if Lo >= Hi then Exit;

 Mid := Lo + (Hi - Lo) div 2;

 Sort(Arr, Aux, Lo, Mid);
 Sort(Arr, Aux, Mid + 1, Hi);
 Merge(Arr, Aux, Lo, Mid, Hi);
end;

procedure MergeSort(var Arr: TIntArray);
var
 Len: Integer;
 Aux: TIntArray;
begin
 Len := Length(Arr);
 if Len <= 1 then Exit;
 SetLength(Aux, Len);
 Sort(Arr, Aux, 0, Len - 1);
end;

procedure MergeSortBU(var Arr: TIntArray);
var
 Len, Size, Lo: Integer;
 Aux: TIntArray;
begin
 Len := Length(Arr);
 if Len <= 1 then Exit;
 SetLength(Aux, Len);

 Size := 1;
 while Size < Len do
 begin
   Lo := 0;
   while Lo < Len - Size do
   begin
     Merge(Arr, Aux, Lo, Lo + Size - 1, Min(Lo + Size * 2 - 1, Len - 1));
     IncEx(Lo, Size * 2);
   end;
   IncEx(Size, Size);
 end;
end;

procedure HeapSort(var Arr: TIntArray);
var
 Len, Index, Pos, Tmp: Integer;
begin
 Len := Length(Arr);
 for Index := Len div 2 downto 1 do
 begin
   Pos := Index;
   while Pos * 2 <= Len do
   begin
     Tmp := Pos * 2;
     if (Tmp < Len) and (Arr[Tmp - 1] < Arr[Tmp]) then Inc(Tmp);
     if not (Arr[Pos - 1] < Arr[Tmp - 1]) then Break;
     Swap(Arr[Pos - 1], Arr[Tmp - 1]);
     Pos := Tmp;
   end;
 end;
 while Len > 0 do
 begin
   Swap(Arr[0], Arr[Len - 1]);
   Pos := 1;
   while Pos * 2 <= Len do
   begin
     Tmp := Pos * 2;
     if (Tmp < Len) and (Arr[Tmp - 1] < Arr[Tmp]) then Inc(Tmp);
     if not (Arr[Pos - 1] < Arr[Tmp - 1]) then Break;
     Swap(Arr[Pos - 1], Arr[Tmp - 1]);
     Pos := Tmp;
   end;
   Dec(Len);
 end;
end;

procedure QSort3W(var Arr: TIntArray; const Lo, Hi: Integer);
var
 LSide, RSide, Pos, Val: Integer;
begin
 if Lo >= Hi then Exit;
 Val := Arr[Lo];
 LSide := Lo;
 RSide := Hi;
 Pos := Lo + 1;

 while Pos <= RSide do
   if Arr[Pos] < Val then
   begin
     Swap(Arr[LSide], Arr[Pos]);
     Inc(Pos);
     Inc(LSide);
   end else if Arr[Pos] > Val then
   begin
     Swap(Arr[RSide], Arr[Pos]);
     Dec(RSide);
   end else
     Inc(Pos);

 QSort3W(Arr, Lo, LSide - 1);
 QSort3W(Arr, RSide + 1, Hi);
end;

procedure QuickSort3W(var Arr: TIntArray);
begin
 QSort3W(Arr, 0, Length(Arr) - 1);
end;

function Partition(var Arr: TIntArray; const Lo, Hi: Integer): Integer;
var
 LSide, RSide, Val: Integer;
begin
 Val := Arr[Lo];
 LSide := Lo;
 RSide := Hi + 1;

 while True do
 begin
   repeat
     Inc(LSide);
     if (Val <= Arr[LSide]) or (LSide = Hi) then Break;
   until False;
   repeat
     Dec(RSide);
     if (Val >= Arr[RSide]) or (RSide = Lo) then Break;
   until False;
   if LSide >= RSide then Break;
   Swap(Arr[LSide], Arr[RSide]);
 end;

 Swap(Arr[RSide], Arr[Lo]);
 Result := LSide;
end;

procedure QSort(var Arr: TIntArray; const Lo, Hi: Integer);
var
 Mid: Integer;
begin
 if Lo >= Hi then Exit;
 Mid := Partition(Arr, Lo, Hi);
 QSort(Arr, Lo, Mid - 1);
 QSort(Arr, Mid + 1, Hi);
end;

procedure QuickSort(var Arr: TIntArray);
begin
 QSort(Arr, 0, Length(Arr) - 1);
end;

procedure TIARandomizeEx(var TIA: TIntArray; shuffles: Integer);
{==============================================================================]   
 Explanation: Randomizes TIA.
              Example: [1, 2, 3] => [2, 3, 1]  
              The higher count of shuffles is, the "stronger" randomization you'll get.                   
[==============================================================================}
var
 l, i, t: Integer;
begin
 l := Length(TIA);
 if ((l > 1) and (shuffles > 0)) then
   for t := 1 to shuffles do
     for i := 0 to (l - 1) do
       Swap(TIA[Random(l)], TIA[Random(l)]);
end;                                                          

procedure SortingTimer(TIA: TIntArray; algorithm: TSortAlgorithm);
var
 t: Integer;
 s: string; 
 arr: TIntArray;
begin
 arr := CopyTIA(TIA);
 t := GetSystemTime;
 case algorithm of
   sa_BubbleSort:
   begin
     BubbleSort(arr);    
     s := 'BubbleSort()';
   end;
   sa_HeapSort: 
   begin
     HeapSort(arr);
     s := 'HeapSort()';
   end;
   sa_InsertionSort:
   begin
     InsertionSort(arr);
     s := 'InsertionSort()';
   end;
   sa_MergeSort: 
   begin
     MergeSort(arr);
     s := 'MergeSort()';
   end;
   sa_MergeSortBU:
   begin
     MergeSortBU(arr);
     s := 'MergeSortBU()';
   end;
   sa_SelectionSort:
   begin
     SelectionSort(arr);
     s := 'SelectionSort()';
   end;
   sa_ShellSort: 
   begin
     ShellSort(arr);
     s := 'ShellSort()';
   end;
   sa_QuickSort:
   begin
     QuickSort(arr);
     s := 'QuickSort()';
   end;
   sa_QuickSort3W:
   begin
     QuickSort3W(arr);
     s := 'QuickSort3W()';
   end;
   sa_JnlbSort:
   begin
     JnlbSort(arr, so_LowToHigh);
     s := 'JnlbSort()';
   end;
   sa_JnlbSort2W:
   begin
     JnlbSort2W(arr, so_LowToHigh);
     s := 'JnlbSort2W()';
   end;
 end;        
 t := (GetSystemTime - t);
 WriteLn(MD5(TIAToStr(arr)) + ': ' + IntToStr(t) + ' ms. [' + s + ']');  
 SetLength(arr, 0);
end;

begin
 ClearDebug;      
 original := TIAByRange2bit(500, -500);   
 WriteLn(MD5(TIAToStr(original)) + ' (REVERSED):'); 

 SortingTimer(original, sa_JnlbSort);  
 SortingTimer(original, sa_JnlbSort2W);
 SortingTimer(original, sa_BubbleSort);    
 SortingTimer(original, sa_ShellSort);
 SortingTimer(original, sa_SelectionSort); 
 SortingTimer(original, sa_InsertionSort); 
 SortingTimer(original, sa_MergeSort);   
 SortingTimer(original, sa_MergeSortBU); 
 SortingTimer(original, sa_HeapSort); 
 SortingTimer(original, sa_QuickSort);
 SortingTimer(original, sa_QuickSort3W);

 WriteLn(''); 
 ReverseTIA(original);
 WriteLn(MD5(TIAToStr(original)) + ' (ALREADY SORTED):');  

 SortingTimer(original, sa_JnlbSort);  
 SortingTimer(original, sa_JnlbSort2W);
 SortingTimer(original, sa_BubbleSort);    
 SortingTimer(original, sa_ShellSort);
 SortingTimer(original, sa_SelectionSort); 
 SortingTimer(original, sa_InsertionSort); 
 SortingTimer(original, sa_MergeSort);   
 SortingTimer(original, sa_MergeSortBU); 
 SortingTimer(original, sa_HeapSort); 
 SortingTimer(original, sa_QuickSort);
 SortingTimer(original, sa_QuickSort3W);

 WriteLn('');                       
 TIARandomizeEx(original, 2);       
 WriteLn(MD5(TIAToStr(original)) + ' (RANDOMIZED):');  

 SortingTimer(original, sa_JnlbSort);  
 SortingTimer(original, sa_JnlbSort2W);
 SortingTimer(original, sa_BubbleSort);    
 SortingTimer(original, sa_ShellSort);
 SortingTimer(original, sa_SelectionSort); 
 SortingTimer(original, sa_InsertionSort); 
 SortingTimer(original, sa_MergeSort);   
 SortingTimer(original, sa_MergeSortBU); 
 SortingTimer(original, sa_HeapSort); 
 SortingTimer(original, sa_QuickSort);
 SortingTimer(original, sa_QuickSort3W);

 WriteLn('');
 FillTIAEx(original, [1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048, 4096, 8192, 16384]);
 WriteLn(MD5(TIAToStr(original)) + ' ("FEW" UNIQUE):');  

 SortingTimer(original, sa_JnlbSort);  
 SortingTimer(original, sa_JnlbSort2W);
 SortingTimer(original, sa_BubbleSort);    
 SortingTimer(original, sa_ShellSort);
 SortingTimer(original, sa_SelectionSort); 
 SortingTimer(original, sa_InsertionSort); 
 SortingTimer(original, sa_MergeSort);   
 SortingTimer(original, sa_MergeSortBU); 
 SortingTimer(original, sa_HeapSort); 
 SortingTimer(original, sa_QuickSort);
 SortingTimer(original, sa_QuickSort3W);

end.

 

Working HeapSort():

 

procedure HeapSort(var TIA: TIntArray);
var
 a, b, r, c, l: Integer;
begin
 l := Length(TIA);
 a := ((l - 1) div 2);
 while (a >= 0) do
 begin
   r := a;
   while (((r * 2) + 1) <= (l - 1)) do
   begin 
     c := ((r * 2) + 1);
     if ((c < (l - 1)) and (TIA[c] < TIA[(c + 1)])) then
       c := (c + 1);
     if (TIA[r] < TIA[c]) then
     begin
       Swap(TIA[r], TIA[c]);
       r := c;
     end else
       Break;
   end;
   a := (a - 1);
 end;
 b := (l - 1);
 while (b > 0) do
 begin
   Swap(TIA[b], TIA[0]);
   b := (b - 1);
   r := 0;
   while (((r * 2) + 1) <= b) do
   begin 
     c := ((r * 2) + 1);
     if ((c < b) and (TIA[c] < TIA[(c + 1)])) then
       c := (c + 1);
     if (TIA[r] < TIA[c]) then
     begin
       Swap(TIA[r], TIA[c]);
       r := c;
     end else
       Break;
   end;
 end;
end;

var
 TIA: TIntArray;

begin
 TIA := [1, 3, 1, 2, 4, 0, -1, 9, 8, 5, 5, 6, 7];
 WriteLn(TIAToStr(TIA));
 HeapSort(TIA);
 WriteLn(TIAToStr(TIA));
end.

 

Script is also attached below.

 

-Jani

Sorting_Algorithms.scar

Edited by Janilabo
Link to comment
Share on other sites

Created an include ("sortingLib") with all sorting algorithms Freddy introduced here + 4 of my custom ones, JnlbSort, JnlbSort2W, JnlbSortDnmc and JnlbSortDnmc2W.

 

Contains sorting algorithms for TIntArray's, TStrArray's, TExtArray's and TCharArray's.

Sorting both ways is supported, High to Low and Low to High - this is based on TSortOrder type.

 

Credits to:

-Algorithm creators/innovators

-Freddy

 

Include is attached!

 

NOTE: I added "__" before any commands that are needed only for particular algorithms to get em working correctly (QuickSort, QuickSort3W, MergeSort and MergeSortBU are based on those commands).

sortingLib.scar

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.



×
  • Create New...