Reset of compound combinations in delphi

[elysha]

There's a code that crosses all possible combinations of row elements and takes them to List.Box:

procedure TForm1.Button1Click(Sender: TObject);
var
 m: integer;
procedure GenStr(S0, S1: string);

var

i: integer;

begin

if Length(S0) = m then

ListBox1.Items.Add(S0)

else

for i := 1 to Length(S1) do

GenStr(S0+S1[i], copy(S1,1,i-1) + copy(S1,i+1,Length(S1)));

end;
begin

m := 3;

GenStr('','123');

end;
end.

After completed, the result is: 123♪ 132♪ 213♪ 231♪ 312♪ 321which, with regard to my task, is correct.

But my job is to find such combinations in the elements of the body, not in the row. That is, for example, compliance:

a[0]:=1;

a[1]:=2;

a[2]:=3;

GenStr('',a[0],a[1],a[2]);

That would give me the same result.
How can that be realized?

[Demir]

Algorithm converts:

1. Moving from the penultimate part of the reset looking for a[i], meeting the inequality a[i] bu a[i + 1].
2. Modify element a[i] with the smallest element that:
   • is right a[i].
   • is larger than a[i]
3. All elements behind a[i] shall be sorted.

I didn't change your code. I wrote mine.

unit Unit1;
{$mode objfpc}{$H+}
interface
uses

Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
{ TForm1 }
TForm1 = class(TForm)

Button1: TButton;

Edit1: TEdit;

ListBox1: TListBox;

procedure Button1Click(Sender: TObject);

private

{ private declarations }

public

{ public declarations }

end;
type

ResultArray = array of integer;
var

Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure PrintArray(pArr: ResultArray; p: integer);

var

i: integer;

s: string;

begin

s := '(' + IntToStr(p) + ') ';

for i := 0 to Length(pArr) - 1 do

s := s + IntToStr(pArr[i]);

Form1.ListBox1.Items.Add(s);

end;
function SortArray(pArr: ResultArray; index: integer): ResultArray;

var

list: TStringList;

i: integer;

begin

list := TStringList.Create;
list.Sorted := True;
for i := index + 1 to Length(pArr) - 1 do

list.Add(IntToStr(pArr[i]));
for i := 0 to list.Count - 1 do

pArr[index + 1 + i] := StrToInt(list[i]);
list.Free;
result := pArr;

end;
procedure TForm1.Button1Click(Sender: TObject);

var

count: integer;

arr: ResultArray;

i: integer;

xi, xj: integer;

max, tmp: integer;

flag: boolean;

p: integer;

begin

ListBox1.Clear;
count := StrToInt(Edit1.Text);

SetLength(arr, count);
p := 1;
// Заполняем массив от 1 до count

for i := 1 to count do

arr[i - 1] := i;
PrintArray(arr, p);
Inc(p);
while (True) do

begin

flag := False;

xj := count - 1;
  // (1) Двигаясь с предпоследнего элемента перестановки, ищем элемент a[i], удовлетворяющий неравенству a[i] < a[i + 1]
  for i := xj - 1 downto 0 do
    begin
      if (arr[i] < arr[i + 1]) then
         begin
           xi := i;
           max := arr[i + 1];
           xj := i + 1;
           flag := True;
           break;
         end;
    end;

  if (not flag) then
     break;

  // (2) Меняем местами элемент a[i] с наименьшим элементом, который:
  //     а) находится праве a[i].
  //     б) является больше чем a[i].
  for i := xj to count - 1 do
    begin
      if (arr[xi] < arr[i]) and (arr[i] < max) then
         begin
           xj := i;
           max := arr[i];
         end;
    end;

   tmp := arr[xi];
   arr[xi] := arr[xj];
   arr[xj] := tmp;

   // (3) Все элементы стоящие за a[i] сортируем
   arr := SortArray(arr, xi);

   PrintArray(arr, p);
   Inc(p);
 end;

end;

end.

Result: