SplitTPAEx.pas

procedure TPASortXY(var A: TPointArray; iLo, iHi: Integer);
var
  Lo, Hi, PivotX, PivotY: Integer;
begin
  Lo := iLo;
  Hi := iHi;
  PivotX := A[(Lo + Hi) div 2].x;
  PivotY := A[(Lo + Hi) div 2].y;
  repeat
    while (A[Lo].y < PivotY) or ((A[Lo].y = PivotY) and (A[Lo].x < PivotX)) do Inc(Lo);
    while (A[Hi].y > PivotY) or ((A[Hi].y = PivotY) and (A[Hi].x > PivotX)) do Dec(Hi);
    if Lo <= Hi then
    begin
      Swap(A[Lo], A[Hi]);
      Inc(Lo);
      Dec(Hi);
    end;
  until Lo > Hi;
  if Hi > iLo then TPASortXY(A, iLo, Hi);
  if Lo < iHi then TPASortXY(A, Lo, iHi);
end;

function BinarySearchX(A: TPointArray; x, Lo, Hi: Integer): Integer;
var
  Pos, PivotX: Integer;
begin
  if (Lo > Hi) then
    Exit(Lo);

  Pos := (Lo + Hi) div 2;
  PivotX := A[Pos].x;

  if (x < PivotX) then
    Result := BinarySearchX(a, x, Lo, Pos - 1)
  else if (x > PivotX) then
    Result := BinarySearchX(a, x, Pos + 1, Hi)
  else
  begin
    while (Pos > 0) and (A[Pos - 1].y = A[Pos].y) and (A[Pos - 1].x = x) do
      Dec(Pos);
    Result := Pos;
  end;
end;

function DeluxeSplitTPAEx(const Arr: TPointArray; w, h: Integer): T2DPointArray;
var
  tpa: TPointArray;
  i, Len, x, y, yy, xx: Integer;

  Groups: TIntegerArray;
  GroupInfo: array of record
    Index: Integer;
    Length: Integer;
  end;
  GroupCount, FromGroup, ToGroup, CurrentGroup: Integer;

  CurrentX, CurrentY, RowCount, LookAhead: Integer;
  Rows: array of record
    StartIndex, EndIndex, LookAhead: Integer;
  end;
begin
  if (Length(Arr) < 1) or (w < 0) or (h < 0) then
    Exit;

  tpa := Copy(Arr);
  Len := High(tpa);

  TPASortXY(tpa, 0, Len);
  CurrentY := tpa[0].y;

  SetLength(Rows, Min(tpa[Len].y - CurrentY, Len) + 1);
  RowCount := -1;

  i := 0;
  while (i <= Len) do
  begin
    y := tpa[i].y;

    Inc(RowCount);
    Rows[RowCount].LookAhead := y - CurrentY;
    Rows[RowCount].StartIndex := i;

    CurrentY := y;
    Inc(i);

    while (i <= Len) and (tpa[i].y = CurrentY) do Inc(i);
    Rows[RowCount].EndIndex := i - 1;
  end;

  CurrentY := 0;
  LookAhead := h;
  while (CurrentY < RowCount) and (Rows[CurrentY + 1].LookAhead <= LookAhead) do
  begin
    Dec(LookAhead, Rows[CurrentY + 1].LookAhead);
    Inc(CurrentY);
  end;

  for i := 0 to RowCount - 1 do
  begin
    Rows[i].LookAhead := CurrentY - i;

    Inc(LookAhead, Rows[i + 1].LookAhead);
    while (CurrentY < RowCount) and (Rows[CurrentY + 1].LookAhead <= LookAhead) do
    begin
      Dec(LookAhead, Rows[CurrentY + 1].LookAhead);
      Inc(CurrentY);
    end;
  end;

  SetLength(Groups, Len + 1);
  SetLength(GroupInfo, Len + 1);

  CurrentGroup := 0;
  GroupCount := 1;

  Groups[0] := 0;
  GroupInfo[0].Index  := 0;
  GroupInfo[0].Length := 1;

  CurrentX := tpa[0].x;
  CurrentY := tpa[0].y;

  for i := 1 to Len do
  begin
    x := tpa[i].x;
    y := tpa[i].y;

    if (y <> CurrentY) or (x - CurrentX > w) then
    begin
      Inc(GroupCount);
      Inc(CurrentGroup);

      GroupInfo[CurrentGroup].Index := i;
    end;

    CurrentX := x;
    CurrentY := y;

    Groups[i] := CurrentGroup;
    Inc(GroupInfo[CurrentGroup].Length);
  end;

  if (h > 0) then
    for y := 0 to RowCount - 1 do
    begin
      if (GroupCount <= 1) then
        Break;

      LookAhead := Rows[y].LookAhead;
      if (LookAhead <= 0) then
        Continue;

      Inc(LookAhead, y);
      CurrentY := Rows[LookAhead].EndIndex;

      for x := Rows[y].StartIndex to Rows[y].EndIndex do
      begin
        CurrentX := tpa[x].x;
        ToGroup := Groups[x];

        for yy := y + 1 to LookAhead do
          for xx := BinarySearchX(tpa, CurrentX - w, Rows[yy].StartIndex, Rows[yy].EndIndex) to Rows[yy].EndIndex do
          begin
            FromGroup := Groups[xx];

            if (FromGroup = ToGroup) then
              Continue
            else if (tpa[xx].x > CurrentX + w) then
              Break
            else if (GroupInfo[FromGroup].Length > GroupInfo[ToGroup].Length) then
              Swap(FromGroup, ToGroup);

            Groups[x]  := ToGroup;
            Groups[xx] := ToGroup;

            CurrentGroup := GroupInfo[FromGroup].Length;
            GroupInfo[FromGroup].Length := 0;

            Inc(GroupInfo[ToGroup].Length, CurrentGroup);
            Dec(GroupCount);

            i := GroupInfo[FromGroup].Index;
            if (i < GroupInfo[ToGroup].Index) then
              GroupInfo[ToGroup].Index := i;

            for i := i to CurrentY do
              if (Groups[i] = FromGroup) then
              begin
                Groups[i] := ToGroup;
                Dec(CurrentGroup);
                if (CurrentGroup <= 1) then
                  Break;
              end;
          end;

      end;
    end;

  CurrentGroup := 0;
  SetLength(Result, GroupCount);

  for i := 0 to Len do
    if (GroupInfo[i].Length > 0) then
    begin
      SetLength(Result[CurrentGroup], GroupInfo[i].Length);

      GroupInfo[i].Index := CurrentGroup;
      GroupInfo[i].Length := 0;
      Inc(CurrentGroup);

      if (CurrentGroup >= GroupCount) then
        Break;
    end;

  for i := 0 to Len do
  begin
    CurrentGroup := Groups[i];
    Result[GroupInfo[CurrentGroup].Index][GroupInfo[CurrentGroup].Length] := tpa[i];
    Inc(GroupInfo[CurrentGroup].Length);
  end;
end;