Delphi XE8中的数字分区算法生成器

Question

How to make efficient and simplest algorithm to output a list of number N Partitions in Delphi XE8 ?

For example N=4 , the result (Lets say listed in a TListBox ):

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

I have tried something, decided to use a dynamic array:

var
  IntegerArray: array of Integer;

To count the ones, twos, threes,...

And this to type out the dynamic array in a 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;

And started writing the algorithm (so far works but uses only numbers 1,2 and 3 to write partitions), but it seems I need to rewrite it to use recursion (so it will use all available numbers to write partitions), and that's my question; how to use recursion here?

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;

---

Example of running the current program:

Update

Managed to make it work like this:

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;

But clearly, I need some optimization.

Answer 1

You are right, the simplest implementation is recursive.

There are some possibilities for optimization (for larger values it would be nice to store partitions of smaller values and use them again and again), but I think that for big N values the result list size will be too huge for output

//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, '');

gives output

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 

Answer 2

From your link there was a reference to: Fast Algorithms for Generating Integer Partitions .

Implementing the proposed fastest algorithms there (ZS1 and ZS2) looks like this: (Note, there is no recursion here!)

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.

Outputs:

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