procedure SortRadix(var a: array of Longint; n: Integer);
type LongintArr = array [0..0] of Longint;
var
b: ^LongintArr;
e: Integer;
{$R-}
procedure SortCount;
var
c: array [0..$F] of Integer;
i, t: Integer;
begin
FillChar(c,SizeOf(c),#0);
for i:=0 to n-1 do Inc(c[a[i] shr e and $F]);
for i:=Low(c)+1 to High(c) do Inc(c[i],c[i-1]);
for i:=n-1 downto 0 do begin
t:=a[i] shr e and $F;
Dec(c[t]); b^[c[t]]:=a[i];
end;
for i:=0 to n-1 do a[i]:=b^[i];
end;
var
i: Integer;
m: Longint;
begin
GetMem(b,n*SizeOf(Longint));
m:=a[0]; for i:=1 to n-1 do if m<a[i] then m:=a[i];
e:=0;
while m>0 do begin
SortCount; Inc(e,4); m:=m shr 4;
end;
FreeMem(b,n*SizeOf(Longint));
end;
const
n=10;
a: array [0..n-1] of Longint = (9,8,7,6,5,4,3,2,1,0);
var i: Integer;
begin
Write('A ='); for i:=Low(a) to High(a) do Write(' ',a[i]); WriteLn;
SortRadix(a,n);
Write('A''='); for i:=Low(a) to High(a) do Write(' ',a[i]); WriteLn;
end.
Можно сократить число проходов с 2 до 1 на каждый байт значения
procedure SortRadix(var a: array of Longint; n: Integer);
type LongintArr = array [0..0] of Longint;
var
b: ^LongintArr;
e: Integer;
{$R-}
procedure SortCount;
var
c: array [0..$FF] of Integer;
i, t: Integer;
begin
FillChar(c,SizeOf(c),#0);
for i:=0 to n-1 do Inc(c[a[i] shr e and $FF]);
for i:=Low(c)+1 to High(c) do Inc(c[i],c[i-1]);
for i:=n-1 downto 0 do begin
t:=a[i] shr e and $FF;
Dec(c[t]); b^[c[t]]:=a[i];
end;
for i:=0 to n-1 do a[i]:=b^[i];
end;
var
i: Integer;
m: Longint;
begin
GetMem(b,n*SizeOf(b[0]));
m:=a[0]; for i:=1 to n-1 do if m<a[i] then m:=a[i];
e:=0;
while m>0 do begin
SortCount; Inc(e,8); m:=m shr 8;
end;
FreeMem(b,n*SizeOf(b[0]));
end;
Также возможно увеличить производительность возврата содержимого b^ в a добавив функцию Move
Move(b^,a,n*SizeOf(a[0]));