Array sort

unit anysort;
 
{$ifdef fpc}{$mode delphi}{$H+}{$endif}
 
interface
 
type
  TCompareFunc = function (const elem1, elem2): Integer;
 
procedure AnySort(var Arr; Count: Integer; Stride: Integer; CompareFunc: TCompareFunc);
 
implementation
 
type
  TByteArray = array [Word] of byte;
  PByteArray = ^TByteArray;
 
procedure AnyQuickSort(var Arr; idxL, idxH: Integer;
  Stride: Integer; CompareFunc: TCompareFunc; var SwapBuf, MedBuf);
var
  ls,hs : Integer;
  li,hi : Integer;
  mi    : Integer;
  ms    : Integer;
  pb    : PByteArray;
begin
  pb:=@Arr;
  li:=idxL;
  hi:=idxH;
  mi:=(li+hi) div 2;
  ls:=li*Stride;
  hs:=hi*Stride;
  ms:=mi*Stride;
  Move(pb[ms], medBuf, Stride);
  repeat
    while CompareFunc( pb[ls], medBuf) < 0 do begin
      inc(ls, Stride);
      inc(li);
    end;
    while CompareFunc( medBuf, pb[hs] ) < 0 do begin
      dec(hs, Stride);
      dec(hi);
    end;
    if ls <= hs then begin
      Move(pb[ls], SwapBuf, Stride);
      Move(pb[hs], pb[ls], Stride);
      Move(SwapBuf, pb[hs], Stride);
      // begin fix 11/11/2021: update ms if the reference point is moved
      if li=mi then ms:=hs;
      if hi=mi then ms:=ls;
      // end fix
      inc(ls, Stride); inc(li);
      dec(hs, Stride); dec(hi);
    end;
  until ls>hs;
  if hi>idxL then AnyQuickSort(Arr, idxL, hi, Stride, CompareFunc, SwapBuf, MedBuf);
  if li<idxH then AnyQuickSort(Arr, li, idxH, Stride, CompareFunc, SwapBuf, MedBuf);
end;
 
procedure AnySort(var Arr; Count: Integer; Stride: Integer; CompareFunc: TCompareFunc);
var
  buf: array of byte;
begin
  if Count <= 1 then Exit; // should be more than 1 to be sortable
  SetLength(buf, Stride*2);
  AnyQuickSort(Arr, 0, Count-1, Stride, compareFunc, buf[0], buf[Stride]);
end;
 
end.

interface

uses AnySort;

procedure SortArrayInteger(var arr: array of Integer; count: Integer);

implementation
 
function CompareInt(const d1,d2): integer;
var
  i1 : integer absolute d1;
  i2 : integer absolute d2;
begin
  if i1=i2 then Result:=0
  else if i1<i2 then Result:=-1
  else Result:=1;
end;

procedure SortArrayInteger(var arr: array of Integer; count: Integer);
begin
  anysort.AnySort(arr, Count, sizeof(Integer), @CompareInt);
end;

{$mode objfpc} {$coperators on}
unit AnySort2;

interface

type
    // Comparer should provide function Less(const a, b: Elem): boolean.
    generic Sorter<Elem, Comparer> = class
    type
        pElem = ^Elem;

        class procedure Sort(p: pElem; count: SizeUint); static;
        class procedure Sort(var a: array of Elem); static;

    private const
        SelectionThreshold = 12;
        HeapArity = 4;
    type
        SwapTemp = array[0 .. sizeof(Elem) - 1] of byte;

        class procedure SelectionSort(p: pElem; count: SizeUint); static;

        class function Median(p: pElem; count: SizeUint): pElem; static;
        class procedure QSort(p: pElem; count, reasonable: SizeUint); static;

        class procedure HeapReplacePessimistic(p: pElem; count, id: SizeUint; const x: SwapTemp); static;
        class procedure HeapSort(p: pElem; count: SizeUint); static;
    end;

    generic ComparerLessOp<Elem> = class
        class function Less(const a, b: Elem): boolean; static; inline;
    end;

    generic SorterLessOp<Elem> = class(specialize Sorter<Elem, specialize ComparerLessOp<Elem>>) end;

implementation

    class procedure Sorter.Sort(p: pElem; count: SizeUint);
    begin
        QSort(p, count, count);
    end;

    class procedure Sorter.Sort(var a: array of Elem);
    begin
        Sort(pElem(a), length(a));
    end;

    class procedure Sorter.SelectionSort(p: pElem; count: SizeUint);
    var
        i, j, imin: SizeInt;
        t: SwapTemp;
    begin
        for i := 0 to SizeInt(count) - 2 do
        begin
            imin := i;
            for j := i + 1 to SizeInt(count) - 1 do
                if Comparer.Less(p[j], p[imin]) then imin := j;
            t := SwapTemp(p[i]); SwapTemp(p[i]) := SwapTemp(p[imin]); SwapTemp(p[imin]) := t;
        end;
    end;

    class function Sorter.Median(p: pElem; count: SizeUint): pElem;
    var
        a, b, c, t: pElem;
    begin
        a := p;
        b := p + count div 2;
        c := p + SizeUint(count - 1);
        if Comparer.Less(b^, a^) then begin t := a; a := b; b := t; end;
        if Comparer.Less(c^, b^) then begin t := c; c := b; b := t; end;
        if Comparer.Less(b^, a^) then result := a else result := b;
    end;

    // see MSVC implementation of std::sort
    class procedure Sorter.QSort(p: pElem; count, reasonable: SizeUint);
    var
        L, R: SizeInt;
        t, pivot: SwapTemp;
    begin
        while (count > SelectionThreshold) and (reasonable > 0) do
        begin
            reasonable := reasonable div 2 + reasonable div 4;

            pivot := SwapTemp(Median(p, count)^);
            R := 0;
            L := count - 1;

            repeat
                while Comparer.Less(p[R], Elem(pivot)) do inc(R);
                while Comparer.Less(Elem(pivot), p[L]) do dec(L);
                if R <= L then
                begin
                    t := SwapTemp(p[R]); SwapTemp(p[R]) := SwapTemp(p[L]); SwapTemp(p[L]) := t;
                    inc(R);
                    dec(L);
                end;
            until R > L;

            // [0 .. L], [R .. count - 1]
            // possible edge cases are L = -1 or R = count !
            if SizeInt(count) - R <= L then
            begin
                QSort(p + R, SizeInt(count) - R, reasonable); // QSort calls with count = 0 or count = 1 are safe.
                count := L + 1;
            end else
            begin
                QSort(p, L + 1, reasonable);
                p += R;
                count -= R;
            end;
        end;
        if count > SelectionThreshold then
            HeapSort(p, count)
        else if count >= 2 then
            SelectionSort(p, count);
    end;

    // HeapReplacePessimistic(p, count, id, x)
    //
    // is equivalent to
    //
    // p[id] := x;
    // id := HeapDownThoroughly(..., id);
    // HeapUp(..., id)
    //
    // where HeapDownThoroughly doesn't stop at correct position, instead shifting the element all the way down, saving one compare at each level.
    // HeapUp then bubbles the element up to the correct position.
    // See Python's 'heapq' for justification over simple HeapDown.
    //
    // Careful with 'x' passed by reference and pointing into 'p'!

    class procedure Sorter.HeapReplacePessimistic(p: pElem; count, id: SizeUint; const x: SwapTemp);
    var
        child, bestChild, lastChild, parent, start: SizeUint;
    begin
        start := id;
        repeat
            child := HeapArity * id; // childs of 'id' are p[child + 1] ... p[child + HeapArity].
            bestChild := child + 1;
            if bestChild >= count then break;

            lastChild := child + HeapArity;
            if lastChild >= count then lastChild := count - 1;

            for child := child + 2 to lastChild do
                if Comparer.Less(p[bestChild], p[child]) then bestChild := child;

            SwapTemp(p[id]) := SwapTemp(p[bestChild]);
            id := bestChild;
        until false;

        while id > start do
        begin
            parent := (id - 1) div HeapArity;
            if not Comparer.Less(p[parent], Elem(x)) then break;
            SwapTemp(p[id]) := SwapTemp(p[parent]);
            id := parent;
        end;
        SwapTemp(p[id]) := x;
    end;

    class procedure Sorter.HeapSort(p: pElem; count: SizeUint);
    var
        i: SizeInt;
        t: SwapTemp;
    begin
        for i := SizeInt((count + (HeapArity - 2)) div HeapArity) - 1 downto 0 do
        begin
            t := SwapTemp(p[i]);
            HeapReplacePessimistic(p, count, i, t);
        end;
        for i := SizeInt(count) - 1 downto 1 do
        begin
            t := SwapTemp(p[i]);
            SwapTemp(p[i]) := SwapTemp(p[0]);
            HeapReplacePessimistic(p, i, 0, t);
        end;
    end;

    class function ComparerLessOp.Less(const a, b: Elem): boolean;
    begin
        result := a < b;
    end;

end.

{$mode objfpc}
uses AnySort2;

var
    a: array of integer;

begin
    a := specialize TArray<integer>.Create(111, 555, 888, 777, 333, 444, 666);
    specialize SorterLessOp<integer>.Sort(a);
end.