Генератор алгоритмов с числовым номером в Delphi XE8

75
8

Как сделать эффективный и простой алгоритм для вывода списка номеров N разделов в Delphi XE8?

Например, N=4, результат (скажем, указан в TListBox):

4
3 + 1
2 + 2
2 + 1 + 1
1 + 1 + 1 + 1

Я что-то пробовал, решил использовать динамический массив:

var
IntegerArray: array of Integer;

Чтобы сосчитать те, два, три,...

И это, чтобы напечатать динамический массив в TListBox:

procedure TMForm.AddItem;
var
Temp: String;
I: Integer;
II: Integer;

begin

Temp:= '';
for II:= 0 to Length(IntegerArray)-1 do
begin

for I := 0 to (IntegerArray[(Length(IntegerArray)-II)-1]-1) do
begin
Temp:= Temp+IntToStr(Length(IntegerArray)-II-1);
Temp:= Temp+'+';
end;
end;

delete(Temp,length(Temp),1);
ListBox1.Items.Add(Temp);
end;

И начал писать алгоритм (пока работает, но использует только номера 1,2 и 3 для записи разделов), но мне кажется, мне нужно переписать его для использования рекурсии (чтобы он использовал все доступные номера для записи разделов), и что мой вопрос; как использовать рекурсию здесь?

function TMForm.Calculate(MyInt: Integer): Integer;
var
I: Integer;

begin
ListBox1.Clear;
GlobalInt:= MyInt;
Result:= 0;

SetLength(IntegerArray, 0);
SetLength(IntegerArray, (MyInt+1));
IntegerArray[1]:= MyInt;
AddItem;
Result:= Result+1;
//
if MyInt>1 then
begin

repeat
IntegerArray[1]:= IntegerArray[1]-2;
IntegerArray[2]:= IntegerArray[2]+1;
AddItem;
Result:= Result+1;

until ((IntegerArray[1]/2) < 1 );

if MyInt>2 then
repeat
IntegerArray[3]:= IntegerArray[3]+1;
IntegerArray[1]:= MyInt-IntegerArray[3]*3;
IntegerArray[2]:= 0;
AddItem;
Result:= Result+1;

if NOT ((IntegerArray[1]/2) < 1) then
repeat
IntegerArray[1]:= IntegerArray[1]-2;
IntegerArray[2]:= IntegerArray[2]+1;
AddItem;
Result:= Result+1;
until ((IntegerArray[1]/2) <=1 );

IntegerArray[1]:= MyInt-IntegerArray[3]*3;
IntegerArray[2]:= 0;
until ((IntegerArray[1]/3) < 1 );

//if MyInt>3 then...

end;

Edit1.Text:= IntToStr(Result);
end;

Пример запуска текущей программы:

enter image description here

Обновить

Удалось заставить его работать следующим образом:

procedure TMForm.Calculate(MyInt: Integer);
var
I: Integer;

begin
ListBox1.Clear;
GlobalInt:= MyInt;
ItemCount:= 0;

SetLength(IntegerArray, 0);
SetLength(IntegerArray, (MyInt+1));
IntegerArray[1]:= MyInt;
AddItem;
ItemCount:= ItemCount+1;
//
if MyInt>1 then
Step2;

if MyInt>2 then
for I := 3 to MyInt do
Steps(I);

Edit1.Text:= IntToStr(ItemCount);
end;

procedure TMForm.Steps(n: Integer);
var
I,II: Integer;

begin
if not ((IntegerArray[1]/n) < 1 ) then
repeat
IntegerArray[n]:= IntegerArray[n]+1;
//
IntegerArray[1]:= GlobalInt;
for I:= 3 to GlobalInt do IntegerArray[1]:= IntegerArray[1]-IntegerArray[I]*I;
//
AddItem;
ItemCount:= ItemCount+1;
Step2;

if n>3 then
for II := 3 to (n-1) do
begin
Steps(II);
end;

until ((IntegerArray[1]/n) < 1 );
//
IntegerArray[n]:= 0;
IntegerArray[1]:= GlobalInt;
for I:= 3 to GlobalInt do IntegerArray[1]:= IntegerArray[1]-IntegerArray[I]*I;
end;

procedure TMForm.SpinBox1Change(Sender: TObject);
begin
SpinBox2.Value:= SpinBox1.Value;
end;

procedure TMForm.Step2;
var
I: Integer;
begin
if NOT ((IntegerArray[1]/2) < 1) then
repeat
IntegerArray[1]:= IntegerArray[1]-2;
IntegerArray[2]:= IntegerArray[2]+1;
AddItem;
ItemCount:= ItemCount+1;

until ((IntegerArray[1]/2) < 1 );

IntegerArray[2]:= 0;
IntegerArray[1]:= GlobalInt;
for I:= 3 to GlobalInt do IntegerArray[1]:= IntegerArray[1]-IntegerArray[I]*I;
end;

procedure TMForm.FormCreate(Sender: TObject);
begin
//
end;

Но, очевидно, мне нужна оптимизация.

спросил(а) 2021-01-19T18:27:57+03:00 2 месяца, 3 недели назад
1
Решение
105

Вы правы, простейшая реализация рекурсивна.

Есть некоторые возможности для оптимизации (для больших значений было бы неплохо хранить разделы меньших значений и использовать их снова и снова), но я думаю, что для больших значений N размер списка результатов будет слишком большим для вывода

//N is number for partitions, M is maximum part value 
//(used here to avoid permutation repeats like 3 1 and 1 3)
procedure Partitions(N, M: integer; s: string);
var
i: integer;
begin
if N = 0 then
Memo1.Lines.Add(s)
else
for i := Min(M, N) downto 1 do
Partitions(N - i, i, s + IntToStr(i) + ' ');
end;

begin
Partitions(7, 7, '');

дает выход

7 
6 1
5 2
5 1 1
4 3
4 2 1
4 1 1 1
3 3 1
3 2 2
3 2 1 1
3 1 1 1 1
2 2 2 1
2 2 1 1 1
2 1 1 1 1 1
1 1 1 1 1 1 1

ответил(а) 2021-01-19T18:27:57+03:00 2 месяца, 3 недели назад
62

Из вашей ссылки была ссылка на: Быстрые алгоритмы генерации целых разделов.

Реализация предлагаемых быстрых алгоритмов там (ZS1 и ZS2) выглядит так: (Обратите внимание, здесь нет рекурсии!)

procedure PartitionsZS1(n: Integer);
var
x: TArray<Integer>;
i,r,h,t,m: Integer;
begin
SetLength(x,n+1);
for i := 1 to n do x[i] := 1;
x[1] := n;
m := 1;
h := 1;
WriteLn(x[1]);
while (x[1] <> 1) do begin
if (x[h] = 2) then begin
m := m + 1;
x[h] := 1;
h := h - 1;
end
else begin
r := x[h] - 1;
t := m - h + 1;
x[h] := r;
while (t >= r) do begin
h := h + 1;
x[h] := r;
t := t - r;
end;
if (t = 0) then
m := h
else begin
m := h + 1;
if (t > 1) then begin
h := h + 1;
x[h] := t;
end;
end;
end;
for i := 1 to m do Write(x[i]);
WriteLn;
end;
end;

procedure PartitionsZS2(n: Integer);
var
x: TArray<Integer>;
i,j,r,h,m: Integer;
begin
SetLength(x,n+1);
for i := 1 to n do x[i] := 1;
for i := 1 to n do Write(x[i]);
WriteLn;
x[0] := -1;
x[1] := 2;
h := 1;
m := n - 1;
for i := 1 to m do Write(x[i]);
WriteLn;
while (x[1] <> n) do begin
if (m-h > 1) then begin
h := h + 1;
x[h] := 2;
m := m - 1;
end
else begin
j := m - 2;
while (x[j] = x[m - 1]) do begin
x[j] := 1;
j := j - 1;
end;
h := j + 1;
x[h] := x[m - 1] + 1;
r := x[m] + x[m - 1]*(m-h-1);
x[m] := 1;
if (m - h) > 1 then
x[m-1] := 1;
m := h + r - 1;
end;
for i := 1 to m do Write(x[i]);
WriteLn;
end;
end;


program Project61;

{$APPTYPE CONSOLE}

begin
PartitionsZS1(7);
WriteLn;
PartitionsZS2(7);
end.

Выходы:

7
61
52
511
43
421
4111
331
322
3211
31111
2221
22111
211111
1111111

1111111
211111
22111
2221
31111
3211
322
331
4111
421
43
511
52
61
7

ответил(а) 2021-01-19T18:27:57+03:00 2 месяца, 3 недели назад
Ваш ответ
Введите минимум 50 символов
Чтобы , пожалуйста,
Выберите тему жалобы:

Другая проблема