Комбинаторика в Delphi. Как определить все перестановки в массиве.

Несмотря на то, что тема поста относится больше не к программированию, а к математике, определение всех перестановок в массиве (неважно какого типа) может потребоваться и при работе в Интернет. Простой пример — определть все возможные названия сайтов, составленных из 3 ключевых слов. Или провести синонимизацию какого-либо участа текста, используя заданные массивы слов-синонимов. Что касается количества перестановок, то тут все просто — количество перестановок будет равно факториалу количества элементов в массиве, т.е., если у нас есть массив M, то количество перестановок k будет равно:
k = Length(M)!
для трехэлементного массива k=1*2*3=6
для четырех элементов: k=1*2*3*4=24 и т.д.
Осталось только вывести все возможные перестановки.

Чтобы продемонстрировать вариант перебора всевозможных перестановок зададимся простой целью:
Есть набор чисел: 1, 2, 3. Необходимо вывести все возможные перестановки этих чисел.
Итак на входе у нас будет массив (1,2,3).
Нам надо переставить числа так, чтобы в итоге все числа выставились в ряд: 3, 2, 1.
Для достижения поставленой цели нам потребуется:

1. Вспомогательная функция определения количества перестановок (вычисления факториала числа). Хоть у нас и есть чётко заданый масси, следует учитывать будущее этого алгоритма — вывести перестановки для массивов любой длины.
2. Функция получения следующей перестановки.
3. Функция перемещения двух элементов в массиве.

Самое простое — то написать функцию перестановки двух элементов в массиве (первая задача на первом курсе по информатике):

procedure Swap(var a, b: byte);
var  c: byte;
begin
   c := a;
   a := b;
   b := c
end;

Вычисление факториала — тоже не вызовет никаких проблем и затруднений:

function Factorial(n: Word): Longint;
var f: LongInt;
     i: Integer;
begin
  f := 1;
  for i := 2 to n do
    f := f * i;
  Result:=f;
end;

Теперь подумаем как составить функцию получения следующей перестановки в массиве. В каком случае можно поменять два элемента массива местами? Логично предполоить, что в нашем случае менять местами элементы необходимо до тех пор пока все предудыщие элементы в массиве не станут меньше последующих.
Попробуем реализовать сказанное в виде процедуры:

type
  TSingleArray = array of byte;
procedure Next(var X: TSingleArray; var Yes: boolean);
var i,j: byte;
begin
  i:=High(X)-1;//начинаем с предпоследнего элемента
  { поиск i }
  while (i >= Low(X)) and (X[i] > X[i + 1]) do
    dec(i);
  if (i >= Low(X))and(i<=high(X)) then
    begin
      j:=i+1;//следующий за X[i] элемент
    {поискj}
      while (j<high(X)) and (X[j+1]>X[i]) do
       inc(j);
      Swap(X[i], X[j]);//меняем местами
      for j:=i+1 to (high(X)+i) div 2 do
         Swap(X[j], X[high(X)-j+i+1]);
      Yes:=true
    end
  else
    Yes:=false;//все перестановки завершены
end;

Итак, все вспомогательные методы готовы. Осталось собрать их воедино.
Будем делать так. Передаем в функцию одномерный массив для которого необходимо вывести все перестановки, на выходе будем получать двумерный массив у которого количество элементов в первом измерении равно количеству перестановок, а во втором измерении — количеству элементов в исходном массиве.

procedure GenerateBytes(const Key: array of byte);
var
  i,j: integer;
  ByteArray: TByteArray;
  Yes:boolean;
 
procedure Next(var X: TSingleArray; var Yes: boolean);
var  i, j: byte;
begin
  i:=High(X)-1;
  { поиск i }
  while (i >= Low(X)) and (X[i] > X[i + 1]) do
    dec(i);
  if (i >= Low(X))and(i<=high(X)) then
    begin
      j:=i+1;
    { поиск j }
      while (j<high(X)) and (X[j+1]>X[i]) do
       inc(j);
      Swap(X[i], X[j]);
      for j:=i+1 to (high(X)+i) div 2 do
        Swap(X[j], X[high(X)-j+i+1]);
      Yes:=true
    end
  else
    Yes:=false;
end;
 
begin
  SetLength(ByteArray, Factorial(Length(Key)));//устанавливаем размер первого измерения
  SetLength(ByteArray[0],length(Key));//второе измерение
  i:=0;
    repeat
      SetLength(ByteArray[i],length(a));//добавляем элемент во второе измерение
      for j:=0 to length(a)-1 do
        ByteArray[i,j]:=a[j];//записываем перестановку
      inc(i);
      Next(a, Yes);//ищем следующую перестановку
    until not Yes;
end;

После завершения процедуры массив ByteArray будет содержать следующие элементы:

((1,2,3),
 (1,3,2),
 (2,1,3),
 (2,3,1),
 (3,1,2),
 (3,2,1))

Немного видоизменив функцию Next можно составить массив перестановок, например, для нескольких слов.