Here is a simple but effective TSort class that sorts external data just by a OnCompare and OnSwap event both based on indexes and not real data.
Currently it supports shellsort, quicksort and bubblesort (yes i know that it's normally the slowest but if the data is already sorted can be quite fast). The sorting methods where taken & ported from various sources.
Beware that quicksort (i think) might fail in one direction (my documentation says i fixed quicksort but i'm not 100% sure as debugging code is still present), if anybody can point out the problem or can make it fail during testing (or tell me it's ok), please let me know.
If you implement shakersort (bi-directional bubblesort) i'm also very very interested!
If you have the OnCompare event compare multiple colums from two rows of gridview and set the OnSwap to exchange two rows you can easily do very complex sorting (the reason why i wrote this class in the first place).
Only minor problem is that with a normal rowswap not all is exchanged (I think I was using the moverow method) in the older gridview versions (focus rectangle for instance).
Any comments are welcome!
The interface:
CODE
type
{
A ComparesEvent should compare two nodes indentified by their indexes.
The Action value returns should be :
0 is the e1 and e2 values are identical,
-1 if the e1 value is smaller than the e2 value and
+1 if the e1 value is larger than the e2 value.}
TCompareEvent = procedure(Sender: TObject; e1, e2: Word; var Action: Integer) of object;
{
A SwapEvent is called to swap two nodes identified by their indexes.}
TSwapEvent = procedure(Sender: TObject; e1, e2: Word) of object;
{
Sorting is performed on a 0 based starting index of the data
and Elements records of data.
}
TSort = class(TObject)
private
FOnCompare: TCompareEvent;
FOnSwap: TSwapEvent;
function GetCanSort: Boolean;
public
{The constructor.}
constructor Create(compare: TCompareEvent = nil; swap: TSwapEvent = nil);
{Performs a QuickSort on a 0 based array containing a number of Elements.}
procedure DoQuickSort(Sender: TObject; Elements: Word; Ascending: Boolean = True);
{Performs a BubbleSort on a 0 based array containing a number of Elements.}
procedure DoBubbleSort(Sender: TObject; Elements: Word; Ascending: Boolean = True);
{Performs a ShellSort on a 0 based array containing a number of Elements.}
procedure DoShellSort(Sender: TObject; Elements: Word; Ascending: Boolean = True);
{Performs a ShakerSort on a 0 based array containing a number of Elements.}
//procedure DoShakerSort(Sender: TObject; Elements: Word; Ascending: Boolean = True); //Not Implemented
{The destructor.}
destructor Destroy; override;
published
{OnCompare is the The @Link(TCompareEvent) that is used to compare two values to be ordered.}
property OnCompare: TCompareEvent read FOnCompare write FOnCompare;
{OnSWap is the the @Link(TCompareEvent) that is used to swap two values.}
property OnSwap: TSwapEvent read FOnSwap write FOnSwap;
{Returns True if both Events are assigned and thus sorting is possible.}
property CanSort: Boolean read GetCanSort;
end;
{
A ComparesEvent should compare two nodes indentified by their indexes.
The Action value returns should be :
0 is the e1 and e2 values are identical,
-1 if the e1 value is smaller than the e2 value and
+1 if the e1 value is larger than the e2 value.}
TCompareEvent = procedure(Sender: TObject; e1, e2: Word; var Action: Integer) of object;
{
A SwapEvent is called to swap two nodes identified by their indexes.}
TSwapEvent = procedure(Sender: TObject; e1, e2: Word) of object;
{
Sorting is performed on a 0 based starting index of the data
and Elements records of data.
}
TSort = class(TObject)
private
FOnCompare: TCompareEvent;
FOnSwap: TSwapEvent;
function GetCanSort: Boolean;
public
{The constructor.}
constructor Create(compare: TCompareEvent = nil; swap: TSwapEvent = nil);
{Performs a QuickSort on a 0 based array containing a number of Elements.}
procedure DoQuickSort(Sender: TObject; Elements: Word; Ascending: Boolean = True);
{Performs a BubbleSort on a 0 based array containing a number of Elements.}
procedure DoBubbleSort(Sender: TObject; Elements: Word; Ascending: Boolean = True);
{Performs a ShellSort on a 0 based array containing a number of Elements.}
procedure DoShellSort(Sender: TObject; Elements: Word; Ascending: Boolean = True);
{Performs a ShakerSort on a 0 based array containing a number of Elements.}
//procedure DoShakerSort(Sender: TObject; Elements: Word; Ascending: Boolean = True); //Not Implemented
{The destructor.}
destructor Destroy; override;
published
{OnCompare is the The @Link(TCompareEvent) that is used to compare two values to be ordered.}
property OnCompare: TCompareEvent read FOnCompare write FOnCompare;
{OnSWap is the the @Link(TCompareEvent) that is used to swap two values.}
property OnSwap: TSwapEvent read FOnSwap write FOnSwap;
{Returns True if both Events are assigned and thus sorting is possible.}
property CanSort: Boolean read GetCanSort;
end;
The implementation:
CODE
constructor TSort.Create(compare: TCompareEvent; swap: TSwapEvent);
begin
inherited Create();
FOnCompare := compare;
FOnSwap := swap;
end;
{-----------------------------------------------}
function TSort.GetCanSort: Boolean;
begin
Result := Assigned(FOnCompare) and Assigned(FOnSwap);
end;
{-----------------------------------------------}
procedure TSort.DoQuickSort(Sender: TObject; Elements: Word; Ascending: Boolean = True);
function Compare(e1, e2: Word): Integer;
begin
// OutputDebugString(Pchar(Format('Comparing :%2.2d and :%2.2d', [e1, e2])));
FOnCompare(Sender, e1, e2, Result);
end;
procedure Swap(e1, e2: Word);
begin
// OutputDebugString(Pchar(Format('Swapping :%2.2d and :%2.2d', [e1, e2])));
FOnSwap(Sender, e1, e2);
end;
procedure QuickSort(lower, upper: Word); //Fails with Word...
var
i, j, pivot : Integer;
begin
if (lower < upper) then //This test fails when using words and no safeguard down below.
begin
i := lower;
j := upper;
pivot := j;
//if (lower < 0) then
//OutputDebugString(Pchar(Format('QuickSort lower:%2.2d, upper:%2.2d, pivot:%2.2d', [lower, upper, pivot])));
repeat
while (i < j) and (Compare(i, pivot) <= 0) do //a<b
Inc(i); { Parting for left }
while (i < j) and (Compare(j, pivot) >= 0) do
Dec(j); { Parting for right}
if (i < j) then Swap(i, j);
until (i >= j);
Swap(i, upper);
if (i - lower) > (upper - i) then
begin
if (i > 0) then
QuickSort(lower, i - 1);
QuickSort(i + 1, upper);
end
else
begin
QuickSort(i + 1, upper);
if (i > 0) then
QuickSort(lower, i - 1);
end;
end;
end;
begin
if CanSort then
QuickSort(0, Elements - 1);
end;
{-----------------------------------------------}
procedure TSort.DoBubbleSort(Sender: TObject; Elements: Word; Ascending: Boolean = True);
function Compare(e1, e2: Word): Integer;
begin
FOnCompare(Sender, e1, e2, Result);
end;
procedure Swap(e1, e2: Word);
begin
FOnSwap(Sender, e1, e2);
end;
procedure BubbleSort;
var
i, j : Word;
swapped : Boolean;
m : Integer;
begin
if ascending then
m := 1
else
m := -1;
if CanSort then
begin
i := 0;
swapped := True;
while (i < Pred(Elements)) and swapped do
begin
j := Pred(Elements);
while (j > i) do
begin
if (m * Compare(j, j - 1) < 0) then
begin
swapped := True;
Swap(j, j - 1);
end;
Dec(j);
end;
Inc(i);
end;
end;
end;
begin
if CanSort then
BubbleSort;
end;
{-----------------------------------------------}
//procedure TSort.DoShakerSort(Sender: TObject; uNElem: Word; Ascending: Boolean = True);
//begin
//end;
{-----------------------------------------------}
procedure TSort.DoShellSort(Sender: TObject; Elements: Word; Ascending: Boolean = True);
function Compare(e1, e2: Word): Integer;
begin
FOnCompare(Sender, e1 - 1, e2 - 1, Result);
end;
procedure Swap(e1, e2: Word);
begin
FOnSwap(Sender, e1 - 1, e2 - 1);
end;
procedure ShellSort(NumberItems, Distance: Integer);
var
X, Y : Integer;
m : Integer;
begin
if ascending then
m := 1
else
m := -1;
for Y := Distance + 1 to NumberItems do
begin
X := Y - Distance;
while X > 0 do
begin
if m * Compare(X + Distance, X) = -1 then
begin
Swap(X + Distance, X);
X := X - Distance;
end
else
X := 0;
end;
end
end;
var
Distance : Integer;
begin
if CanSort then
begin
Distance := Pred(Elements) div 2;
while Distance > 0 do
begin
ShellSort(Elements, Distance);
Distance := Distance div 2
end;
end
end;
{-----------------------------------------------}
destructor TSort.Destroy;
begin
inherited;
end;
begin
inherited Create();
FOnCompare := compare;
FOnSwap := swap;
end;
{-----------------------------------------------}
function TSort.GetCanSort: Boolean;
begin
Result := Assigned(FOnCompare) and Assigned(FOnSwap);
end;
{-----------------------------------------------}
procedure TSort.DoQuickSort(Sender: TObject; Elements: Word; Ascending: Boolean = True);
function Compare(e1, e2: Word): Integer;
begin
// OutputDebugString(Pchar(Format('Comparing :%2.2d and :%2.2d', [e1, e2])));
FOnCompare(Sender, e1, e2, Result);
end;
procedure Swap(e1, e2: Word);
begin
// OutputDebugString(Pchar(Format('Swapping :%2.2d and :%2.2d', [e1, e2])));
FOnSwap(Sender, e1, e2);
end;
procedure QuickSort(lower, upper: Word); //Fails with Word...
var
i, j, pivot : Integer;
begin
if (lower < upper) then //This test fails when using words and no safeguard down below.
begin
i := lower;
j := upper;
pivot := j;
//if (lower < 0) then
//OutputDebugString(Pchar(Format('QuickSort lower:%2.2d, upper:%2.2d, pivot:%2.2d', [lower, upper, pivot])));
repeat
while (i < j) and (Compare(i, pivot) <= 0) do //a<b
Inc(i); { Parting for left }
while (i < j) and (Compare(j, pivot) >= 0) do
Dec(j); { Parting for right}
if (i < j) then Swap(i, j);
until (i >= j);
Swap(i, upper);
if (i - lower) > (upper - i) then
begin
if (i > 0) then
QuickSort(lower, i - 1);
QuickSort(i + 1, upper);
end
else
begin
QuickSort(i + 1, upper);
if (i > 0) then
QuickSort(lower, i - 1);
end;
end;
end;
begin
if CanSort then
QuickSort(0, Elements - 1);
end;
{-----------------------------------------------}
procedure TSort.DoBubbleSort(Sender: TObject; Elements: Word; Ascending: Boolean = True);
function Compare(e1, e2: Word): Integer;
begin
FOnCompare(Sender, e1, e2, Result);
end;
procedure Swap(e1, e2: Word);
begin
FOnSwap(Sender, e1, e2);
end;
procedure BubbleSort;
var
i, j : Word;
swapped : Boolean;
m : Integer;
begin
if ascending then
m := 1
else
m := -1;
if CanSort then
begin
i := 0;
swapped := True;
while (i < Pred(Elements)) and swapped do
begin
j := Pred(Elements);
while (j > i) do
begin
if (m * Compare(j, j - 1) < 0) then
begin
swapped := True;
Swap(j, j - 1);
end;
Dec(j);
end;
Inc(i);
end;
end;
end;
begin
if CanSort then
BubbleSort;
end;
{-----------------------------------------------}
//procedure TSort.DoShakerSort(Sender: TObject; uNElem: Word; Ascending: Boolean = True);
//begin
//end;
{-----------------------------------------------}
procedure TSort.DoShellSort(Sender: TObject; Elements: Word; Ascending: Boolean = True);
function Compare(e1, e2: Word): Integer;
begin
FOnCompare(Sender, e1 - 1, e2 - 1, Result);
end;
procedure Swap(e1, e2: Word);
begin
FOnSwap(Sender, e1 - 1, e2 - 1);
end;
procedure ShellSort(NumberItems, Distance: Integer);
var
X, Y : Integer;
m : Integer;
begin
if ascending then
m := 1
else
m := -1;
for Y := Distance + 1 to NumberItems do
begin
X := Y - Distance;
while X > 0 do
begin
if m * Compare(X + Distance, X) = -1 then
begin
Swap(X + Distance, X);
X := X - Distance;
end
else
X := 0;
end;
end
end;
var
Distance : Integer;
begin
if CanSort then
begin
Distance := Pred(Elements) div 2;
while Distance > 0 do
begin
ShellSort(Elements, Distance);
Distance := Distance div 2
end;
end
end;
{-----------------------------------------------}
destructor TSort.Destroy;
begin
inherited;
end;
To sort random numbers in a TMemo, just use the following code:
CODE
procedure TForm1.DoCompare(Sender: TObject; e1, e2: Word;
var Action: Integer);
begin
if (StrToInt(Memo1.Lines[e1]) < StrToInt(Memo1.Lines[e2])) then
Action := -1
else if (StrToInt(Memo1.Lines[e1]) > StrToInt(Memo1.Lines[e2])) then
Action := 1
else
Action := 0;
end;
procedure TForm1.DoSwap(Sender: TObject; e1, e2: Word);
begin
Memo1.Lines.Exchange(e1, e2);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
i, j : Integer;
sort : TSort;
begin
Memo1.DoubleBuffered := True;
sort := TSort.Create(DoCompare, DoSwap);
if not sort.CanSort then Exit;
Randomize;
//sort 100 times
for j := 1 to 100 do
begin
Memo1.Clear;
//create demo data
Memo1.Lines.BeginUpdate;
for i := 0 to 100 do
Memo1.Lines.Add(IntToStr(Random(1000)));
Memo1.Lines.EndUpdate;
//sort
Memo1.Lines.BeginUpdate;
sort.DoShellSort(Self, Memo1.Lines.Count);
Memo1.Lines.EndUpdate;
//test if sorted
for i := 0 to Pred(Memo1.Lines.Count) - 1 do
if StrToInt(Memo1.Lines[i]) > StrToInt(Memo1.Lines[i + 1]) then
begin
ShowMessage('Sort Error:' + IntToStr(i));
Break;
end;
end;
end;
var Action: Integer);
begin
if (StrToInt(Memo1.Lines[e1]) < StrToInt(Memo1.Lines[e2])) then
Action := -1
else if (StrToInt(Memo1.Lines[e1]) > StrToInt(Memo1.Lines[e2])) then
Action := 1
else
Action := 0;
end;
procedure TForm1.DoSwap(Sender: TObject; e1, e2: Word);
begin
Memo1.Lines.Exchange(e1, e2);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
i, j : Integer;
sort : TSort;
begin
Memo1.DoubleBuffered := True;
sort := TSort.Create(DoCompare, DoSwap);
if not sort.CanSort then Exit;
Randomize;
//sort 100 times
for j := 1 to 100 do
begin
Memo1.Clear;
//create demo data
Memo1.Lines.BeginUpdate;
for i := 0 to 100 do
Memo1.Lines.Add(IntToStr(Random(1000)));
Memo1.Lines.EndUpdate;
//sort
Memo1.Lines.BeginUpdate;
sort.DoShellSort(Self, Memo1.Lines.Count);
Memo1.Lines.EndUpdate;
//test if sorted
for i := 0 to Pred(Memo1.Lines.Count) - 1 do
if StrToInt(Memo1.Lines[i]) > StrToInt(Memo1.Lines[i + 1]) then
begin
ShowMessage('Sort Error:' + IntToStr(i));
Break;
end;
end;
end;
Small Update
------------
Hi
I saw that i had disabled descending sorting in quicksort all together. Here a modification that seems to work (basically it's negating the compare function).
Just change the first lines of the DoQuickSort routine into :
CODE
procedure TSort.DoQuickSort(Sender: TObject; Elements: Word; Ascending: Boolean = True);
var
m : Integer;
function Compare(e1, e2: Word): Integer;
var
r : Integer;
begin
FOnCompare(Sender, e1, e2, r);
Result := m * r;
end;
procedure Swap(e1, e2: Word);
begin
FOnSwap(Sender, e1, e2);
end;
procedure QuickSort(lower, upper: Word); //Fails with Word...
var
i, j, pivot : Integer;
begin
if ascending then
m := 1
else
m := -1;
if (lower < upper) then //This test fails when using words and no safeguard down below.
var
m : Integer;
function Compare(e1, e2: Word): Integer;
var
r : Integer;
begin
FOnCompare(Sender, e1, e2, r);
Result := m * r;
end;
procedure Swap(e1, e2: Word);
begin
FOnSwap(Sender, e1, e2);
end;
procedure QuickSort(lower, upper: Word); //Fails with Word...
var
i, j, pivot : Integer;
begin
if ascending then
m := 1
else
m := -1;
if (lower < upper) then //This test fails when using words and no safeguard down below.
