Столкнулся с проблемой такого порядка. Как ни крутил, решить оптимально не получается. Требуется мозговой штурм коллективного разума. Задача выглядит следующим образом.
Имеется одномерный массив с 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.
program Counter30;
const
M = 5;
K = 10;
type
TArray = array [0..M - 1] of integer;
Или так
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.
program Counter30;
const
M = 5;
K = 10;
type
TArray = array [0..M - 1] of integer;
Т.е. сам принцип цикличности переменного количества циклов реализован, но ... не до конца. По всей видимости проблема в критериях, по которым прерывается очередной цикл. Т.е. где-то в коде функции IsFinal или перед её входом не учтён какой-то нюанс. Скорее всего речь идёт о таком переменном цикле условий выхода из цикла, но касающегося вопроса своевременности прерывания основных циклов смены чисел. В этом соль Земли.
т.е. в нашем примере в двухпозиционных массивах цикл из 10 чисел должен прерываться после числа 9 в первой позиции
в трёхпозиционных на второй позиции аналогично после достижения 9 и на первой позиции при достижении 8 и так далее
У нас же получается преждевременный выход из цикла в определённых местах.
IsFinal - условие завершения, условно говоря, программы
Ошибка где-то в переносе.
Прийду вечером - посмотрю.
Там в переменной i - текущий столбец для накопления (изменения на каждом шаге). Если i=K, то начинается перенос - инкремент левых столбцов. Этот инкремент выполняется до тех пор, пока в j столбце сохраняется после инкремента условие переноса - т.е. K-1 (для i-1), K-2 (для i-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.
Результат