//Cгенерировать все перестановки, которые состоят только из разрешенных циклов,
//например, перестановки длиной 5 из циклов {1},{2},{1,2},{1,4},{3,4,5},{3,4},{5},{1,2,3},{4,6},{3,5},{4},{1,5}.

unit AllowedPermForm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

type
  TCycle= integer;

const
  CycleBitCount=8*SizeOf(TCycle);
  AllCycles: array[0..11] of TCycle=
   ($01, $02, $03, $09, $1C, $0C, $10, $07, $18, $14, $08, $11);
   //{1},{2},{1,2},{1,4},{3,4,5},{3,4},{5},{1,2,3},{4,6},{3,5},{4},{1,5}

var
  LastBitNo: integer;
  ZeroIndex: array of integer;
  UsedIndex: array[0..CycleBitCount-1] of integer;
  CycleIndex: array[0..CycleBitCount-1] of array of integer;

{
Выдача из Init:
LastBitNo = 4
ZeroIndex = 1  2  2  1  5  4  5  3  5  3  4  1
CycleIndex[0] = 0  2  3  7  11
CycleIndex[1] = 1
CycleIndex[2] = 4  5  9
CycleIndex[3] = 8  10
CycleIndex[4] = 6

Выдача из Print:
00000001  00000002  0000001C
00000001  00000002  0000000C  00000010
00000001  00000002  00000014  00000008
00000003  0000001C
00000003  0000000C  00000010
00000003  00000014  00000008
00000009  00000002  00000014
00000007  00000018
00000007  00000008  00000010
00000011  00000002  0000000C
}

procedure Print(Count: integer);
var
  i: integer;
  s: string;
begin;
  for i:=0 to Count-1 do s:=s + IntToHex(AllCycles[UsedIndex[i]], 8) + '  ';
  Form1.Memo1.Lines.Add(s);
  end;

function Init: boolean;
var
  i, j, k: integer;
  c, AllBits: TCycle;
//  s: string;
begin;
  AllBits:=0;
  SetLength(ZeroIndex, Length(AllCycles));
  for i:=Low(CycleIndex) to High(CycleIndex) do CycleIndex[i]:=nil;
  for i:=Low(AllCycles) to High(AllCycles) do begin;
    c:=AllCycles[i];
    AllBits:=AllBits or c;
    if c<>0 then begin;
      j:=0;
      while c and 1=0 do begin;
        c:=c shr 1;
        inc(j);
        end;
      k:=Length(CycleIndex[j]);
      SetLength(CycleIndex[j], k+1);
      CycleIndex[j, k]:=i;
      while c and 1=1 do begin;
        c:=c shr 1;
        inc(j);
        end;
      ZeroIndex[i]:=j;
      end;
    end;
  Result:=(AllBits and (AllBits+1)=0);
  LastBitNo:=-1;
  while AllBits<>0 do begin;
    AllBits:=AllBits shr 1;
    inc(LastBitNo);
    end;
{
  Form1.Memo1.Lines.Add(Format('LastBitNo = %d',[LastBitNo]));
  s:='ZeroIndex = '; for i:=0 to Length(ZeroIndex)-1 do s:=s + IntToStr(ZeroIndex[i]) + '  ';
  Form1.Memo1.Lines.Add(s);
  for j:=0 to LastBitNo do begin;
    s:=Format('CycleIndex[%d] = ',[j]);
    for i:=0 to Length(CycleIndex[j])-1 do s:=s + IntToStr(CycleIndex[j,i]) + '  ';
    Form1.Memo1.Lines.Add(s);
    end;
}
  end;

procedure Generate(Count, BitNo: integer; Mask: TCycle);
var
  i, Index, NewBitNo: integer;
  c, t, NewMask: TCycle;
begin;
  for i:=0 to Length(CycleIndex[BitNo])-1 do begin;
    Index:=CycleIndex[BitNo, i];
    c:=AllCycles[Index];
    if Mask and c=0 then begin;
      NewMask:=Mask or c;
      UsedIndex[Count]:=Index;
      NewBitNo:=ZeroIndex[Index];
      t:=1; t:=t shl NewBitNo;
      while t and NewMask<>0 do begin;
        t:=t+t; inc(NewBitNo);
        end;
      if NewBitNo>LastBitNo then Print(Count+1)
      else Generate(Count+1, NewBitNo, NewMask);
      end;
    end;
  end;

procedure TForm1.Button1Click(Sender: TObject);
begin;
  Memo1.Lines.Add('Начало работы');
  if Init then Generate(0,0,0);
  Memo1.Lines.Add('Конец работы');
  end;

end.