{*******************************************************}
{                                                       }
{              FastCube 2 Sort Utils unit               }
{                                                       }
{               Copyright (c) 2001-2016                 }
{           by Oleg Pryalkov, Paul Ishenin              }
{                  Fast Reports Inc.                    }
{*******************************************************}

//VCL uses section
{$IFNDEF FMX}
unit fcxSort;
{$INCLUDE fcx.inc}

interface
uses
  Classes, SysUtils,
{$IFDEF FPC}
  LCLType,
{$ELSE}
  Windows,
{$ENDIF}
  fcxTypes, fcxUniqueArray, fcxUniqueValue;
//FMX uses
{$ELSE FMX}
{$INCLUDE fcx.inc}

interface
uses
  System.Classes, System.SysUtils,
  FMX.fcxTypes, FMX.fcxUniqueArray, FMX.fcxUniqueValue;
{$ENDIF FMX}

Type
  TfcxCompareFunc =  function(const AValue1, AValue2: Pointer): Integer of Object;

procedure SortUniqueList(AStart, AEnd: integer; AList: PfcxCUVArray; ACompare: TfcxCompareFunc; ANullValue: PfcxCommonUV; AExtraList: PfcxArrPointerArray; AExtraCount: integer; AOrderIndex: integer);
//procedure SortStringUniqueList(AStart, AEnd: integer; AList: PfcxCUVArray; AExtraList: PfcxPointerArray);
//procedure SortStringUniqueList(AStart, AEnd: integer; AList: PfcxPointerArray; ASplitList: PfcxArrPointerArray; AIndexOrderField: integer);
//procedure SortUniqueList(AStart, AEnd: integer; AList: PfcxPointerArray; ASplitList: PfcxArrPointerArray; ACompare: TfcxCompareFunc; AIndexOrderField: integer);

implementation

procedure SortUniqueList(AStart, AEnd: integer; AList: PfcxCUVArray; ACompare: TfcxCompareFunc; ANullValue: PfcxCommonUV; AExtraList: PfcxArrPointerArray; AExtraCount: integer; AOrderIndex: integer);
var  x1s: PfcxPointerArray;
  procedure QuickSortOL(L, R: Integer);
  var
    i, j, p: integer;
    v, b: PfcxCommonUV;

    procedure Insert(const l1, n1: integer);
    var
      i1, j1, v1: integer;
      x1: PfcxCommonUV;

    begin
      for i1 := l1 + 1 to n1 do
      begin
        x1 := AList[i1];
        v1 := l1;
        for j1 := i1 - 1 downto l1 do
        begin
          if ACompare(AList[j1], x1) <= 0 then
          begin
            v1 := j1 + 1;
            break;
          end;
          AList[j1 + 1] := AList[j1];

        end;
        AList[v1] := x1;
      end;
    end;

  begin
    while (l < r) do
    begin
      if r - l <= 12 then
      begin
        Insert(l, r);
        exit;
      end;

      p := (l + r) shr 1;
      V := AList[p];

      AList[p] := AList[l];

      i := succ(l);
      j := r;
      while true do
      begin
        while (i < j) and (ACompare(v, AList[i]) > 0) do
          inc(i);
        while (j >= i) and (ACompare(AList[j], v) > 0) do
          dec(j);
        if (i >= j) then
          break;
        b := AList[i];

        AList[i] := AList[j];
        AList[j] := b;


        dec(j);
        inc(i);
      end;
      AList[l] := AList[j];
      AList[j] := v;


      if ((j - l) <= (r - j)) then
      begin
        QuickSortOL(l, j - 1);
        l := succ(j);
      end
      else
      begin
        QuickSortOL(j + 1, r);
        r := pred(J);
      end;
    end;
  end;
  procedure QuickSortOLWithExtraList(L, R: Integer);
  var
    i, j, p, AExtraIndex: integer;
    v, b: PfcxCommonUV;
    bs: Pointer;
    procedure Insert(const l1, n1: integer);
    var
      i1, j1, v1, AExtraIndex: integer;
      x1: PfcxCommonUV;
    begin
      for i1 := l1 + 1 to n1 do
      begin
        x1 := AList[i1];
        v1 := l1;
        for AExtraIndex := 0 to AExtraCount - 1 do
          x1s[AExtraIndex] := AExtraList[AExtraIndex][i1];
        for j1 := i1 - 1 downto l1 do
        begin
          if ACompare(AList[j1], x1) <= 0 then
          begin
            v1 := j1 + 1;
            break;
          end;
          AList[j1 + 1] := AList[j1];
          for AExtraIndex := 0 to AExtraCount - 1 do
            AExtraList[AExtraIndex][j1 + 1] := AExtraList[AExtraIndex][j1];
        end;
        AList[v1] := x1;
        for AExtraIndex := 0 to AExtraCount - 1 do
          AExtraList[AExtraIndex][v1] := x1s[AExtraIndex];
      end;
    end;

  begin
    while (l < r) do
    begin
      if r - l <= 12 then
      begin
        Insert(l, r);
        exit;
      end;

      p := (l + r) shr 1;
      V := AList[p];
      AList[p] := AList[l];
      for AExtraIndex := 0 to AExtraCount - 1 do
      begin
        x1s[AExtraIndex] := AExtraList[AExtraIndex][p];
//      Vs := AExtraList[p];
        AExtraList[AExtraIndex][p] := AExtraList[AExtraIndex][l];
      end;

      i := succ(l);
      j := r;
      while true do
      begin
        while (i < j) and (ACompare(v, AList[i]) > 0) do
          inc(i);
        while (j >= i) and (ACompare(AList[j], v) > 0) do
          dec(j);
        if (i >= j) then
          break;
        b := AList[i];
        AList[i] := AList[j];
        AList[j] := b;
        for AExtraIndex := 0 to AExtraCount - 1 do
        begin
          bs := AExtraList[AExtraIndex][i];
          AExtraList[AExtraIndex][i] := AExtraList[AExtraIndex][j];
          AExtraList[AExtraIndex][j] := bs;
        end;
        dec(j);
        inc(i);
      end;
      AList[l] := AList[j];
      AList[j] := v;
      for AExtraIndex := 0 to AExtraCount - 1 do
      begin
        AExtraList[AExtraIndex][l] := AExtraList[AExtraIndex][j];
        AExtraList[AExtraIndex][j] := x1s[AExtraIndex];//vs;
      end;
      if ((j - l) <= (r - j)) then
      begin
        QuickSortOLWithExtraList(l, j - 1);
        l := succ(j);
      end
      else
      begin
        QuickSortOLWithExtraList(j + 1, r);
        r := pred(J);
      end;
    end;
  end;

  procedure QuickSortOLWithExtraListWithOrder(L, R: Integer);
  var
    i, j, p, AExtraIndex: integer;
    v, b: PfcxCommonUV;
    bs: Pointer;
    procedure Insert(const l1, n1: integer);
    var
      i1, j1, v1, AExtraIndex: integer;
      x1: PfcxCommonUV;
    begin
      for i1 := l1 + 1 to n1 do
      begin
        x1 := AList[i1];
        v1 := l1;
        for AExtraIndex := 0 to AExtraCount - 1 do
          x1s[AExtraIndex] := AExtraList[AExtraIndex][i1];
        for j1 := i1 - 1 downto l1 do
        begin
//          if ACompare(AList[j1], x1) <= 0 then
          if fcxIntCompare(PfcxCommonUV(AExtraList[AOrderIndex][j1]).Index, PfcxCommonUV(x1s[AOrderIndex]).Index) <= 0 then
          begin
            v1 := j1 + 1;
            break;
          end;
          AList[j1 + 1] := AList[j1];
          for AExtraIndex := 0 to AExtraCount - 1 do
            AExtraList[AExtraIndex][j1 + 1] := AExtraList[AExtraIndex][j1];
        end;
        AList[v1] := x1;
        for AExtraIndex := 0 to AExtraCount - 1 do
          AExtraList[AExtraIndex][v1] := x1s[AExtraIndex];
      end;
    end;

  begin
    while (l < r) do
    begin
      if r - l <= 12 then
      begin
        Insert(l, r);
        exit;
      end;

      p := (l + r) shr 1;
      V := AList[p];
      AList[p] := AList[l];
      for AExtraIndex := 0 to AExtraCount - 1 do
      begin
        x1s[AExtraIndex] := AExtraList[AExtraIndex][p];
//      Vs := AExtraList[p];
        AExtraList[AExtraIndex][p] := AExtraList[AExtraIndex][l];
      end;

      i := succ(l);
      j := r;
      while true do
      begin
//        while (i < j) and (ACompare(v, AList[i]) > 0) do
        while (i < j) and (fcxIntCompare(PfcxCommonUV(x1s[AOrderIndex]).Index, PfcxCommonUV(AExtraList[AOrderIndex][i]).Index) > 0) do
          inc(i);
//        while (j >= i) and (ACompare(AList[j], v) > 0) do
        while (j >= i) and (fcxIntCompare(PfcxCommonUV(AExtraList[AOrderIndex][j]).Index, PfcxCommonUV(x1s[AOrderIndex]).Index) > 0) do
          dec(j);
        if (i >= j) then
          break;
        b := AList[i];
        AList[i] := AList[j];
        AList[j] := b;
        for AExtraIndex := 0 to AExtraCount - 1 do
        begin
          bs := AExtraList[AExtraIndex][i];
          AExtraList[AExtraIndex][i] := AExtraList[AExtraIndex][j];
          AExtraList[AExtraIndex][j] := bs;
        end;
        dec(j);
        inc(i);
      end;
      AList[l] := AList[j];
      AList[j] := v;
      for AExtraIndex := 0 to AExtraCount - 1 do
      begin
        AExtraList[AExtraIndex][l] := AExtraList[AExtraIndex][j];
        AExtraList[AExtraIndex][j] := x1s[AExtraIndex];//vs;
      end;
      if ((j - l) <= (r - j)) then
      begin
        QuickSortOLWithExtraListWithOrder(l, j - 1);
        l := succ(j);
      end
      else
      begin
        QuickSortOLWithExtraListWithOrder(j + 1, r);
        r := pred(J);
      end;
    end;
  end;

var
  I, AExtraIndex: integer;
  ACommonUV: PfcxCommonUV;
  APointer: Pointer;
begin
  GetMem(x1s, AExtraCount * fcPointerSize);
// first move NULL value to first position
  if ANullValue <> nil then
    for I := AStart to AEnd do
    begin
      if (AList[I] = ANullValue) then
      begin
        if I <> AStart then
        begin
          ACommonUV := AList[I];
          AList[I] := AList[AStart];
          AList[AStart] := ACommonUV;
          if AExtraList <> nil then
          begin
            for AExtraIndex := 0 to AExtraCount - 1 do
            begin
              APointer := AExtraList[AExtraIndex][I];
              AExtraList[AExtraIndex][I] := AExtraList[AExtraIndex][AStart];
              AExtraList[AExtraIndex][AStart] := APointer;
            end;
          end;
        end;
        inc(AStart);
        Break;
      end;
    end;
  if AExtraList <> nil then
    if (AOrderIndex > -1) and (AOrderIndex < AExtraCount) then
      QuickSortOLWithExtraListWithOrder(AStart, AEnd)
    else
      QuickSortOLWithExtraList(AStart, AEnd)
  else
    QuickSortOL(AStart, AEnd);
  FreeMem(x1s);
end;

end.


