unit Unit7;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, math, Vcl.StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

const
MaxSerieSize=50000000;
MinSafeFloat=1e-10;
MaxSafeFloat=1e50;

type
PDoubleArr=^TDoubleArr;
TDoubleArr=array[0..maxseriesize-1] of double;


TDoubleArray=class
private
public
fcount:integer;
fcapacity:integer;
procedure SetCount(newcount:integer);
procedure SetCapacity(newcapacity:integer);
procedure QSort2GPT;
procedure QSort10Sections;
public
fitems:pdoublearr;
procedure Add(value:double);
procedure Grow;
procedure Assign(otherarray: tdoublearray);
property Count:integer read fcount write setcount;
property Capacity:integer read fcapacity write SetCapacity;
end;


var
  Form1: TForm1;

implementation

{$R *.dfm}


procedure TDoubleArray.SetCapacity(newcapacity: integer);
begin
  if NewCapacity < fCount then
    raise exception.Create('NewCapacity='+inttostr(NewCapacity));
  if NewCapacity <> fCapacity then
  begin
    ReallocMem(fitems, NewCapacity * SizeOf(double));
    FCapacity := NewCapacity;
  end;
end;

procedure TDoubleArray.SetCount(newcount: integer);
begin
if newcount>fcapacity then setcapacity(newcount);
fcount := newcount;
end;


procedure TDoubleArray.QSort2GPT;
var
arr:array of double;
q:integer;
procedure QSort(low,high:integer);
var
  i, j: Integer;
  pivot, temp: double;
begin
  i := low;
  j := high;
  pivot := arr[(low + high) div 2];

  repeat
    while arr[i] < pivot do
      Inc(i);
    while arr[j] > pivot do
      Dec(j);

    if i <= j then
    begin
      temp := arr[i];
      arr[i] := arr[j];
      arr[j] := temp;
      Inc(i);
      Dec(j);
    end;
  until i > j;

  if low < j then
    QSort(low, j);
  if i < high then
    QSort(i, high);
end;
begin
if count<=1 then exit;

setlength(arr,count);
for q:=0 to count-1 do arr[q]:=fitems[q];
qsort(0,count-1);
for q:=0 to count-1 do fitems[q]:=arr[q];
setlength(arr,0);

end;

procedure TDoubleArray.QSort10Sections;
const
SectionsCount=100;
var
sectionsize:integer;
Sections:array[0..SectionsCount-1] of tdoublearray;
q,w:integer;
minval,maxval:double;
interval:double;
begin
if fcount<300 then begin
QSort2GPT;
exit;
end;


minval:=MaxSafeFloat;
maxval:=-MaxSafeFloat;
for q:=0 to fcount-1 do begin
if fitems[q]<minval then minval:=fitems[q];
if fitems[q]>maxval then maxval:=fitems[q];
end;//next q

minval:=minval-minsafefloat;
maxval:=maxval+minsafefloat;
interval:=maxval-minval;

sectionsize:=fcount div sectionscount;
for q:=0 to sectionscount-1 do begin
sections[q]:=TDoubleArray.Create;
sections[q].Capacity:=sectionsize*2;
end;

for q:=0 to fcount-1 do begin
sections[floor((sectionscount-1)*(fitems[q]-minval)/interval)].Add(fitems[q]);
end;

count:=0;
for q:=0 to SectionsCount-1 do begin
sections[q].QSort10Sections;
for w:=0 to sections[q].fcount-1 do add(sections[q].fitems[w]);
sections[q].Free;
end;


end;

procedure TDoubleArray.Add(value: double);
begin
fcount:=fcount+1;
if fcount>fcapacity then grow;
fitems^[fcount-1]:=value;
end;

procedure TDoubleArray.Grow;
begin
if fcapacity<100 then setcapacity(100) else
setcapacity(fcapacity*2);
end;

procedure TDoubleArray.Assign(otherarray: tdoublearray);
var
q:integer;
begin
count:=0;
capacity:=otherarray.Count;
for q:=0 to otherarray.Count-1 do add(otherarray.fitems[q]);
end;



procedure TForm1.Button1Click(Sender: TObject);
var
q,w:integer;
firsttime:longword;
timegpt,timesections:longword;
curarray:tdoublearray;
outstr:string;
begin

firsttime:=GetTickCount;
for q:=0 to 100 do begin
curarray:=tdoublearray.Create;
curarray.Capacity:=100000;
for w:=0 to  99999 do curarray.Add(random);
curarray.QSort2GPT;
curarray.Free;
end;
timegpt:=gettickcount-firsttime;

firsttime:=GetTickCount;
for q:=0 to 100 do begin
curarray:=tdoublearray.Create;
curarray.Capacity:=100000;
for w:=0 to  99999 do curarray.Add(random);
curarray.QSort10Sections;
curarray.Free;
end;
timesections:=gettickcount-firsttime;


outstr:='GPT: '+inttostr(timegpt)+'; Секции: '+inttostr(timesections);
application.MessageBox(pchar(outstr),'Тест',mb_ok);

end;

procedure TForm1.Button2Click(Sender: TObject);
var
q,w:integer;
arr1,arr2:tdoublearray;
begin
for q:=0 to 100 do begin
arr1:=tdoublearray.Create;
arr1.Capacity:=10000;
for w:=0 to 9999 do arr1.Add(random);
arr2:=tdoublearray.Create;
arr2.assign(arr1);

arr1.QSort2GPT;
arr2.QSort10Sections;

for w:=0 to arr1.Count-1 do if arr1.fitems[w]<>arr2.fitems[w] then application.MessageBox('Ошибка!','Test',mb_ok);


end;
end;

end.