unit IntroSort;

interface

uses
  Generics.Defaults;

type
  TArray = record
  private
    const IntrosortSizeThreshold = 16;
    class function FloorLog2(n: Integer): Integer; static;

    class procedure SortTwoItems<T>(const comparer: IComparer<T>; left, right: Pointer); static; inline;
    class procedure SortThreeItems<T>(const comparer: IComparer<T>; left, mid, right: Pointer); static; inline;

    class procedure InsertionSort<T>(var values: array of T; const comparer: IComparer<T>; left, right: Integer); static;

    class procedure DownHeap<T>(var values: array of T; const comparer: IComparer<T>; left, count, i: Integer); static;
    class procedure HeapSort<T>(var values: array of T; const comparer: IComparer<T>; left, right: Integer); static;

    class function QuickSortPartition<T>(var values: array of T; const comparer: IComparer<T>; left, right: Integer): Integer; static;

    class procedure IntroSort<T>(var values: array of T; const comparer: IComparer<T>; left, right, depthLimit: Integer); overload; static;
    class procedure IntroSort<T>(var values: array of T; const comparer: IComparer<T>; index, count: Integer); overload; static;
  public
    class procedure Sort<T>(var values: array of T); overload; static;
    class procedure Sort<T>(var values: array of T; const comparer: IComparer<T>); overload; static;
    class procedure Sort<T>(var values: array of T; const comparer: IComparer<T>; index, count: Integer); overload; static;
  end;

implementation

uses
  RTLConsts,
  SysUtils;

{ TArray }

class function TArray.FloorLog2(n: Integer): Integer;
begin
  Result := 0;
  while n >= 1 do
  begin
    Inc(Result);
    n := n div 2;
  end;
end;

class procedure TArray.SortTwoItems<T>(const comparer: IComparer<T>; left,
  right: Pointer);
type
  PT = ^T;
var
  temp: T;
begin
  if comparer.Compare(PT(left)^, PT(right)^) > 0 then
  begin
    temp := PT(left)^;
    PT(left)^ := PT(right)^;
    PT(right)^ := temp;
  end;
end;

class procedure TArray.SortThreeItems<T>(const comparer: IComparer<T>; left,
  mid, right: Pointer);
type
  PT = ^T;
var
  temp: T;
begin
  if comparer.Compare(PT(left)^, PT(mid)^) > 0 then
  begin
    temp := PT(left)^;
    PT(left)^ := PT(mid)^;
    PT(mid)^ := temp;
  end;
  if comparer.Compare(PT(left)^, PT(right)^) > 0 then
  begin
    temp := PT(left)^;
    PT(left)^ := PT(right)^;
    PT(right)^ := temp;
  end;
  if comparer.Compare(PT(mid)^, PT(right)^) > 0 then
  begin
    temp := PT(mid)^;
    PT(mid)^ := PT(right)^;
    PT(right)^ := temp;
  end;
end;

class procedure TArray.DownHeap<T>(var values: array of T;
  const comparer: IComparer<T>; left, count, i: Integer);
var
  temp: T;
  child, n, x: Integer;
begin
  temp := values[left + i - 1];
  n := count div 2;
  while i <= n do
  begin
    child := i * 2;
    if (child < count) and (comparer.Compare(values[left + child - 1], values[left + child]) < 0) then
      Inc(child);
    if not comparer.Compare(temp, values[left + child - 1]) < 0 then
      Break;
    values[left + i - 1] := values[left + child - 1];
    i := child;
  end;
  values[left + i - 1] := temp;
end;

class procedure TArray.HeapSort<T>(var values: array of T;
  const comparer: IComparer<T>; left, right: Integer);
var
  count, i: Integer;
  temp: T;
begin
  count := right - left + 1;
  for i := count div 2 downto 1 do
    DownHeap<T>(values, comparer, left, count, i);
  for i := count downto 2 do
  begin
    temp := values[left];
    values[left] := values[left + i - 1];
    values[left + i - 1] := temp;
    DownHeap<T>(values, comparer, left, i - 1, 1);
  end;
end;

class procedure TArray.InsertionSort<T>(var values: array of T;
  const comparer: IComparer<T>; left, right: Integer);
var
  i, j: Integer;
  temp: T;
begin
  for i := left + 1 to right do
  begin
    j := i;
    temp := values[i];
    while (j > left) and (comparer.Compare(temp, values[j - 1]) < 0) do
    begin
      values[j] := values[j - 1];
      Dec(j);
    end;
    values[j] := temp;
  end;
end;

class function TArray.QuickSortPartition<T>(var values: array of T;
  const comparer: IComparer<T>; left, right: Integer): Integer;
var
  mid, pivotIndex: Integer;
  pivot, temp: T;
begin
  mid := left + (right - left) div 2;

  SortThreeItems<T>(comparer, @values[left], @values[mid], @values[right]);

  Dec(right);
  pivotIndex := right;

  pivot := values[mid];
  values[mid] := values[right];
  values[right] := pivot;

  while left < right do
  begin
    repeat
      Inc(left);
    until comparer.Compare(values[left], pivot) >= 0;
    repeat
      Dec(right);
    until comparer.Compare(pivot, values[right]) >= 0;

    if left >= right then
      Break;

    temp := values[left];
    values[left] := values[right];
    values[right] := temp;
  end;

  pivot := values[left];
  values[left] := values[pivotIndex];
  values[pivotIndex] := pivot;
  Result := left;
end;

class procedure TArray.IntroSort<T>(var values: array of T;
  const comparer: IComparer<T>; left, right, depthLimit: Integer);
var
  count, pivot: Integer;
begin
  while right > left do
  begin
    count := right - left + 1;
    if count <= IntrosortSizeThreshold then
    begin
      if count = 1 then
        Exit;
      if count = 2 then
      begin
        SortTwoItems<T>(comparer, @values[left], @values[right]);
        Exit;
      end;
      if count = 3 then
      begin
        SortThreeItems<T>(comparer, @values[left], @values[right - 1], @values[right]);
        Exit;
      end;
      InsertionSort<T>(values, comparer, left, right);
      Exit;
    end;

    if depthLimit = 0 then
    begin
      HeapSort<T>(values, comparer, left, right);
      Exit;
    end;

    Dec(depthLimit);
    pivot := QuickSortPartition<T>(values, comparer, left, right);
    IntroSort<T>(values, comparer, pivot + 1, right, depthLimit);
    right := pivot - 1;
  end;
end;

class procedure TArray.IntroSort<T>(var values: array of T;
  const comparer: IComparer<T>; index, count: Integer);
begin
  if count < 2 then
    Exit;

  IntroSort<T>(values, comparer, index, count + index - 1, 2 * FloorLog2(count));
end;

class procedure TArray.Sort<T>(var values: array of T);
begin
  IntroSort<T>(values, TComparer<T>.Default, Low(Values), Length(Values));
end;

class procedure TArray.Sort<T>(var values: array of T;
  const comparer: IComparer<T>);
begin
  IntroSort<T>(values, comparer, Low(Values), Length(Values));
end;

class procedure TArray.Sort<T>(var values: array of T;
  const comparer: IComparer<T>; index, count: Integer);
begin
  if (index < Low(values)) or ((index > High(values)) and (count > 0))
    or (index + count - 1 > High(values)) or (count < 0)
    or (index + count < 0) then
    raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange);
  if count <= 1 then
    Exit;
  IntroSort<T>(values, comparer, index, count);
end;

end.