Delphi - Get combinations from multiple sets-CodePudding

Using: Delphi 10.2 Tokyo

Please link me to an algorithm or code to get all possible combinations of values from multiple sets, with one value per set. The number of sets is not known in advance, nor the number of values in each set.

Example:

1. (1, 2, 3) (A, B)
Desired result: 
1 A
1 B
2 A
2 B
3 A
3 B

2. (1, 2, 3, 4) (A, B) (X, Y, Z)
Desired result: 
1 A X
1 A Y
1 A Z
2 A X
2 A Y
2 A Z
3 A X
3 A Y
3 A Z
4 A X
4 A Y
4 A Z
1 B X
1 B Y
1 B Z
2 B X
2 B Y
2 B Z
3 B X
3 B Y
3 B Z
4 B X
4 B Y
4 B Z

Thanks in advance!

CodePudding user response：

Recursive and iterative generation (with storage and without storage) of cartesian product of 2d array A elements

var
  A: array of array of Integer;
  B: array of array of Integer;
  i, j: Integer;
  s: string;
  NN: Integer;

  procedure CartesianRec(From: Integer; cs: string);
  var
    j: integer;
  begin
    if From = Length(A) then
      Memo1.Lines.Add(cs)
    else
      for j := 0 to High(A[From]) do
        CartesianRec(From   1, cs   IntToStr(A[From, j])   ' ');
  end;

  procedure CartesianIter;
  var
    i, j, k, l, c, N, M: Integer;
  begin
    NN := 1;
    for k := 0 to High(A) do
      NN := NN * Length(A[k]);
    SetLength(B, NN, Length(A));
    N := NN;
    M := 1;
    for k := 0 to High(A) do begin
      N := N div Length(A[k]);
      c := 0;
      for l := 0 to M - 1 do
        for i := 0 to High(A[k]) do
          for j := 0 to N - 1 do begin
            B[c, k] := A[k, i];
            Inc(c);
          end;
      M := M * Length(A[k]);
    end;
  end;

  procedure CartesianOnline;
  var
    i, j, k, l, c, N, M, dimA: Integer;
    s: string;
  begin
    NN := 1;
    dimA := Length(A);
    //SetLength(CartProduct, dimA);
    for k := 0 to dimA - 1 do
      NN := NN * Length(A[k]);
    for i := 0 to NN - 1 do begin
      j := i;
      s := '';
      for k := dimA - 1 downto 0 do begin
        l := j mod Length(A[k]);
        s := IntToStr(A[k][l])   ' '   s;
        //we can also put CartProduct[k] := A[k][l];
        j := j div Length(A[k]);
      end;
      Memo1.Lines.Add(s);
      //or use CartProduct
    end;
  end;

  begin
  nn := 1;
  SetLength(A, 3);
  for i := 0 to High(A) do begin
    SetLength(A[i], 5 - i);
    s := '';
    for j := 0 to High(A[i]) do begin
      A[i, j] := nn;
      Inc(nn);
      s := s   IntToStr(A[i, j])   ' ';
    end;
    Memo1.Lines.Add(s);
  end;
  Memo1.Lines.Add('------');
  CartesianRec(0, '');
  Memo1.Lines.Add('------');
  CartesianIter;
  for i := 0 to NN - 1 do begin
    s := '';
    for j := 0 to High(A) do
      s := s   IntToStr(B[i, j])   ' ';
    Memo1.Lines.Add(s);
  end;
  Memo1.Lines.Add('------');
  CartesianOnline;

1 2 3 4 5 
6 7 8 9 
10 11 12

Result:

CodePudding user response：

I used TLists and Integer arrays and managed to solve the problem. Here is my code:

uses Classes, SysUtils, Generics.Collections;

type
  TIntArray = array of integer;

  TIntArrayList = TList<TIntArray>;

  TCartesianProduct = class
  private
    FSetList: TIntArrayList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure AddSet(ASet: TIntArray);
    procedure GetCombinations(var AIntArrayList: TIntArrayList);
  end;

implementation

{ TCartesianProduct }

constructor TCartesianProduct.Create;
begin
  FSetList := TIntArrayList.Create;
end;

destructor TCartesianProduct.Destroy;
begin
  FSetList.Free;
end;

procedure TCartesianProduct.AddSet(ASet: TIntArray);
begin
  FSetList.Add(ASet);
end;

procedure TCartesianProduct.GetCombinations(var AIntArrayList: TIntArrayList);
var
  WorkList, OuputList: TIntArrayList;
  r: TIntArray;
  n, c, l: integer;
  f: Boolean;
begin

  WorkList := TIntArrayList.Create; // Length of each set array, and current iteration index
  OuputList := TIntArrayList.Create;
  try
    n := FSetList.Count;

    for c := 0 to n - 1 do
      WorkList.Add([Length(FSetList[c]), 0]);

    while ((WorkList[0][1] < WorkList[0][0])) do
    begin

      SetLength(r, n); // result array length is the number of sets

      for c := 0 to FSetList.Count - 1 do
      begin
        r[c] := FSetList[c][WorkList[c][1]];
      end;

      Inc(WorkList[n - 1][1]); // last work list item (set)
      if (WorkList[n - 1][1] = WorkList[n - 1][0]) and (n - 1 <> 0) then // if it equal the length of the set
      begin
        WorkList[n - 1][1] := 0; // then reset it back to zero

        l := n - 1; // make pointer point to previous item up
        f := false;
        repeat
          Dec(l);

          if (l >= 0) then
          begin
            Inc(WorkList[l][1]); // increase index in previous item
            if (l <> 0) and (WorkList[l][1] = WorkList[l][0]) then
            begin
              WorkList[l][1] := 0; // If that items pointer points to the last item, reset it to zero
            end
            else
              f := true;
          end
          else
            f := true;

        until f;

      end;

      OuputList.Add(r);
    end;

    AIntArrayList.Clear;
    for c := 0 to OuputList.Count - 1 do
      AIntArrayList.Add(OuputList[c]);

  finally
    OuputList.Free;
    WorkList.Free;
  end;

end;

Test it with this code:

procedure TfmMain.btTestClick(Sender: TObject);
 var
 intset1, intset2, intset3: TIntArray;
 outsetlist: TIntArrayList;
 CP: TCartesianProduct;
 c, d: Integer;
 l: string;
begin
   SetLength(intset2, 4);
   SetLength(intset3, 4);
  
   intset2[0] := 105;
   intset2[1] := 106;
   intset2[2] := 107;
   intset2[3] := 108;
  
   intset3[0] := 109;
   intset3[1] := 110;
   intset3[2] := 111;
   intset3[3] := 112;
  
   outsetlist := TIntArrayList.Create;
   CP := TCartesianProduct.Create;
   try
   CP.AddSet(intset2);
   CP.AddSet(intset3);
  
   CP.GetCombinations(outsetlist);
  
   ListBox1.Clear;
  
   for c := 0 to outsetlist.Count - 1 do
   begin
   l := '';
   for d := 0 to high(outsetlist[c]) do
   l := l   Format('%d ', [outsetlist[c][d]]);
  
   ListBox1.Items.Add(l);
   end;
  
   finally
   CP.Free;
   outsetlist.Free;
   end;
end;