Sorting Algorithms

[FHannes]

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 May 6, 2013 by Freddy

[Janilabo]

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

[FHannes]

I'm not, most of these have a pretty bad performance compared to ShellSort which SCAR currently uses, the only used that are the same or close in most cases are QuickSort and HeapSort.

[Wanted]

Nice to see these posted

[FHannes]

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 January 16, 2012 by Freddy

[Janilabo]

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

 

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

 

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(). 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 May 6, 2013 by Janilabo

[Janilabo]

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

[AnthonyPhics]

オンライン カジノは、プレイヤーが自宅にいながらにしてポーカー、ルーレット、ブラックジャック、スロットなどのギャンブル ゲームを楽しむ機会を提供する仮想プラットフォームです。 オンラインカジノは、アクセスのしやすさ、ゲームの種類の多さ、そして大金を獲得する機会があるため、年々人気が高まっています。

オンラインカジノの主な利点は、利便性とアクセスしやすさです。 プレイヤーは、通常のカジノの営業時間に制限されず、いつでもゲームを楽しむことができます。 必要なのは、インターネットにアクセスできるデバイスと、カジノのウェブサイトにアクセスできることだけです。 これにより、プレイヤーは従来のカジノによくありがちなストレスや緊張を感じることなく、快適な環境でプレイすることができます。

オンラインカジノのもう1つの利点は、ゲームの選択肢が豊富なことです。 ユーザーは、それぞれ独自のルールと勝利の機会を提供する何百もの異なるゲームから選択できます。 技術革新のおかげで、オンライン ゲームのグラフィックとサウンドは高品質になり、プレイヤーは興奮と情熱の雰囲気に浸ることができます。

さまざまなゲームに加えて、オンライン カジノはプレーヤーにさまざまなボーナスやプロモーションも提供します。 これらは、スロットのフリースピン、プレイのための追加のお金、または貴重な賞品が得られる特別なトーナメントなどです。 このようなボーナスにより、勝利の可能性が高まり、ゲームがさらに楽しくなります。

もちろん、オンラインカジノでのプレイにはリスクがあります。 ギャンブルには依存性がある可能性があるため、自分の感情を監視し、支出をコントロールすることが重要であることを覚えておくことが重要です。 カジノはまた、責任あるゲーミングをサポートし、自己排除や賭け金制限の機会を提供します 深田えいみ xvideo

全体として、オンライン カジノはギャンブル愛好家にとって便利でエキサイティングなエンターテイメントを提供します。 幅広いゲーム、ボーナスの選択肢があり、いつでもプレイできるため、世界中のプレイヤーの間で人気が高まっています。 ただし、責任あるゲームと、ゲームが単なる楽しみと娯楽の源であるように自分の行動を制御する能力について覚えておくことが重要です。

[DarrelSnush]

Как найти аудиопоздравления на телефон: полезные советы

Праздничные дни и особенные события в жизни отличная возможность удивить собственных недалёких оригинальным пожеланьем. Если вы желайте выслать аудиопоздравление на телефон, но не знаете, с чего начать, эта статья окажет вам помощь отыскать подходящие решения.

1. Поиск готовых аудиопоздравлений

Существует огромное количество ресурсов, в каком месте можно отыскать готовые аудиопоздравления:
- Веб-сайты специальные сайты и блоги предлагают коллекции аудиопоздравлений на разные удачный поводы: дни рождения, anniversaries, Новый год и прочие праздники. Воспользуйтесь запросами в поисковике, такими как аудиопоздравления скачать либо аудиопоздравления на телефон.
- Приложения многие мобильные приложения для создания поздравлений делают отличное предложение встроенные аудиофайлы. Попытайтесь установить прибавления, такие как "Пожелания" либо "Картинки и поздравления".

2. Запись собственного аудиопоздравления

Ежели вы хотите добавить личный штрих, запишите пожелание сами:
- Смартфон используйте приложение для записи звука (встроенное в телефон или сторонние приложения). Просто нажмите на запись, произнесите поздравление и сохраните файл.
- Редактирование с помощью приложений для редактирования звука (к примеру, Audacity либо GarageBand) вы сможете добавить музыку, эффекты или улучшить качество записи.

3. Отправка аудиопоздравления

После всего этого как вы нашли либо записали аудиопоздравление, вам надо выслать его:
- ММС вы можете выслать аудиофайл через MMS. Просто выберите файл и отправьте его, как обычное сообщение.
- Мессенджеры воспользуйтесь популярными приложениями, в том числе WhatsApp, Viber либо Telegram, чтобы выслать аудиозапись. Всегда есть возможность прибавления текста и эмодзи, чтобы сделать пожеланье более выразительным.
- Email если нужно отправить длиннющий https://audiosms.ru/ файл, используйте электронную почту. Прикрепите аудиофайл к сообщению и отправьте его адресату.

4. Внедрение социальных сетей

Если вы хотите сделать поздравление более общественным, опубликуйте его в нужных страницах в социальных сетях:
- Instagram Stories или Facebook загрузите аудиофайл либо добавьте его в видео, которое можно оформить с помощью благовидных фонов и фильтров.
- VK вы можете создать пост с аудиозаписью и поделиться им с приятелями либо в сообществах.

Заключение

Аудиопоздравления это хороший метод удивить и повеселить близких. Выбор готовых аудиофайлов, творенье собственного поздравления либо внедрение мессенджеров и социальных сетей все это окажет вам помощь найти безупречный метод поздравить своих приятелей и родных. Не страшитесь проявлять креативность, и ваш подарок станет незабываемым!