{*********************************************************}
{* sorts.pas *}
{* Copyright (c) Julian M Bucknall 1998 *}
{* KOL Portions ©2001-2005, Thaddy de Koning *}
{* All rights reserved. *}
{*********************************************************}
{* Sort routines *}
{*********************************************************}
{Note: this unit is released as freeware. In other words, you are free
to use this unit in your own applications, however I retain all
copyright to the code. JMB}
unit sorts;
{$ifdef fpc}{$mode delphi}{$endif}
interface
type
TSortElement = double; // what you need to sort.
TLessFunction = function (const X, Y : TSortElement) : boolean;
{function prototype to compare two items and return true if item X
is STRICTLY LESS than item Y}
procedure BubbleSort(var aItemArray : array of TSortElement;
aLeft, aRight : integer;
aLessThan : TLessFunction);
procedure ShakerSort(var aItemArray : array of TSortElement;
aLeft, aRight : integer;
aLessThan : TLessFunction);
procedure SelectionSort(var aItemArray : array of TSortElement;
aLeft, aRight : integer;
aLessThan : TLessFunction);
procedure InsertionSort(var aItemArray : array of TSortElement;
aLeft, aRight : integer;
aLessThan : TLessFunction);
procedure ShellSort(var aItemArray : array of TSortElement;
aLeft, aRight : integer;
aLessThan : TLessFunction);
procedure QuickSort(var aItemArray : array of TSortElement;
aLeft, aRight : integer;
aLessThan : TLessFunction);
procedure UsualInsertionSort(var aItemArray : array of TSortElement;
aLeft, aRight : integer;
aLessThan : TLessFunction);
procedure UsualQuickSort(var aItemArray : array of TSortElement;
aLeft, aRight : integer;
aLessThan : TLessFunction);
implementation
procedure BubbleSort(var aItemArray : array of TSortElement;
aLeft, aRight : integer;
aLessThan : TLessFunction);
var
i, j : integer;
Temp : TSortElement;
begin
for i := aLeft to pred(aRight) do
for j := aRight downto succ(i) do
if aLessThan(aItemArray[j], aItemArray[j-1]) then begin
Temp := aItemArray[j];
aItemArray[j] := aItemArray[j-1];
aItemArray[j-1] := Temp;
end;
end;
procedure ShakerSort(var aItemArray : array of TSortElement;
aLeft, aRight : integer;
aLessThan : TLessFunction);
var
i : integer;
Temp : TSortElement;
begin
while (aLeft < aRight) do begin
for i := aRight downto succ(aLeft) do
if aLessThan(aItemArray[i], aItemArray[i-1]) then begin
Temp := aItemArray[i];
aItemArray[i] := aItemArray[i-1];
aItemArray[i-1] := Temp;
end;
inc(aLeft);
for i := succ(aLeft) to aRight do
if aLessThan(aItemArray[i], aItemArray[i-1]) then begin
Temp := aItemArray[i];
aItemArray[i] := aItemArray[i-1];
aItemArray[i-1] := Temp;
end;
dec(aRight);
end;
end;
procedure SelectionSort(var aItemArray : array of TSortElement;
aLeft, aRight : integer;
aLessThan : TLessFunction);
var
i, j : integer;
IndexOfMin : integer;
Temp : TSortElement;
begin
for i := aLeft to pred(aRight) do begin
IndexOfMin := i;
for j := succ(i) to aRight do
if aLessThan(aItemArray[j], aItemArray[IndexOfMin]) then
IndexOfMin := j;
Temp := aItemArray[i];
aItemArray[i] := aItemArray[IndexOfMin];
aItemArray[IndexOfMin] := Temp;
end;
end;
procedure UsualInsertionSort(var aItemArray : array of TSortElement;
aLeft, aRight : integer;
aLessThan : TLessFunction);
var
i, j : integer;
Temp : TSortElement;
begin
for i := succ(aLeft) to aRight do begin
Temp := aItemArray[i];
j := i;
while (j > aLeft) and aLessThan(Temp, aItemArray[j-1]) do begin
aItemArray[j] := aItemArray[j-1];
dec(j);
end;
aItemArray[j] := Temp;
end;
end;
procedure InsertionSort(var aItemArray : array of TSortElement;
aLeft, aRight : integer;
aLessThan : TLessFunction);
var
i, j : integer;
IndexOfMin : integer;
Temp : TSortElement;
begin
{find the smallest element and put it in the first position}
IndexOfMin := aLeft;
for i := succ(aLeft) to aRight do
if aLessThan(aItemArray[i], aItemArray[IndexOfMin]) then
IndexOfMin := i;
if (aLeft <> IndexOfMin) then begin
Temp := aItemArray[aLeft];
aItemArray[aLeft] := aItemArray[IndexOfMin];
aItemArray[IndexOfMin] := Temp;
end;
{now sort via insertion method}
for i := aLeft+2 to aRight do begin
Temp := aItemArray[i];
j := i;
while aLessThan(Temp, aItemArray[j-1]) do begin
aItemArray[j] := aItemArray[j-1];
dec(j);
end;
aItemArray[j] := Temp;
end;
end;
procedure ShellSort(var aItemArray : array of TSortElement;
aLeft, aRight : integer;
aLessThan : TLessFunction);
var
i, j : integer;
h : integer;
Temp : TSortElement;
begin
{firstly calculate the first h value we shall use: it'll be about
one ninth of the number of the elements}
h := 1;
while (h <= (aRight - aLeft) div 9) do
h := (h * 3) + 1;
{start a loop that'll decrement h by one third each time through}
while (h > 0) do begin
{now insertion sort each h-subfile}
for i := (aLeft + h) to aRight do begin
Temp := aItemArray[i];
j := i;
while (j >= (aLeft+h)) and aLessThan(Temp, aItemArray[j-h]) do begin
aItemArray[j] := aItemArray[j-h];
dec(j, h);
end;
aItemArray[j] := Temp;
end;
{decrease h by a third}
h := h div 3;
end;
end;
procedure UsualQuickSort(var aItemArray : array of TSortElement;
aLeft, aRight : integer;
aLessThan : TLessFunction);
function Partition(L, R : integer): integer;
var
i, j : integer;
Last : TSortElement;
Temp : TSortElement;
begin
{set up the indexes}
i := L;
j := pred(R);
{get the partition element}
Last := aItemArray[R];
{do forever (we'll break out of the loop when needed)}
while true do begin
{find the first element greater than or equal to the partition
element from the left; note that our partition element will
stop this loop}
while aLessThan(aItemArray[i], Last) do
inc(i);
{find the first element less than the partition element from the
right; check to break out of the loop if we hit the left
element - we have no sentinel there}
while aLessThan(Last, aItemArray[j]) do begin
if (j = L) then
Break;
dec(j);
end;
{if we crossed get out of this infinite loop to swap the
partition element into place}
if (i >= j) then
Break;
{otherwise swap the two out-of-place elements}
Temp := aItemArray[i];
aItemArray[i] := aItemArray[j];
aItemArray[j] := Temp;
{and continue}
inc(i);
dec(j);
end;
{swap the partition element into place, return the dividing index}
aItemArray[R] := aItemArray[i];
aItemArray[i] := Last;
Result := i;
end;
procedure QuickSortPrim(L, R : integer);
var
DividingItem : integer;
begin
{stop the recursion, if needed}
if (R - L) <= 0 then
Exit;
{otherwise, partition about the final element in the set}
DividingItem := Partition(L, R);
{recursively quicksort the two subsets either side of the dividing
element}
QuicksortPrim(L, pred(DividingItem));
QuicksortPrim(succ(DividingItem), R);
end;
begin
{start it all off}
QuicksortPrim(aLeft, aRight);
end;
procedure QuickSort(var aItemArray : array of TSortElement;
aLeft, aRight : integer;
aLessThan : TLessFunction);
function Partition(L, R : integer): integer;
var
i, j : integer;
Last : TSortElement;
Temp : TSortElement;
begin
{set up the indexes}
i := L;
j := pred(R);
{get the partition element}
Last := aItemArray[R];
{do forever (we'll break out of the loop when needed)}
while true do begin
{find the first element greater than or equal to the partition
element from the left; note that our partition element will
stop this loop}
while aLessThan(aItemArray[i], Last) do
inc(i);
{find the first element less than the partition element from the
right; note the median-of-three algorithm has ensured we have
a sentinel on the left}
while not aLessThan(aItemArray[j], Last) do
dec(j);
{if we crossed get out of this infinite loop to swap the
partition element into place}
if (i >= j) then
Break;
{otherwise swap the two out-of-place elements}
Temp := aItemArray[i];
aItemArray[i] := aItemArray[j];
aItemArray[j] := Temp;
{and continue}
inc(i);
dec(j);
end;
{swap the partition element into place, return the dividing index}
aItemArray[R] := aItemArray[i];
aItemArray[i] := Last;
Result := i;
end;
procedure QuickSortPrim(L, R : integer);
var
DividingItem : integer;
Temp : TSortElement;
i, j : integer;
begin
{if needed, stop the recursion at the cut-off point, and insertion
sort}
if (R - L) <= 10 then begin
for i := succ(L) to R do begin
Temp := aItemArray[i];
j := i;
while (j > L) and aLessThan(Temp, aItemArray[j-1]) do begin
aItemArray[j] := aItemArray[j-1];
dec(j);
end;
aItemArray[j] := Temp;
end;
Exit;
end;
{calculate the median-of-three element; for an extra bit of speed,
put the smallest element of the three in the first position, the
greatest in the last position, and the median in the last-but-one
position and partition a smaller subset excluding the first and
last}
Temp := aItemArray[(L+R) shr 1];
aItemArray[(L+R) shr 1] := aItemArray[pred(R)];
aItemArray[pred(R)] := Temp;
if not aLessThan(aItemArray[L], aItemArray[pred(R)]) then begin
Temp := aItemArray[L];
aItemArray[L] := aItemArray[pred(R)];
aItemArray[pred(R)] := Temp;
end;
if not aLessThan(aItemArray[L], aItemArray[R]) then begin
Temp := aItemArray[L];
aItemArray[L] := aItemArray[R];
aItemArray[R] := Temp;
end;
if not aLessThan(aItemArray[pred(R)], aItemArray[R]) then begin
Temp := aItemArray[R];
aItemArray[R] := aItemArray[pred(R)];
aItemArray[pred(R)] := Temp;
end;
DividingItem := Partition(succ(L), pred(R));
{recursively quicksort the two subsets either side of the dividing
element}
QuickSortPrim(L, pred(DividingItem));
QuickSortPrim(succ(DividingItem), R);
end;
begin
{start it all off}
QuickSortPrim(aLeft, aRight);
end;
end.