Странно, тестирую бытсрую и пирамидальную на скорость, первая бысрее... может я ошибся где-то ?
Вот код:
Код
{$M 65000, 0, 0}
Const
N=9000;
type
x=array[1..N] of real;
Var
a:x;
i:integer;
T:longint;
G:LongInT;
procedure swap (i, j : word);
var
t : real;
begin
t := a[i];
a[i] := a[j];
a[j] := t
end;
procedure sort (n, t : word);
begin
while ((t shl 1+1 <= n) and (a[t shl 1+1] > a[t]) or (t shl 1 <= n) and (a[t shl 1] > a[t])) do
begin
if (a[t shl 1+1] >= a[t shl 1]) and (t shl 1 +1 <= n) then
begin
swap (t shl 1 +1, t);
t := t shl 1+1
end else
begin
swap (t shl 1, t);
t := t shl 1
end
end;
end;
procedure Sort_Quick(var a:x; left,right:integer);
var
l,r:integer;
B:real;
begin
l:=left;
r:=right;
B:=a[l];
repeat
while (a[r]>=B) and (l<r) do r:=r-1;
a[l]:=a[r];
while (a[l]<=B) and (l<r) do l:=L+1;
a[r]:=a[l]
until r=l;
a[l]:=B;
If left<L-1 then SORT_QUICK(a,left,l-1);
If r+1<right then Sort_Quick(a,r+1,right);
end;
begin
Randomize;
T:=MemL[$0040:$006C];
FOR G:=1 to 100 do
begin
for i := 1 to n do a[i]:=Random(MaxInt);
for i := n downto 1 do sort (n, i);
for i := n downto 1 do
begin
swap (1, i);
sort (i-1, 1);
end;
End;
T:=MemL[$0040:$006C]-T;
Writeln(T);
T:=MemL[$0040:$006C];
FOR G:=1 to 100 do
begin
for i := 1 to n do a[i]:=Random(MaxInt);
Sort_Quick(A,1,n);
End;
T:=MemL[$0040:$006C]-T;
Writeln(T);
end.