fpc/packages/rtl-extra/src/inc/sortalgs.pp

{
    This file is part of the Free Pascal Run Time Library (rtl)
    Copyright (c) 1999-2019 by the Free Pascal development team

    This file provides alternative pluggable sorting algorithms,
    which can be used instead of the default QuickSort implementation
    in unit SortBase.

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

{$IFNDEF FPC_DOTTEDUNITS}
unit SortAlgs;
{$ENDIF FPC_DOTTEDUNITS}

{$MODE objfpc}

interface

{$IFDEF FPC_DOTTEDUNITS}
uses
  System.SortBase;
{$ELSE FPC_DOTTEDUNITS}
uses
  SortBase;
{$ENDIF FPC_DOTTEDUNITS}

{
                       HeapSort

  Average performance: O(n log n)
    Worst performance: O(n log n)
     Extra memory use: O(1)
               Stable: no
     Additional notes: Usually slower in practice, compared to QuickSort (in the
                       average case), but has a much better worst-case
                       performance of O(n log n) (versus O(n*n) for QuickSort).
                       Can be used instead of QuickSort where the risk of
                       QuickSort's worst case scenario is not acceptable - e.g.
                       high risk applications, security-conscious applications
                       or applications with hard real-time requirements.

                       On systems with small or no data caches it might perform
                       better or comparable to QuickSort even in the average
                       case, so might be a good general purpose choice for
                       embedded systems as well. It's O(1) extra memory use and
                       the fact it's not recursive also makes it a good
                       candidate for embedded use.
}

procedure HeapSort_PtrList_NoContext(
                ItemPtrs: PPointer;
                ItemCount: SizeUInt;
                Comparer: TListSortComparer_NoContext);
procedure HeapSort_PtrList_Context(
                ItemPtrs: PPointer;
                ItemCount: SizeUInt;
                Comparer: TListSortComparer_Context;
                Context: Pointer);
procedure HeapSort_ItemList_Context(
                Items: Pointer;
                ItemCount, ItemSize: SizeUInt;
                Comparer: TListSortComparer_Context;
                Context: Pointer);
procedure HeapSort_ItemList_CustomItemExchanger_Context(
                Items: Pointer;
                ItemCount, ItemSize: SizeUInt;
                Comparer: TListSortComparer_Context;
                Exchanger: TListSortCustomItemExchanger_Context;
                Context: Pointer);

const
  HeapSort: TSortingAlgorithm = (
    PtrListSorter_NoContextComparer: @HeapSort_PtrList_NoContext;
    PtrListSorter_ContextComparer: @HeapSort_PtrList_Context;
    ItemListSorter_ContextComparer: @HeapSort_ItemList_Context;
    ItemListSorter_CustomItemExchanger_ContextComparer: @HeapSort_ItemList_CustomItemExchanger_Context;
  );

{
                       Randomized QuickSort

  Average performance: O(n log n)
    Worst performance: O(n*n)
     Extra memory use: O(log n) on the stack
               Stable: no
     Additional notes: Uses a random element as the pivot. This makes it harder
                       to intentionally produce an input permutation that
                       triggers its worst O(n*n) performance. Note that, while
                       this ensures that no particular input triggers the worst
                       case scenario, this doesn't completely eliminate the
                       chance of it happening. There is still an extremely
                       small chance that the random number generator generates
                       an unlucky sequence that triggers the worst O(n*n)
                       performance when combined with the input permutation.
                       And it is still possible for a malicious user to
                       deliberately construct a worst case scenario, if the
                       random sequence can be predicted (it is generated by a
                       pseudorandom-number generator, which means its output is
                       deterministic, and can be predicted if the initial random
                       seed is known. And Randomize uses the system time to
                       initialize the random seed, which also makes it easy to
                       predict). If these risks cannot be tolerated, a different
                       sorting algorithm should be used.
}
{$ifdef FPC_HAS_FEATURE_RANDOM}
procedure RandomizedQuickSort_PtrList_NoContext(
                ItemPtrs: PPointer;
                ItemCount: SizeUInt;
                Comparer: TListSortComparer_NoContext);
procedure RandomizedQuickSort_PtrList_Context(
                ItemPtrs: PPointer;
                ItemCount: SizeUInt;
                Comparer: TListSortComparer_Context;
                Context: Pointer);
procedure RandomizedQuickSort_ItemList_Context(
                Items: Pointer;
                ItemCount, ItemSize: SizeUInt;
                Comparer: TListSortComparer_Context;
                Context: Pointer);
procedure RandomizedQuickSort_ItemList_CustomItemExchanger_Context(
                Items: Pointer;
                ItemCount, ItemSize: SizeUInt;
                Comparer: TListSortComparer_Context;
                Exchanger: TListSortCustomItemExchanger_Context;
                Context: Pointer);

const
  RandomizedQuickSort: TSortingAlgorithm = (
    PtrListSorter_NoContextComparer: @RandomizedQuickSort_PtrList_NoContext;
    PtrListSorter_ContextComparer: @RandomizedQuickSort_PtrList_Context;
    ItemListSorter_ContextComparer: @RandomizedQuickSort_ItemList_Context;
    ItemListSorter_CustomItemExchanger_ContextComparer: @RandomizedQuickSort_ItemList_CustomItemExchanger_Context;
  );
{$endif def FPC_HAS_FEATURE_RANDOM}

{
                       IntroSort

  Average performance: O(n log n)
    Worst performance: O(n log n)
     Extra memory use: O(log n) on the stack
               Stable: no
     Additional notes: Hybrid between QuickSort and HeapSort. It starts by doing
                       QuickSort, but switches to HeapSort if the recursion
                       depth exceeds 2*log2(n). This results in fast average
                       performance, similar to QuickSort, combined with a good
                       O(n log n) worst case performance, because sequences that
                       trigger QuickSort's worst case are caught and sorted by
                       HeapSort instead.
}
procedure IntroSort_PtrList_NoContext(
                ItemPtrs: PPointer;
                ItemCount: SizeUInt;
                Comparer: TListSortComparer_NoContext);
procedure IntroSort_PtrList_Context(
                ItemPtrs: PPointer;
                ItemCount: SizeUInt;
                Comparer: TListSortComparer_Context;
                Context: Pointer);
procedure IntroSort_ItemList_Context(
                Items: Pointer;
                ItemCount, ItemSize: SizeUInt;
                Comparer: TListSortComparer_Context;
                Context: Pointer);
procedure IntroSort_ItemList_CustomItemExchanger_Context(
                Items: Pointer;
                ItemCount, ItemSize: SizeUInt;
                Comparer: TListSortComparer_Context;
                Exchanger: TListSortCustomItemExchanger_Context;
                Context: Pointer);

const
  IntroSort: TSortingAlgorithm = (
    PtrListSorter_NoContextComparer: @IntroSort_PtrList_NoContext;
    PtrListSorter_ContextComparer: @IntroSort_PtrList_Context;
    ItemListSorter_ContextComparer: @IntroSort_ItemList_Context;
    ItemListSorter_CustomItemExchanger_ContextComparer: @IntroSort_ItemList_CustomItemExchanger_Context;
  );

implementation

{$GOTO on}

{*****************************************************************************
                                   HeapSort
*****************************************************************************}

function HeapSort_Parent(i: SizeUInt): SizeUInt; inline;
begin
  Result := (i - 1) div 2;
end;

function HeapSort_Left(i: SizeUInt): SizeUInt; inline;
begin
  Result := 2*i + 1;
end;

function HeapSort_Right(i: SizeUInt): SizeUInt; inline;
begin
  Result := 2*i + 2;
end;

procedure HeapSort_PtrList_NoContext(
                ItemPtrs: PPointer;
                ItemCount: SizeUInt;
                Comparer: TListSortComparer_NoContext);
var
  HeapSize: SizeUInt;

  procedure Heapify(I: SizeUInt);
  label
    again;
  var
    L, R, Largest: SizeUInt;
    Q: Pointer;
  begin
again:
    L := HeapSort_Left(I);
    R := HeapSort_Right(I);
    if (L < HeapSize) and (Comparer(ItemPtrs[L], ItemPtrs[I]) > 0) then
      Largest := L
    else
      Largest := I;
    if (R < HeapSize) and (Comparer(ItemPtrs[R], ItemPtrs[Largest]) > 0) then
      Largest := R;
    if Largest <> I then
    begin
      Q := ItemPtrs[I];
      ItemPtrs[I] := ItemPtrs[Largest];
      ItemPtrs[Largest] := Q;
      { we use goto instead of tail recursion }
      I := Largest;
      goto again;
    end;
  end;

var
  I: SizeUInt;
  Q: Pointer;
begin
  if not Assigned(ItemPtrs) or (ItemCount < 2) then
    exit;
  HeapSize := ItemCount;
  for I := HeapSort_Parent(ItemCount - 1) downto 0 do
    Heapify(I);
  for I := ItemCount - 1 downto 1 do
  begin
    Q := ItemPtrs[0];
    ItemPtrs[0] := ItemPtrs[I];
    ItemPtrs[I] := Q;
    Dec(HeapSize);
    Heapify(0);
  end;
end;

procedure HeapSort_PtrList_Context(
                ItemPtrs: PPointer;
                ItemCount: SizeUInt;
                Comparer: TListSortComparer_Context;
                Context: Pointer);
var
  HeapSize: SizeUInt;

  procedure Heapify(I: SizeUInt);
  label
    again;
  var
    L, R, Largest: SizeUInt;
    Q: Pointer;
  begin
again:
    L := HeapSort_Left(I);
    R := HeapSort_Right(I);
    if (L < HeapSize) and (Comparer(ItemPtrs[L], ItemPtrs[I], Context) > 0) then
      Largest := L
    else
      Largest := I;
    if (R < HeapSize) and (Comparer(ItemPtrs[R], ItemPtrs[Largest], Context) > 0) then
      Largest := R;
    if Largest <> I then
    begin
      Q := ItemPtrs[I];
      ItemPtrs[I] := ItemPtrs[Largest];
      ItemPtrs[Largest] := Q;
      { we use goto instead of tail recursion }
      I := Largest;
      goto again;
    end;
  end;

var
  I: SizeUInt;
  Q: Pointer;
begin
  if not Assigned(ItemPtrs) or (ItemCount < 2) then
    exit;
  HeapSize := ItemCount;
  for I := HeapSort_Parent(ItemCount - 1) downto 0 do
    Heapify(I);
  for I := ItemCount - 1 downto 1 do
  begin
    Q := ItemPtrs[0];
    ItemPtrs[0] := ItemPtrs[I];
    ItemPtrs[I] := Q;
    Dec(HeapSize);
    Heapify(0);
  end;
end;

procedure HeapSort_ItemList_Context(
                Items: Pointer;
                ItemCount, ItemSize: SizeUInt;
                Comparer: TListSortComparer_Context;
                Context: Pointer);
var
  HeapSize: SizeUInt;
  TempBuf: Pointer;

  procedure Heapify(I: SizeUInt);
  label
    again;
  var
    L, R, Largest: SizeUInt;
  begin
again:
    L := HeapSort_Left(I);
    R := HeapSort_Right(I);
    if (L < HeapSize) and (Comparer(Items + ItemSize*L, Items + ItemSize*I, Context) > 0) then
      Largest := L
    else
      Largest := I;
    if (R < HeapSize) and (Comparer(Items + ItemSize*R, Items + ItemSize*Largest, Context) > 0) then
      Largest := R;
    if Largest <> I then
    begin
      Move((Items + ItemSize*I)^, TempBuf^, ItemSize);
      Move((Items + ItemSize*Largest)^, (Items + ItemSize*I)^, ItemSize);
      Move(TempBuf^, (Items + ItemSize*Largest)^, ItemSize);
      { we use goto instead of tail recursion }
      I := Largest;
      goto again;
    end;
  end;

var
  I: SizeUInt;
begin
  if not Assigned(Items) or (ItemCount < 2) or (ItemSize < 1) then
    exit;

  GetMem(TempBuf, ItemSize);
  
{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
  try
{$endif FPC_HAS_FEATURE_EXCEPTIONS}
    HeapSize := ItemCount;
    for I := HeapSort_Parent(ItemCount - 1) downto 0 do
      Heapify(I);
    for I := ItemCount - 1 downto 1 do
    begin
      Move((Items + ItemSize*0)^, TempBuf^, ItemSize);
      Move((Items + ItemSize*I)^, (Items + ItemSize*0)^, ItemSize);
      Move(TempBuf^, (Items + ItemSize*I)^, ItemSize);
      Dec(HeapSize);
      Heapify(0);
    end;
{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
  finally
{$endif FPC_HAS_FEATURE_EXCEPTIONS}  
    FreeMem(TempBuf, ItemSize);
{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
  end;
{$endif FPC_HAS_FEATURE_EXCEPTIONS}
end;

procedure HeapSort_ItemList_CustomItemExchanger_Context(
                Items: Pointer;
                ItemCount, ItemSize: SizeUInt;
                Comparer: TListSortComparer_Context;
                Exchanger: TListSortCustomItemExchanger_Context;
                Context: Pointer);
var
  HeapSize: SizeUInt;

  procedure Heapify(I: SizeUInt);
  label
    again;
  var
    L, R, Largest: SizeUInt;
  begin
again:
    L := HeapSort_Left(I);
    R := HeapSort_Right(I);
    if (L < HeapSize) and (Comparer(Items + ItemSize*L, Items + ItemSize*I, Context) > 0) then
      Largest := L
    else
      Largest := I;
    if (R < HeapSize) and (Comparer(Items + ItemSize*R, Items + ItemSize*Largest, Context) > 0) then
      Largest := R;
    if Largest <> I then
    begin
      Exchanger(Items + ItemSize*I, Items + ItemSize*Largest, Context);
      { we use goto instead of tail recursion }
      I := Largest;
      goto again;
    end;
  end;

var
  I: SizeUInt;
begin
  if not Assigned(Items) or (ItemCount < 2) or (ItemSize < 1) then
    exit;

  HeapSize := ItemCount;
  for I := HeapSort_Parent(ItemCount - 1) downto 0 do
    Heapify(I);
  for I := ItemCount - 1 downto 1 do
  begin
    Exchanger(Items + ItemSize*0, Items + ItemSize*I, Context);
    Dec(HeapSize);
    Heapify(0);
  end;
end;

{*****************************************************************************
                            Randomized QuickSort
*****************************************************************************}
{$ifdef FPC_HAS_FEATURE_RANDOM}

function Random_SizeUInt(L: SizeUInt): SizeUInt;
begin
{$if sizeof(SizeUInt)=2}
  Result := Random(LongInt(L));
{$elseif sizeof(SizeUInt)=4}
  Result := Random(Int64(L));
{$elseif sizeof(SizeUInt)=8}
  Result := Random(Int64($100000000));
  Result := Result or (SizeUInt(Random(Int64($100000000))) shl 32);
  if L <> 0 then
    Result := Result mod L
  else
    Result := 0;
{$else}
  {$fatal Unexpected size of SizeUInt}
{$endif}
end;

procedure RandomizedQuickSort_PtrList_NoContext(ItemPtrs: PPointer; L, R : SizeUInt;
                                                Comparer: TListSortComparer_NoContext);
var
  I, J, PivotIdx : SizeUInt;
  P, Q : Pointer;
begin
 repeat
   I := L;
   J := R;
   PivotIdx := L + Random_SizeUInt(SizeUInt(R - L));
   P := ItemPtrs[PivotIdx];
   repeat
     while (I < PivotIdx) and (Comparer(P, ItemPtrs[i]) > 0) do
       Inc(I);
     while (J > PivotIdx) and (Comparer(P, ItemPtrs[J]) < 0) do
       Dec(J);
     if I < J then
     begin
       Q := ItemPtrs[I];
       ItemPtrs[I] := ItemPtrs[J];
       ItemPtrs[J] := Q;
       if PivotIdx = I then
       begin
         PivotIdx := J;
         Inc(I);
       end
       else if PivotIdx = J then
       begin
         PivotIdx := I;
         Dec(J);
       end
       else
       begin
         Inc(I);
         Dec(J);
       end;
     end;
   until I >= J;
   // sort the smaller range recursively
   // sort the bigger range via the loop
   // Reasons: memory usage is O(log(n)) instead of O(n) and loop is faster than recursion
   if (PivotIdx - L) < (R - PivotIdx) then
   begin
     if (L + 1) < PivotIdx then
       RandomizedQuickSort_PtrList_NoContext(ItemPtrs, L, PivotIdx - 1, Comparer);
     L := PivotIdx + 1;
   end
   else
   begin
     if (PivotIdx + 1) < R then
       RandomizedQuickSort_PtrList_NoContext(ItemPtrs, PivotIdx + 1, R, Comparer);
     if (L + 1) < PivotIdx then
       R := PivotIdx - 1
     else
       exit;
   end;
 until L >= R;
end;

procedure RandomizedQuickSort_PtrList_NoContext(ItemPtrs: PPointer; ItemCount: SizeUInt; Comparer: TListSortComparer_NoContext);
begin
  if not Assigned(ItemPtrs) or (ItemCount < 2) then
    exit;
  RandomizedQuickSort_PtrList_NoContext(ItemPtrs, 0, ItemCount - 1, Comparer);
end;

procedure RandomizedQuickSort_PtrList_Context(ItemPtrs: PPointer; ItemCount: SizeUInt; Comparer: TListSortComparer_Context; Context: Pointer);

  procedure QuickSort(L, R : SizeUInt);
  var
    I, J, PivotIdx : SizeUInt;
    P, Q : Pointer;
  begin
    repeat
      I := L;
      J := R;
      PivotIdx := L + Random_SizeUInt(SizeUInt(R - L));
      P := ItemPtrs[PivotIdx];
      repeat
        while (I < PivotIdx) and (Comparer(P, ItemPtrs[I], Context) > 0) do
          Inc(I);
        while (J > PivotIdx) and (Comparer(P, ItemPtrs[J], Context) < 0) do
          Dec(J);
        if I < J then
        begin
          Q := ItemPtrs[I];
          ItemPtrs[I] := ItemPtrs[J];
          ItemPtrs[J] := Q;
          if PivotIdx = I then
          begin
            PivotIdx := J;
            Inc(I);
          end
          else if PivotIdx = J then
          begin
            PivotIdx := I;
            Dec(J);
          end
          else
          begin
            Inc(I);
            Dec(J);
          end;
        end;
      until I >= J;
      // sort the smaller range recursively
      // sort the bigger range via the loop
      // Reasons: memory usage is O(log(n)) instead of O(n) and loop is faster than recursion
      if (PivotIdx - L) < (R - PivotIdx) then
      begin
        if (L + 1) < PivotIdx then
          QuickSort(L, PivotIdx - 1);
        L := PivotIdx + 1;
      end
      else
      begin
        if (PivotIdx + 1) < R then
          QuickSort(PivotIdx + 1, R);
        if (L + 1) < PivotIdx then
          R := PivotIdx - 1
        else
          exit;
      end;
    until L >= R;
  end;

begin
  if not Assigned(ItemPtrs) or (ItemCount < 2) then
    exit;
  QuickSort(0, ItemCount - 1);
end;

procedure RandomizedQuickSort_ItemList_Context(Items: Pointer; ItemCount, ItemSize: SizeUInt; Comparer: TListSortComparer_Context; Context: Pointer);

var
  TempBuf: Pointer;

  procedure QuickSort(L, R : SizeUInt);
  var
    I, J, PivotIdx : SizeUInt;
    P : Pointer;
  begin
    repeat
      I := L;
      J := R;
      PivotIdx := L + Random_SizeUInt(SizeUInt(R - L));
      P := Items + ItemSize*PivotIdx;
      repeat
        while (I < PivotIdx) and (Comparer(P, Items + ItemSize*I, Context) > 0) do
          Inc(I);
        while (J > PivotIdx) and (Comparer(P, Items + ItemSize*J, Context) < 0) do
          Dec(J);
        if I < J then
        begin
          Move((Items + ItemSize*I)^, TempBuf^, ItemSize);
          Move((Items + ItemSize*J)^, (Items + ItemSize*I)^, ItemSize);
          Move(TempBuf^, (Items + ItemSize*J)^, ItemSize);
          if PivotIdx = I then
          begin
            PivotIdx := J;
            P := Items + ItemSize*PivotIdx;
            Inc(I);
          end
          else if PivotIdx = J then
          begin
            PivotIdx := I;
            P := Items + ItemSize*PivotIdx;
            Dec(J);
          end
          else
          begin
            Inc(I);
            Dec(J);
          end;
        end;
      until I >= J;
      // sort the smaller range recursively
      // sort the bigger range via the loop
      // Reasons: memory usage is O(log(n)) instead of O(n) and loop is faster than recursion
      if (PivotIdx - L) < (R - PivotIdx) then
      begin
        if (L + 1) < PivotIdx then
          QuickSort(L, PivotIdx - 1);
        L := PivotIdx + 1;
      end
      else
      begin
        if (PivotIdx + 1) < R then
          QuickSort(PivotIdx + 1, R);
        if (L + 1) < PivotIdx then
          R := PivotIdx - 1
        else
          exit;
      end;
    until L >= R;
  end;

begin
  if not Assigned(Items) or (ItemCount < 2) or (ItemSize < 1) then
    exit;
  GetMem(TempBuf, ItemSize);
  try
    QuickSort(0, ItemCount - 1);
  finally
    FreeMem(TempBuf, ItemSize);
  end;
end;

procedure RandomizedQuickSort_ItemList_CustomItemExchanger_Context(
                Items: Pointer;
                ItemCount, ItemSize: SizeUInt;
                Comparer: TListSortComparer_Context;
                Exchanger: TListSortCustomItemExchanger_Context;
                Context: Pointer);

  procedure QuickSort(L, R : SizeUInt);
  var
    I, J, PivotIdx : SizeUInt;
    P : Pointer;
  begin
    repeat
      I := L;
      J := R;
      PivotIdx := L + Random_SizeUInt(SizeUInt(R - L));
      P := Items + ItemSize*PivotIdx;
      repeat
        while (I < PivotIdx) and (Comparer(P, Items + ItemSize*I, Context) > 0) do
          Inc(I);
        while (J > PivotIdx) and (Comparer(P, Items + ItemSize*J, Context) < 0) do
          Dec(J);
        if I < J then
        begin
          Exchanger(Items + ItemSize*I, Items + ItemSize*J, Context);
          if PivotIdx = I then
          begin
            PivotIdx := J;
            P := Items + ItemSize*PivotIdx;
            Inc(I);
          end
          else if PivotIdx = J then
          begin
            PivotIdx := I;
            P := Items + ItemSize*PivotIdx;
            Dec(J);
          end
          else
          begin
            Inc(I);
            Dec(J);
          end;
        end;
      until I >= J;
      // sort the smaller range recursively
      // sort the bigger range via the loop
      // Reasons: memory usage is O(log(n)) instead of O(n) and loop is faster than recursion
      if (PivotIdx - L) < (R - PivotIdx) then
      begin
        if (L + 1) < PivotIdx then
          QuickSort(L, PivotIdx - 1);
        L := PivotIdx + 1;
      end
      else
      begin
        if (PivotIdx + 1) < R then
          QuickSort(PivotIdx + 1, R);
        if (L + 1) < PivotIdx then
          R := PivotIdx - 1
        else
          exit;
      end;
    until L >= R;
  end;

begin
  if not Assigned(Items) or (ItemCount < 2) or (ItemSize < 1) then
    exit;
  QuickSort(0, ItemCount - 1);
end;
{$endif def FPC_HAS_FEATURE_RANDOM}

{*****************************************************************************
                                   IntroSort
*****************************************************************************}

function IntLog2(a: Word): Integer; inline;
begin
  Result := BsrWord(a);
end;
function IntLog2(a: LongWord): Integer; inline;
begin
  Result := BsrDWord(a);
end;
function IntLog2(a: QWord): Integer; inline;
begin
  Result := BsrQWord(a);
end;

procedure IntroSort_PtrList_NoContext(ItemPtrs: PPointer; L, R : SizeUInt;
                                      Comparer: TListSortComparer_NoContext;
                                      MaxDepth: Integer);
var
  I, J, PivotIdx : SizeUInt;
  P, Q : Pointer;
begin
 repeat
   if MaxDepth > 0 then
     Dec(MaxDepth)
   else
   begin
     HeapSort_PtrList_NoContext(@ItemPtrs[L], (R - L) + 1, Comparer);
     exit;
   end;
   I := L;
   J := R;
   PivotIdx := L + ((R - L) shr 1); { same as ((L + R) div 2), but without the possibility of overflow }
   P := ItemPtrs[PivotIdx];
   repeat
     while (I < PivotIdx) and (Comparer(P, ItemPtrs[i]) > 0) do
       Inc(I);
     while (J > PivotIdx) and (Comparer(P, ItemPtrs[J]) < 0) do
       Dec(J);
     if I < J then
     begin
       Q := ItemPtrs[I];
       ItemPtrs[I] := ItemPtrs[J];
       ItemPtrs[J] := Q;
       if PivotIdx = I then
       begin
         PivotIdx := J;
         Inc(I);
       end
       else if PivotIdx = J then
       begin
         PivotIdx := I;
         Dec(J);
       end
       else
       begin
         Inc(I);
         Dec(J);
       end;
     end;
   until I >= J;
   // sort the smaller range recursively
   // sort the bigger range via the loop
   // Reasons: memory usage is O(log(n)) instead of O(n) and loop is faster than recursion
   if (PivotIdx - L) < (R - PivotIdx) then
   begin
     if (L + 1) < PivotIdx then
       IntroSort_PtrList_NoContext(ItemPtrs, L, PivotIdx - 1, Comparer, MaxDepth);
     L := PivotIdx + 1;
   end
   else
   begin
     if (PivotIdx + 1) < R then
       IntroSort_PtrList_NoContext(ItemPtrs, PivotIdx + 1, R, Comparer, MaxDepth);
     if (L + 1) < PivotIdx then
       R := PivotIdx - 1
     else
       exit;
   end;
 until L >= R;
end;

procedure IntroSort_PtrList_NoContext(ItemPtrs: PPointer; ItemCount: SizeUInt; Comparer: TListSortComparer_NoContext);
begin
  if not Assigned(ItemPtrs) or (ItemCount < 2) then
    exit;
  IntroSort_PtrList_NoContext(ItemPtrs, 0, ItemCount - 1, Comparer, 2*IntLog2(ItemCount));
end;

procedure IntroSort_PtrList_Context(ItemPtrs: PPointer; ItemCount: SizeUInt; Comparer: TListSortComparer_Context; Context: Pointer);

  procedure IntroSort(L, R : SizeUInt; MaxDepth: Integer);
  var
    I, J, PivotIdx : SizeUInt;
    P, Q : Pointer;
  begin
    repeat
      if MaxDepth > 0 then
        Dec(MaxDepth)
      else
      begin
        HeapSort_PtrList_Context(@ItemPtrs[L], (R - L) + 1, Comparer, Context);
        exit;
      end;
      I := L;
      J := R;
      PivotIdx := L + ((R - L) shr 1); { same as ((L + R) div 2), but without the possibility of overflow }
      P := ItemPtrs[PivotIdx];
      repeat
        while (I < PivotIdx) and (Comparer(P, ItemPtrs[I], Context) > 0) do
          Inc(I);
        while (J > PivotIdx) and (Comparer(P, ItemPtrs[J], Context) < 0) do
          Dec(J);
        if I < J then
        begin
          Q := ItemPtrs[I];
          ItemPtrs[I] := ItemPtrs[J];
          ItemPtrs[J] := Q;
          if PivotIdx = I then
          begin
            PivotIdx := J;
            Inc(I);
          end
          else if PivotIdx = J then
          begin
            PivotIdx := I;
            Dec(J);
          end
          else
          begin
            Inc(I);
            Dec(J);
          end;
        end;
      until I >= J;
      // sort the smaller range recursively
      // sort the bigger range via the loop
      // Reasons: memory usage is O(log(n)) instead of O(n) and loop is faster than recursion
      if (PivotIdx - L) < (R - PivotIdx) then
      begin
        if (L + 1) < PivotIdx then
          IntroSort(L, PivotIdx - 1, MaxDepth);
        L := PivotIdx + 1;
      end
      else
      begin
        if (PivotIdx + 1) < R then
          IntroSort(PivotIdx + 1, R, MaxDepth);
        if (L + 1) < PivotIdx then
          R := PivotIdx - 1
        else
          exit;
      end;
    until L >= R;
  end;

begin
  if not Assigned(ItemPtrs) or (ItemCount < 2) then
    exit;
  IntroSort(0, ItemCount - 1, 2*IntLog2(ItemCount));
end;

procedure IntroSort_ItemList_Context(Items: Pointer; ItemCount, ItemSize: SizeUInt; Comparer: TListSortComparer_Context; Context: Pointer);

var
  TempBuf: Pointer;

  procedure IntroSort(L, R : SizeUInt; MaxDepth: Integer);
  var
    I, J, PivotIdx : SizeUInt;
    P : Pointer;
  begin
    repeat
      if MaxDepth > 0 then
        Dec(MaxDepth)
      else
      begin
        HeapSort_ItemList_Context(Items + ItemSize*L, (R - L) + 1, ItemSize, Comparer, Context);
        exit;
      end;
      I := L;
      J := R;
      PivotIdx := L + ((R - L) shr 1); { same as ((L + R) div 2), but without the possibility of overflow }
      P := Items + ItemSize*PivotIdx;
      repeat
        while (I < PivotIdx) and (Comparer(P, Items + ItemSize*I, Context) > 0) do
          Inc(I);
        while (J > PivotIdx) and (Comparer(P, Items + ItemSize*J, Context) < 0) do
          Dec(J);
        if I < J then
        begin
          Move((Items + ItemSize*I)^, TempBuf^, ItemSize);
          Move((Items + ItemSize*J)^, (Items + ItemSize*I)^, ItemSize);
          Move(TempBuf^, (Items + ItemSize*J)^, ItemSize);
          if PivotIdx = I then
          begin
            PivotIdx := J;
            P := Items + ItemSize*PivotIdx;
            Inc(I);
          end
          else if PivotIdx = J then
          begin
            PivotIdx := I;
            P := Items + ItemSize*PivotIdx;
            Dec(J);
          end
          else
          begin
            Inc(I);
            Dec(J);
          end;
        end;
      until I >= J;
      // sort the smaller range recursively
      // sort the bigger range via the loop
      // Reasons: memory usage is O(log(n)) instead of O(n) and loop is faster than recursion
      if (PivotIdx - L) < (R - PivotIdx) then
      begin
        if (L + 1) < PivotIdx then
          IntroSort(L, PivotIdx - 1, MaxDepth);
        L := PivotIdx + 1;
      end
      else
      begin
        if (PivotIdx + 1) < R then
          IntroSort(PivotIdx + 1, R, MaxDepth);
        if (L + 1) < PivotIdx then
          R := PivotIdx - 1
        else
          exit;
      end;
    until L >= R;
  end;

begin
  if not Assigned(Items) or (ItemCount < 2) or (ItemSize < 1) then
    exit;
  GetMem(TempBuf, ItemSize);
{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
  try
    IntroSort(0, ItemCount - 1, 2*IntLog2(ItemCount));
  finally
    FreeMem(TempBuf, ItemSize);
  end;
{$else FPC_HAS_FEATURE_EXCEPTIONS}
  IntroSort(0, ItemCount - 1, 2*IntLog2(ItemCount));
  FreeMem(TempBuf, ItemSize);
{$endif FPC_HAS_FEATURE_EXCEPTIONS}
end;

procedure IntroSort_ItemList_CustomItemExchanger_Context(
                Items: Pointer;
                ItemCount, ItemSize: SizeUInt;
                Comparer: TListSortComparer_Context;
                Exchanger: TListSortCustomItemExchanger_Context;
                Context: Pointer);

  procedure IntroSort(L, R : SizeUInt; MaxDepth: Integer);
  var
    I, J, PivotIdx : SizeUInt;
    P : Pointer;
  begin
    repeat
      if MaxDepth > 0 then
        Dec(MaxDepth)
      else
      begin
        HeapSort_ItemList_CustomItemExchanger_Context(Items + ItemSize*L, (R - L) + 1, ItemSize, Comparer, Exchanger, Context);
        exit;
      end;
      I := L;
      J := R;
      PivotIdx := L + ((R - L) shr 1); { same as ((L + R) div 2), but without the possibility of overflow }
      P := Items + ItemSize*PivotIdx;
      repeat
        while (I < PivotIdx) and (Comparer(P, Items + ItemSize*I, Context) > 0) do
          Inc(I);
        while (J > PivotIdx) and (Comparer(P, Items + ItemSize*J, Context) < 0) do
          Dec(J);
        if I < J then
        begin
          Exchanger(Items + ItemSize*I, Items + ItemSize*J, Context);
          if PivotIdx = I then
          begin
            PivotIdx := J;
            P := Items + ItemSize*PivotIdx;
            Inc(I);
          end
          else if PivotIdx = J then
          begin
            PivotIdx := I;
            P := Items + ItemSize*PivotIdx;
            Dec(J);
          end
          else
          begin
            Inc(I);
            Dec(J);
          end;
        end;
      until I >= J;
      // sort the smaller range recursively
      // sort the bigger range via the loop
      // Reasons: memory usage is O(log(n)) instead of O(n) and loop is faster than recursion
      if (PivotIdx - L) < (R - PivotIdx) then
      begin
        if (L + 1) < PivotIdx then
          IntroSort(L, PivotIdx - 1, MaxDepth);
        L := PivotIdx + 1;
      end
      else
      begin
        if (PivotIdx + 1) < R then
          IntroSort(PivotIdx + 1, R, MaxDepth);
        if (L + 1) < PivotIdx then
          R := PivotIdx - 1
        else
          exit;
      end;
    until L >= R;
  end;

begin
  if not Assigned(Items) or (ItemCount < 2) or (ItemSize < 1) then
    exit;
  IntroSort(0, ItemCount - 1, 2*IntLog2(ItemCount));
end;

end.