Столкнулся с проблемой такого порядка. Как ни крутил, решить оптимально не получается. Требуется мозговой штурм коллективного разума. Задача выглядит следующим образом.

Имеется одномерный массив с N ячейками. Необходимо, казалось бы, просто сделать следующее. По заданному максимальному взятому для использования количеству ячеек M (<=N), начинающихся с первой от начала массива, необходимо менять значения в них следующим образом. Объяснить могу только на примере.
Т.е. в начале необходимо взять две первые ячейки. Изначально в первую записать 1, во вторую - на единицу больше. Затем надо менять значение во второй ячейке до некоторого числа K (к примеру, 30)...
Выглядит это так
1 2
1 3
...
1 30
Будут образовываться пары чисел, которые нужно потом будет сохранить. Но это уже к делу не относится. Тут бы сделать основное. Далее, когда значение во второй ячейке достигнет К, надо значение в первой ячейке увеличить на 1. И повторить цикл заново. Т.е.
2 3
2 4
...
2 30 и т.д. До того момента пока последняя пара будет К-1 К (в примере 29 30).
Далее необходимо включить в цикл третью ячейку. И сделать тот же самый цикл по тем же самым критериям изменений. Т.е. изначально это 1 2 3, потом 1 2 4 ... вплоть до К-2 К-1 К (28 29 30). Итак пока мы не заполним все три ячейки таким перебором. Потом четыре ячейки и т.д.
Перебор из M ячеек закончится тогда, когда последним набором чисел будет
K-M+1 K-M ... K-2 K-1 K

Думал, что просто. Справлюсь на раз-два-три. Оказалось не всё так просто, как кажется. Задача имеет практическое значение, поэтому бросить не могу. Нужно решить. Сам не в состоянии. Впервые попал в ступор при решении подобных задач. Помогите выбраться из тупика.

Оно?

program Counter30;

const
  M = 5;
  K = 10;
type
  TArray = array [0..M - 1] of integer;

  procedure ShowArray(const a: TArray);
  var
    i: integer;
  begin
    for i := 0 to M - 1 do
      Write(a[i]: 3);
    writeln;
  end;

var
  a: TArray;
  i, j, n: integer;
begin
  for i := 0 to M - 1 do
    a[i] := 0;
  a[0] := 1;
  a[1] := 1;
  i := 1;
  while a[M - 1] <> K do
  begin
    Inc(a[i]);
    if a[i] > K then
    begin
      a[i] := a[i - 1] + 1 + 1;
      {перенос}
      for j := i - 1 downto 0 do
      begin
        Inc(a[j]);
        if (a[j] <= K - j - i) then
        begin
          for n := j + 1 to i do
            a[n] := a[n - 1] + 1;
          break;
        end
        else
        if j = 0 then
        begin
          Inc(i);
          a[0] := 1;
          for n := j + 1 to i do
            a[n] := a[n - 1] + 1;
        end;
      end;
    end;
    ShowArray(a);
  end;
end.

Почти ... гениально. Увы, почти. Я даже до этого не дошёл. Где-то в коде неточность есть. Я вывел результат в тестовый файл. По циклу всё идёт правильно до позиции
1 33 36
После неё должна следовать группа
1 34 35
Однако, почему-то идёт
2 3 4 и т.д.
Т.е. теряются группы
1 34 35
1 34 36
1 35 36
Тоже самое происходит и после группы
2 33 36
За ней следует не
2 34 35
2 34 36
2 35 36
а аналогичная по логике, но неправильная по сути задачи
3 4 5
Итак в конце каждого цикла по первому числу в тройках. Кроме последних троек, которые должны были оканчивать в таком порядке
33 34 35
33 34 36
33 35 36
34 35 36
а фактически получилось
32 33 36
33 34 35
33 34 36
34 35 36
Т.е. по трём чисел после пары циклы заканчиваются на ... 33 36 вместо ... 35 36.

Потом на четырёх позициях происходит тоже самое нарушение логики при смене цикла на второй позиции. Т.е. за
1 2 31 36 должно следовать 1 2 32 33 и т.к., а идёт 1 3 4 5.
Получается из логики выпадают группы
1 2 32 33
1 2 32 34
1 2 32 35
1 2 32 36
1 2 33 34
1 2 33 35
1 2 33 36
1 2 34 35
1 2 34 36
1 2 35 36
Цикл по первой позиции переключается с 1 32 33 36 на 2 3 4 5, пропуская ряд групп чисел. Т.е. цикл по третьей позиции заканчивается на ... ... 31 36 вместо ... ... 35 36.
И наконец, включается пятая позиция и ...её хватает всего на интервал
1 2 3 4 5 ... 1 2 3 4 36. Всё. Где же недочёт. Не могу найти.

Добавлено через 13 мин.
Т.е. получается такой вот файл... Вместо К=10 я взял 36 ... Но сути дело не меняет. М тоже самое оставил.

Или так

program Counter30;

const
  M = 5;
  K = 10;
type
  TArray = array [0..M - 1] of integer;

  procedure ShowArray(const a: TArray);
  var
    i: integer;
  begin
    for i := 0 to M - 1 do
      Write(a[i]: 3);
    writeln;
  end;

  function IsFinal(const a: TArray): boolean;
  var
    i: integer;
    Res: boolean;
  begin
    Res := True;
    for i := 0 to M - 1 do
      Res := Res and (a[i] = K - M + 1 + i);
    IsFinal := Res;
  end;

var
  a: TArray;
  i, j, n: integer;
begin
  for i := 0 to M - 1 do
    a[i] := 0;
  a[0] := 1;
  a[1] := 1;
  i := 1;
  while not IsFinal(a) do
  begin
    Inc(a[i]);
    if a[i] > K then
    begin
      a[i] := a[i - 1] + 1 + 1;
      {перенос}
      for j := i - 1 downto 0 do
      begin
        Inc(a[j]);
        if (a[j] <= K + j - i) then
        begin
          for n := j + 1 to i do
            a[n] := a[n - 1] + 1;
          break;
        end
        else
        if j = 0 then
        begin
          Inc(i);
          a[0] := 1;
          for n := j + 1 to i do
            a[n] := a[n - 1] + 1;
        end;
      end;
    end;
    ShowArray(a);
  end;
end.

Опять близко, но не в точку Я же говорил, что задача несколько сложнее, чем кажется на первый взгляд. Вот тот же текстовый файл, полученный в результате выполнения программы по новому коду. Строчки в виде ************ - это место, где нарушается логическая последовательность. У меня уже крышечку срывает, когда я занимаюсь алгоритмом этой задачи. Печалька какая-то А решать надо. Может ещё покрутить-повертеть?

Т.е. сам принцип цикличности переменного количества циклов реализован, но ... не до конца. По всей видимости проблема в критериях, по которым прерывается очередной цикл. Т.е. где-то в коде функции IsFinal или перед её входом не учтён какой-то нюанс. Скорее всего речь идёт о таком переменном цикле условий выхода из цикла, но касающегося вопроса своевременности прерывания основных циклов смены чисел. В этом соль Земли.

т.е. в нашем примере в двухпозиционных массивах цикл из 10 чисел должен прерываться после числа 9 в первой позиции
в трёхпозиционных на второй позиции аналогично после достижения 9 и на первой позиции при достижении 8 и так далее

У нас же получается преждевременный выход из цикла в определённых местах.

IsFinal - условие завершения, условно говоря, программы
Ошибка где-то в переносе.

Прийду вечером - посмотрю.

Там в переменной i - текущий столбец для накопления (изменения на каждом шаге). Если i=K, то начинается перенос - инкремент левых столбцов. Этот инкремент выполняется до тех пор, пока в j столбце сохраняется после инкремента условие переноса - т.е. K-1 (для i-1), K-2 (для i-2) и т.д. Потом перенос останавливается и начинается заполнение столбцов справа новыми значениями.

В теории ДА, но не по всему массиву срабатывает на практике. Значит уже где-то в самом алгоритме что-то не то. Спасибо, что не остаётесь безучастным к проблеме. До вечера.

Павел, совместно с ещё одним помощником пришли к самому близкому по сути простому алгоритму. Он выглядит следующим образом:



В итоге получилось следующее. Если используются первые две из пяти позиций массива (т.е. 1 2 0 0 0 и т.д.), алгоритм идеально отрабатывается. На трёх позициях первый сбой происходит на изменении в цикле первой позиции. Т.е. с 1 2 3 0 0 по 1 5 6 0 0 всё гладко ложится, но потом идёт не 2 3 4 0 0, а 2 2 3 0 0... Итак, по всем сменам циклов по позициям. Т.е., как я понимаю, для устранения этой ошибки надо сделать так, чтобы после смены цикла на следующей позиции число было бы на единицу больше, чем в старте текущего цикла.
Устранив эту ошибку, мы решим задачу.
Отсюда предполагается, что рыть надо в коде начиная с выражения a[i-1]:=a[i-1]+1 и ниже до until a[0]=k-n. Всё что вне этих рамок, вроде как создаёт правильную логику. HELP!!! Мы уже близко.

Добавлено через 2 мин.
В прилагаемом текстовом файле в результате отработки программного кода всё это видно наглядно.

УРА!!! Сам докрутил
Вот, что получилось:

Program MH;
Const n=5; k=6;
Var a: array [0..n] of integer;
i,j,d,l,m: integer;
Id, Od: text;
begin
assign(Od,'C:\TP\tz.txt'); Rewrite(Od);
a[1]:=1; i:=1;
repeat
i:=i+1;
repeat
for j:=1 to k-a[i-1] do
begin
a[i]:=a[i-1]+j; d:=0;
for l:=1 to n do
if a[l]>a[l-1] then d:=d+1;
for l:=1 to n do
if d=i then write(Od,a[l]:3) else break;
if l=n then writeln(Od);
end;
a[i-1]:=a[i-1]+1;
m:=-1;
for l:=i-1 downto 1 do
begin
m:=m+1;
if a[l]>k-m then
begin
a[l-1]:=a[l-1]+1;
a[l]:=l;
end;
end;
until a[1]=k-i+2;
a[0]:=0;
for l:=1 to i do a[l]:=l;
until i=n;
close(Od);
end.

Откомпилировал во FreePascal файл из поста #4.
Результат
Для сравнения тот же кусок из TZ1.txt из поста #5:
Ну и дальше
Из TZ1:
Я не пойму. Помеченное звёздочками должно отсутствовать, или наоборот - почему то отсутствует?
----------------------------
Sorry. Пока набирал, всё уже закончилось.