TDoubleArray=class(tsafeobject)
private

public
fcount:integer;
fcapacity:integer;
procedure SetCount(newcount:integer);
procedure SetCapacity(newcapacity:integer);
//procedure SetCapacityQuick(newcapacity:integer);
//Странно, выходит и setcapacity не заполняет нулями. И setcount значит тоже
function GetItem(index: integer): double;
procedure SetItem(index: integer; Value: double);
public
fitems:pdoublearr;
procedure CopyToSimpleArray(var arr:array of double);
destructor Destroy; override;
property Items[index:integer]:double read GetItem write SetItem; default;
property Count:integer read fcount write setcount;
property Capacity:integer read fcapacity write SetCapacity;
function FirstPointer:pdoublearr;
procedure Grow;
procedure Clear;
function SafeGetItem(ind:integer; errval:double):double;//Если выходит за границы индекса - возвращает errval
function TryGetItem(ind:integer; out res:double):boolean;
procedure SetZeroValues(newcount:integer);
procedure SetBlankValues(newcount:integer; newval:double);
procedure Add(value:double);
procedure AddArray(otherarray:tdoublearray);
procedure SwapPoints(pointnum1,pointnum2:integer);
procedure Assign(otherarray:tdoublearray);
procedure SortByGrowing;
function LinInterValue(kx:double):double;//kx-положение в массиве (в вещественных координатах);0 - первая точка, 1 - вторая, 0.5 - посередине
function LagrInterpValue(kx:double; polnum:integer):double;//Интерполяция по Лагранжу: polnum - стенень полинома (должно быть четное число). 2 - линейная интерполяция
function SumValues:double;
function MaxValue:double;
function HasNonZeroValues:boolean;
procedure QSort(ascending:boolean);
procedure SmoothAdjacentAveraging(numpoints:integer);
procedure GetValuesInterval(minval,maxval:double; out minn,maxn:integer);//определяет интервал точек, попадающих
//в указанные границы (предполагается что точки в массиве расположены по возрастанию)
function GetSortedNums(ascending:boolean):tintarray;
//Возвращает список номеров своих элементов, отсортированных по возрастанию (если ascending=true) или убыванию
function ValuesAreEquiDistant(out beg,step:double):boolean;//Возвращает false если чисел 0 или 1
//Также возвращает false если все значения равны
function ValuesAreSubsequent(out beg,step:double):boolean;//Возвращает true если идёт непрерывная последовательность эквидистантных значений, постоянно увеличивающихся
//Возвращает false если чисел 0; если 1, возвращает true и step 1
procedure AddValues(val:double);
procedure MultValues(val:double);
end;

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


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.Add(value: double);
begin
fcount:=fcount+1;
if fcount>fcapacity then grow;
fitems^[fcount-1]:=value;
end;

  tdoublearray = class (TList<double>)
    boolarr:array of boolean;
    arr2:array of double;
    procedure superqsort;
    procedure Log (FN: string; bCnt: boolean=true);
    procedure QuickSort(low, high: Integer);
    procedure QSort4;
    procedure QSort10Sections;
    procedure DoQSort(intervalbeg,intervallast:integer; hasminval,hasmaxval:boolean; minval,maxval:double);
  end;



procedure tdoublearray.Log (FN: string; bCnt: boolean=true);
var
  S, SCNT: string;
  i: integer;
  SA: TStringArray;
begin
  SetLength (SA, count);
  for i := 0 to count-1 do begin
    SA [i] := Items[i].ToString;
  end;
  S := JoinStr (SA, ' ');
  if bCnt then
    SCNT := count.ToString
  else
    SCNT := '';
  LOgger.AppendS (FN+'_'+SCNT + '.txt', S);
end;

procedure tdoublearray.superqsort;
var
q:integer;
sumval, midval, tmpval: double;
tmparray1, tmparray2: tdoublearray;
tmp: double;
begin
  //Log;
  if count<=1 then exit;
  if count=2 then begin
    if items[1]<items[0] then begin
      tmp:=items[1];
      items[1]:=items[0];
      items[0]:=tmp;
    end;
    exit;
  end;
  sumval:=0;
  for q:=0 to count-1 do
    sumval:=sumval+items[q];
  midval:=sumval/count;
  tmparray1:=tdoublearray.create;
  tmparray1.capacity:=count;
  tmparray2:=tdoublearray.create;
  tmparray2.capacity:=count;

  for q:=0 to count-1 do begin
    if items[q]>midval then
      tmparray2.add(items[q])
    else
      tmparray1.add(items[q]);
  end;
  tmparray1.superqsort;
  tmparray2.superqsort;

  for q:=0 to tmparray1.count-1 do
    items[q]:=tmparray1.items[q];
  for q:=0 to tmparray2.count-1 do
    items[tmparray1.count+q]:=tmparray2.items[q];

  tmparray1.free;
  tmparray2.free;
end;


procedure tdoublearray.QSort4;
begin
  setlength(arr2,count);
  setlength(boolarr,count);
  DoQSort(0, count-1,false,false,0,0);
  setlength(arr2,0);
  setlength(boolarr,0);
end;

  procedure tdoublearray.DoQSort(intervalbeg,intervallast:integer; hasminval,hasmaxval:boolean; minval,maxval:double);
  const
  MaxFloat=1E50;
    var
    curcount:integer;
    aveval:double;
    ii:integer;
    curvalscount:integer;
    lowvalscount:integer;
    tmpval:double;
  begin
    curcount:=intervallast-intervalbeg+1;
    if curcount<=1 then exit;//Всего один элемент, сортировать не надо
    if curcount=2 then
      begin
      if (Items[intervalbeg]<Items[intervallast])<>true then
        begin
        tmpval:=Items[intervalbeg];
        Items[intervalbeg]:=Items[intervallast];
        Items[intervallast]:=tmpval
        end;
      exit;
      end;

    if not hasminval then
      begin
      minval:=MaxFloat;
      for ii:=intervalbeg to intervallast do if Items[ii]<minval then minval:=Items[ii];
      end;

    if not hasminval then
      begin
      maxval:=-MaxFloat;
      for ii:=intervalbeg to intervallast do if Items[ii]>maxval then maxval:=Items[ii];
      end;


    aveval:=(minval+maxval)*0.5;


    for ii:=intervalbeg to intervallast do boolarr[ii]:=(Items[ii]<aveval);

    //Помещаем элементы, меньшие aveval, в первую часть arr2:
    curvalscount:=0;
    for ii:=intervalbeg to intervallast do if boolarr[ii]=true then
      begin
        inc(curvalscount);
        arr2[intervalbeg+curvalscount-1]:=Items[ii];
      end;

    lowvalscount:=curvalscount;

    if (lowvalscount=0) or (lowvalscount=curcount) then
      exit;//Все элементы в интервале равны, сортировать нельзя


    //Помещаем элементы, большие или равные aveval, в первую часть arr2:
    for ii:=intervalbeg to intervallast do if boolarr[ii]=not true then
      begin
        inc(curvalscount);
        arr2[intervalbeg+curvalscount-1]:=Items[ii];
      end;

    //Перемещаем arr2 в arr1:
    for ii:=intervalbeg to intervallast do Items[ii]:=arr2[ii];


    doqsort(intervalbeg,intervalbeg+lowvalscount-1,true,false,minval,0);
    doqsort(intervalbeg+lowvalscount,intervallast,false,true,0,maxval);

  end;


procedure TDoubleArray.QSort10Sections;
const
SectionsCount=100;
MaxSafeFloat= 1E9;
minsafefloat= 1E-9;
var
sectionsize:integer;
Sections:array[0..SectionsCount] of tdoublearray;
q,w:integer;
minval,maxval:double;
interval:double;
begin
if count<300 then begin
//Log ('C:\tems3\q10_', false);
QuickSort (0, Count-1);
exit;
end;


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

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

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

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

count:=0;
for q:=0 to SectionsCount-1 do begin

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

*procedure tdoublearray.QuickSort(low, high: Integer);
var
  i, j: Integer;
  pivot, temp: double;
begin
  i := low;
  j := high;
  pivot := Items[(low + high) div 2];

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

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

  if low < j then
    QuickSort(low, j);
  if i < high then
    QuickSort(i, high);
end;

procedure TestDoubleArray (L: integer; Cicles: integer);
var
  A, A1: tdoublearray;
  i, j: integer;
  S: string;
begin
  A:= tdoublearray.Create;
  A1 := tdoublearray.Create;
  A.Count := L;
  for i :=0 to L-1 do
    A [i] := Random (1000) + Random (1000) / 1000 + i / 100000000;

  S := 'standard' + ' ' + L.ToString + ' ' + Cicles.ToString;
  A1.Clear;
  A1.AddRange (A);
  TB (S);
  for i := 1 to Cicles do begin
    if i > 1 then begin
      A1.Clear;
      A1.AddRange (A);
    end;
    A1.Sort;
  end;
  TE (S);

  if L <= 10000000 then begin
    S := 'super' + ' ' + L.ToString + ' ' + Cicles.ToString;
    A1.Clear;
    A1.AddRange (A);
    TB (S);
    for i := 1 to Cicles do begin
      if i > 1 then begin
        A1.Clear;
        A1.AddRange (A);
      end;
      A1.superqsort;
    end;
    TE (S);

    S := 'q4' + ' ' + L.ToString + ' ' + Cicles.ToString;
    A1.Clear;
    A1.AddRange (A);
    TB (S);
    for i := 1 to Cicles do begin
      if i > 1 then begin
        A1.Clear;
        A1.AddRange (A);
      end;
      A1.QSort4;

      if (i = 1) and (L <= 100000) then
        A1.Log ('C:\tems3\q4');
    end;
    TE (S);

    S := 'q10' + ' ' + L.ToString + ' ' + Cicles.ToString;
    A1.Clear;
    A1.AddRange (A);
    TB (S);
    for i := 1 to Cicles do begin
      if i > 1 then begin
        A1.Clear;
        A1.AddRange (A);
      end;
      A1.QSort10Sections;

      if (i = 1) and (L <= 100000) then
        A1.Log ('C:\tems3\q10');
    end;
    TE (S);
  end;

  S := 'quick' + ' ' + L.ToString + ' ' + Cicles.ToString;
  A1.Clear;
  A1.AddRange (A);
  TB (S);
  for i := 1 to Cicles do begin
    if i > 1 then begin
      A1.Clear;
      A1.AddRange (A);
    end;
    A1.QuickSort (0, A1.Count-1);
    if (i = 1) and (L <= 100000) then
      A1.Log ('C:\tems3\quick');
  end;
  TE (S);

  A.Free;
  A1.Free;
end;

initialization
  Initializer.RegisterProc (ipLast,
  procedure
  var
    i: integer;
  begin
    TestDoubleArray (1000, 1000);
    TestDoubleArray (1000000, 1);
    TestDoubleArray (2000000, 1);
    // TestDoubleArray (10000000, 1);
    //TestDoubleArray (50000000, 1);
  end);

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

end;

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

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.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.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*10;
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 TMainForm.Button9Click(Sender: TObject);
var
firsttime:longword;
q,w:integer;
curarray:tdoublearray;
begin

RandSeed :=0;
firsttime:=GetTickCount;

for q:=0 to 80 do begin

curarray:=tdoublearray.Create;
curarray.Capacity:=100000;
for w:=0 to 99999 do curarray.Add(random);

curarray.QSort10Sections;


curarray.Free;
end;//next q

caption:=inttostr(GetTickCount-firsttime);
end;

procedure tdoublearray1.QuickSortStandHoar;
begin
QuickSort(0,count-1);
end;

procedure tdoublearray1.QuickSort(low, high: Integer);
var
  i, j: Integer;
  pivot, temp: double;
begin
  i := low;
  j := high;
  pivot := Items[(low + high) div 2];

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

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

  if low < j then
    QuickSort(low, j);
  if i < high then
    QuickSort(i, high);
end;