FHannes Posted January 11, 2012 Share Posted January 11, 2012 (edited) 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 Quote Link to comment Share on other sites More sharing options...
Janilabo Posted January 13, 2012 Share Posted January 13, 2012 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 Quote Link to comment Share on other sites More sharing options...
FHannes Posted January 13, 2012 Author Share Posted January 13, 2012 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. Quote Link to comment Share on other sites More sharing options...
Wanted Posted January 14, 2012 Share Posted January 14, 2012 Nice to see these posted Quote Link to comment Share on other sites More sharing options...
FHannes Posted January 16, 2012 Author Share Posted January 16, 2012 (edited) 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 Quote Link to comment Share on other sites More sharing options...
Janilabo Posted May 5, 2013 Share Posted May 5, 2013 (edited) 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 Quote Link to comment Share on other sites More sharing options...
Janilabo Posted May 6, 2013 Share Posted May 6, 2013 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 Quote Link to comment Share on other sites More sharing options...