unit Qsort;
{TQSort by Mike Junkin 10/19/95.
DoQSort routine adapted from Peter Szymiczek's QSort procedure which
was presented in issue#8 of The Unofficial Delphi Newsletter.}
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs;
type
TSwapEvent = procedure (Sender : TObject; e1,e2 : word) of Object;
TCompareEvent = procedure (Sender: TObject; e1,e2 : word; var Action : integer) of Object;
TQSort = class(TComponent)
private
FCompare : TCompareEvent;
FSwap : TSwapEvent;
public
procedure DoQSort(Sender: TObject; uNElem: word);
published
property Compare : TCompareEvent read FCompare write FCompare;
property Swap : TSwapEvent read FSwap write FSwap;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Mikes', [TQSort]);
end;
procedure TQSort.DoQSort(Sender: TObject; uNElem: word);
{ uNElem - number of elements to sort }
procedure qSortHelp(pivotP: word; nElem: word);
label
TailRecursion,
qBreak;
var
leftP, rightP, pivotEnd, pivotTemp, leftTemp: word;
lNum: word;
retval: integer;
begin
retval := 0;
TailRecursion:
if (nElem <= 2) then
begin
if (nElem = 2) then
begin
rightP := pivotP +1;
FCompare(Sender,pivotP,rightP,retval);
if (retval > 0) then Fswap(Sender,pivotP,rightP);
end;
exit;
end;
rightP := (nElem -1) + pivotP;
leftP := (nElem shr 1) + pivotP;
{ sort pivot, left, and right elements for "median of 3" }
FCompare(Sender,leftP,rightP,retval);
if (retval > 0) then Fswap(Sender,leftP, rightP);
FCompare(Sender,leftP,pivotP,retval);
if (retval > 0) then Fswap(Sender,leftP, pivotP)
else
begin
FCompare(Sender,pivotP,rightP,retval);
if retval > 0 then Fswap(Sender,pivotP, rightP);
end;
if (nElem = 3) then
begin
Fswap(Sender,pivotP, leftP);
exit;
end;
{ now for the classic Horae algorithm }
pivotEnd := pivotP + 1;
leftP := pivotEnd;
repeat
FCompare(Sender,leftP, pivotP,retval);
while (retval <= 0) do
begin
if (retval = 0) then
begin
Fswap(Sender,leftP, pivotEnd);
Inc(pivotEnd);
end;
if (leftP < rightP) then
Inc(leftP)
else
goto qBreak;
FCompare(Sender,leftP, pivotP,retval);
end; {while}
while (leftP < rightP) do
begin
FCompare(Sender,pivotP, rightP,retval);
if (retval < 0) then
Dec(rightP)
else
begin
FSwap(Sender,leftP, rightP);
if (retval <> 0) then
begin
Inc(leftP);
Dec(rightP);
end;
break;
end;
end; {while}
until (leftP >= rightP);
qBreak:
FCompare(Sender,leftP,pivotP,retval);
if (retval <= 0) then Inc(leftP);
leftTemp := leftP -1;
pivotTemp := pivotP;
while ((pivotTemp < pivotEnd) and (leftTemp >= pivotEnd)) do
begin
Fswap(Sender,pivotTemp, leftTemp);
Inc(pivotTemp);
Dec(leftTemp);
end; {while}
lNum := (leftP - pivotEnd);
nElem := ((nElem + pivotP) -leftP);
if (nElem < lNum) then
begin
qSortHelp(leftP, nElem);
nElem := lNum;
end
else
begin
qSortHelp(pivotP, lNum);
pivotP := leftP;
end;
goto TailRecursion;
end; {qSortHelp }
begin
if Assigned(FCompare) and Assigned(FSwap) then
begin
if (uNElem < 2) then exit; { nothing to sort }
qSortHelp(1, uNElem);
end;
end; { QSort }
end.
{ demo }
unit Unit1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Grids, Qsort, StdCtrls;
type
TForm1 = class(TForm)
QSort1: TQSort;
StringGrid1: TStringGrid;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure QSort1Compare(Sender: TObject; e1, e2: Word; var Action: Integer);
procedure QSort1Swap(Sender: TObject; e1, e2: Word);
procedure Button1Click(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
with StringGrid1 do
begin
Cells[1,1] := 'the';
Cells[1,2] := 'brown';
Cells[1,3] := 'dog';
Cells[1,4] := 'bit';
Cells[1,5] := 'me';
end;
end;
procedure TForm1.QSort1Compare(Sender: TObject; e1, e2: Word;
var Action: Integer);
begin
with Sender as TStringGrid do
begin
if (Cells[1, e1] < Cells[1, e2]) then
Action := -1
else if (Cells[1, e1] > Cells[1, e2]) then
Action := 1
else
Action := 0;
end; {with}
end;
procedure TForm1.QSort1Swap(Sender: TObject; e1, e2: Word);
var
s: string[63]; { must be large enough to contain the longest string in the grid }
i: integer;
begin
with Sender as TStringGrid do
for i := 0 to ColCount -1 do
begin
s := Cells[i, e1];
Cells[i, e1] := Cells[i, e2];
Cells[i, e2] := s;
end; {for}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
QSort1.DoQSort(StringGrid1,STringGrid1.RowCount-1);
end;
end.