Combination and Permutation with merging function - delphi

Question

I have a n number of strings which I need to merge into n number of strings in multiple combinations/permutations. the string cannot repeat itself and combination in single merge doesnt matter ( S1, S2 ) = ( S2, S1 )...
This is used when building a tree model and it decided which combination of characteristics is the best to merge...
This code is what I've wrote for permutations. List contains characteristic attributes, Splits is the number of splits I want to make , SplitList return which attributes need to be merge together... for binary tree I input "2" for Splits and for non-binary tree I run a cycle to return the best value for each of the splits .
I.E.
I have "A", "B", "C", "D", "E", "F".
If i Need to merge into 2 string
2. "A,B,C" and "D,E,F" or "A,C,E" and "B,D,F" or "A,E,F" and "B,C,D"
3. "A,B, and "C,D" and "E,F" or "A,D" and "C,B" and "E,F"
Also minimum number in a string is 1, maximum n-1.
I.E
2. "A" and "B,C,D,E,F" or "C" and "A,B,D,E,F" is a valid merging
function TSplitEngine.doTest(List: TList; Splits: Integer; var SplitList : TArray<Integer>): Double;
var
i, j, SplitNo, Pointer : Integer;
tmpNode : TDTreeNode;
CurRes, CurOut : Double;
TestArr : RTestArr;
ResArr: TArray<double>;
SplitStr : String;
DoSplit, FindSplit : Boolean;
TestList : TArray<Integer>;
begin
Result := DefaultVal;
SetLength( TestList, Splits );
for i := 0 to Length( TestList ) - 1 do
TestList[ i ] := i + 1;
TestArr.Size := Splits + 1;
DoSplit := True;
while DoSplit do
begin
Inc(Iteration);
TestArr.Clear;
for i := 0 to List.Count - 1 do
begin
tmpNode := TDTreeNode( List[ i ] );
j := 0;
FindSplit := True;
While ( j < Length( TestList ) ) and ( FindSplit ) do
begin
if i < TestList[ j ] then
begin
Combine Characteristics
FindSplit := False;
end
else if ( i >= TestList[ Length( TestList ) - 1 ] ) then
begin
Combine last split characteristics
FindSplit := False;
end;
inc( j );
end;
TestArr.AllTotal := TestArr.AllTotal + ( tmpNode.Goods + tmpNode.Bads );
end;
//CalcNode returns the result of this particular splits
CurRes := CalcNode( TestArr );
SetLength( ResArr, 2 );
ResArr[ 1 ] := CurRes;
if IsBetter( CurRes, Result ) then
begin
Result := CurRes;
SplitList := Copy( TestList, 0, Length( TestList ) );
end;
SplitNo := 1;
FindSplit := True;
//Move the split like a pointer...
i := Length( TestList ) - 1;
while ( i >= 0 ) and FindSplit do
begin
if ( TestList[ i ] < ( List.Count - SplitNo ) ) then
begin
Pointer := TestList[ i ] + 1;
for j := i to Length( TestList ) - 1 do
begin
TestList[ j ] := Pointer;
inc( Pointer );
end;
FindSplit := False;
end
else if ( i = 0 ) then
DoSplit := False;
inc ( SplitNo );
Dec( i );
end;
end;
end;
the permutation code seems to be working and the only thing to do would be to tidy it up.
I've tried a few times to convert this code to do combinations but never seemed to work.

Answer 1

I have old code for generation of set partitions with set size <= 10 (due to set comparison implemented through strings). Note that number of partitions for n=10 is 115975 (Bell number).
Procedure generates non-repeating partitions of set into KP parts, so you have to go through all KP values.
Part of output including some two-parts and some three-parts partitions:
1,4 | 2,3,5 |
1,4,5 | 2,3 |
1,5 | 2,3,4 |
1 | 2 | 3,4,5 |
1 | 2,3 | 4,5 |
1 | 2,3,4 | 5 |
procedure generate_multi_partitions(values: array of Integer; KP: Integer);
var
n, i: Integer;
avail: array of Boolean;
output: array of TStringList;
procedure foo(k: Integer); forward;
procedure bar(k, i: Integer);
var
j: Integer;
begin
output[k].add(IntToStr(values[i]));
avail[i] := False;
foo(k + 1);
for j := i + 1 to n - 1 do
if avail[j] and ((j = 0) or (values[j - 1] <> values[j]) or
(not avail[j - 1])) then
bar(k, j);
output[k].Delete(output[k].Count - 1);
avail[i] := True;
end;
procedure foo(k: Integer);
var
i, j: Integer;
s: string;
begin
if (k >= 2) and (output[k - 2].CommaText > output[k - 1].CommaText) then
Exit;
if k = KP - 1 then begin
output[k].Clear;
for i := 0 to n - 1 do
if avail[i] then
output[k].add(IntToStr(values[i]));
if (output[k].Count > 0) and
((k = 0) or (output[k - 1].CommaText <= output[k].CommaText)) then
begin
s := '';
for j := 0 to KP - 1 do
s := s + output[j].CommaText + ' | ';
Memo1.Lines.add(s);
end;
output[k].Clear;
end
else
for i := 0 to n - 1 do
if avail[i] then begin
bar(k, i);
Exit;
end;
end;
begin
n := length(values);
SetLength(avail, n);
SetLength(output, KP);
for i := 0 to KP - 1 do
output[i] := TStringList.Create;
for i := 0 to n - 1 do
avail[i] := True;
foo(0);
for i := 0 to KP - 1 do
output[i].Free;
end;
var
parts: Integer;
begin
for parts := 1 to 5 do
generate_multi_partitions([1, 2, 3, 4, 5], parts);
end;