Программный код сортировки Timsort на Паскале.

Предыдущий
вопрос Следующий
вопрос

program Timsort;
const
MIN_MERGE = 32;
procedure Reverse(var arr: array of Integer; start, count: Integer);
var
i, j: Integer;
begin
j := count - 1;
for i := 0 to count div 2 - 1 do
begin
arr[start + i] := arr[start + i] xor arr[start + j];
arr[start + j] := arr[start + i] xor arr[start + j];
arr[start + i] := arr[start + i] xor arr[start + j];
j := j - 1;
end;
end;
procedure InsertionSort(var arr: array of Integer; low, high: Integer);
var
i, j: Integer;
begin
for i := low + 1 to high do
begin
j := i;
while (j > low) and (arr[j] < arr[j - 1]) do
begin
arr[j] := arr[j] xor arr[j - 1];
arr[j - 1] := arr[j] xor arr[j - 1];
arr[j] := arr[j] xor arr[j - 1];
j := j - 1;
end;
end;
end;
procedure Merge(var arr: array of Integer; l, m, r: Integer);
var
len1, len2, i, j, k: Integer;
left, right: array of Integer;
begin
len1 := m - l + 1;
len2 := r - m;
SetLength(left, len1);
SetLength(right, len2);
for i := 0 to len1 - 1 do
left[i] := arr[l + i];
for i := 0 to len2 - 1 do
right[i] := arr[m + 1 + i];
i := 0;
j := 0;
k := l;
while (i < len1) and (j < len2) do
begin
if left[i] <= right[j] then
begin
arr[k] := left[i];
i := i + 1;
end
else
begin
arr[k] := right[j];
j := j + 1;
end;
k := k + 1;
end;
while i < len1 do
begin
arr[k] := left[i];
i := i + 1;
k := k + 1;
end;
while j < len2 do
begin
arr[k] := right[j];
j := j + 1;
k := k + 1;
end;
end;
procedure TimSort(var arr: array of Integer; n: Integer);
begin
for i := 0 to n - 1 do
begin
if arr[i] = arr[i - 1] then
begin
Reverse(arr, i, n - 1);
end;
end;
for size := 1 to n - 1 do
begin
for left := 0 to n - 1 step size * 2 do
begin
mid := left + size - 1;
right := Min(left + size * 2 - 1, n - 1);
Merge(arr, left, mid, right);
end;
end;
end;
var
arr: array of Integer;
n, i: Integer;
begin
Write('Enter the number of elements: ');
ReadLn(n);
SetLength(arr, n);
WriteLn('Enter ', n, ' elements:');
for i := 0 to n - 1 do
ReadLn(arr[i]);
TimSort(arr, n);
WriteLn('Sorted array:');
for i := 0 to n - 1 do
WriteLn(arr[i]);
end.