1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:

procedure generate(n:word);
var c,t:byte;

begin

if n=1 then
  begin
  //Hier der Abruf bzw. die weitere Verarbeitung der jeweiligen Permutation, z.B. die Ausgabe
  end;

for c:=1 to n do
  begin
  if odd(n) then 
    begin t:=a[c];a[c]:=a[n];a[n]:=t end
    else begin t:=a[1];a[1]:=a[n];a[n]:=t
    end
  end

end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:

unit NDamen2009;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Spin, Grids, ExtCtrls, DBCtrls;

  type
   TBrett=Array of Integer;
   TNDamen = class(TForm)
    Anzahl: TSpinEdit;
    StaticText1: TStaticText;
    Start: TButton;
    StellungsAusgabe: TListBox;
    Zeigen: TCheckBox;
    StaticTextN: TStaticText;
    LabelN: TLabel;
    StaticTextTime: TStaticText;
    FeldAusgabe: TStringGrid;
    LabelZeit: TLabel;
    procedure StartClick(Sender: TObject);
    procedure StellungsAusgabeClick(Sender: TObject);
  private
     Brett:TBrett;
     BrettGroesse:Integer;
     Stellungen:Integer;
     function TimeSekunden:extended;
     procedure Ausgabe(NR:Integer;Brett:TBrett);
     function Erlaubt(x:Integer):Boolean;
     procedure Setz(x:Integer);
     procedure Fuellen(Nr:Integer);
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var NDamen: TNDamen;

implementation

{$R *.DFM}
{$R+,Q+}

 function TNDamen.TimeSekunden:extended;
  var H,M,S,MS:Word;
  begin
   DecodeTime(Now,H,M,S,MS);
   TimeSekunden:=3600.0*H+60.0*M+S+MS/1000
  end;

 procedure TNDamen.Ausgabe(NR:Integer;Brett:TBrett);
  var x,y:Integer;
      Zeile:String;
  begin
   IF NDamen.Zeigen.Checked then
    begin
     Zeile:='';
     StellungsAusgabe.Items.Add(IntToStr(Nr)+'-te Stellung');
     for x:=1 to BrettGroesse do
      for y:=1 to BrettGroesse do
       IF Brett[x]=y then Zeile:=Zeile+char(x+64)+IntToStr(y)+' ';
     StellungsAusgabe.Items.Add(Zeile);
     StellungsAusgabe.Items.Add('');
    end
  end;

 function TNDamen.Erlaubt(x:Integer):Boolean;
  var K:Integer;
  begin
   Erlaubt:=True;
   // waagerechter Test
   for K:=1 to x-1 do
    if Brett[x]=Brett[K] then begin Erlaubt:=False;exit end;
   [b]// Diagonaltest, entfällt beim Turmproblem[/b]
   for K:=1 to x-1 do
    if Abs(Brett[x]-Brett[K])=x-K then begin Erlaubt:=False;exit end;
  end;

 procedure TNDamen.Setz(x:Integer);
  var y:Integer;
  begin
   for y:=1 to BrettGroesse do
    begin
     Brett[x]:=y;
     if Erlaubt(x) then
      if x<BrettGroesse then Setz(x+1)
      else begin Inc(Stellungen);Ausgabe(Stellungen,Brett) end;
    end
  end;

 procedure TNDamen.Fuellen(nr:Integer);
  var x,y:Integer;
      Teil,Zeile:String;
  begin
   for x:=1 to BrettGroesse do
    FeldAusgabe.Cells[x,0]:=char(64+x);
   for y:=1 to BrettGroesse do
    FeldAusgabe.Cells[0,BrettGroesse+1-y]:=IntToStr(y);
   for y:=1 to BrettGroesse do
    for x:=1 to BrettGroesse do
     FeldAusgabe.Cells[x,y]:=' ';
   Zeile:=StellungsAusgabe.Items[Nr];x:=0;
   while Zeile<>'' do
    begin
     Teil:=Copy(Zeile,1,Pos(' ',Zeile)-1);Inc(x);
     y:=StrToInt(Copy(Teil,2,Length(Teil)-1));
     FeldAusgabe.Cells[x,BrettGroesse+1-y]:='D';
     Delete(Zeile,1,Pos(' ',Zeile));
    end;
  end;

 procedure TNDamen.StartClick(Sender: TObject);
  var x,y:Integer;
      TSek:Extended;
  begin
   BrettGroesse:=StrToInt(Anzahl.Text);
   SetLength(Brett,BrettGroesse+1);
   StellungsAusgabe.Clear;
   StellungsAusgabe.Width:=160;
   FeldAusgabe.Width:=25*(BrettGroesse+1);
   FeldAusgabe.Height:=25*(BrettGroesse+1);
   FeldAusgabe.ColCount:=BrettGroesse+1;
   FeldAusgabe.RowCount:=BrettGroesse+1;
   FeldAusgabe.Visible:=False;
   if BrettGroesse>4 then StellungsAusgabe.Width:=120+(BrettGroesse-4)*30;
   if BrettGroesse>11 then Zeigen.Checked:=False;
   if Not Zeigen.Checked then
    begin
     StellungsAusgabe.Visible:=False;
     FeldAusgabe.Visible:=False
    end
   else
    begin
     StellungsAusgabe.Visible:=True;
     FeldAusgabe.Visible:=True;
    end;
   Stellungen:=0;
   Screen.Cursor:=crHourGlass;
   TSek:=TimeSekunden;Setz(1);TSek:=TimeSekunden-TSek;
   Screen.Cursor:=crDefault;
   LabelZeit.Caption:=Format('%0.2f',[TSek])+' sek.';
   LabelN.Caption:=IntToStr(Stellungen);
   for x:=1 to BrettGroesse do
    FeldAusgabe.Cells[x,0]:=char(64+x);
   for y:=1 to BrettGroesse do
    FeldAusgabe.Cells[0,BrettGroesse+1-y]:=IntToStr(y);
   for y:=1 to BrettGroesse do
    for x:=1 to BrettGroesse do
     FeldAusgabe.Cells[y,BrettGroesse+1-x]:=' ';
  end;

 procedure TNDamen.StellungsAusgabeClick(Sender: TObject);
  var Nr:Integer;
  begin
   Nr:=StellungsAusgabe.ItemIndex;
   if (NR+2)mod 3=0 then Fuellen(Nr);
  end;

end.					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:

1  2  3  4            
2  3  4  1             
3  4  1  2            
4  1  2  3            
1  2  3  4    T[4]=L, also dec(L)        
2  3  1  4    es werden nur die ersten drei rotiert        
3  1  4  2            
1  4  2  3            
4  2  3  1            
2  3  1  4    T[4]=L, also dec(L)        
3  1  2  4    es werden nur die ersten drei rotiert        
1  2  4  3            
2  4  3  1            
4  3  1  2            
3  1  2  4    T[4]=L, also dec(L)
1  2  3  4    es werden nur die ersten drei rotiert
          T[3]=L, also dec(L)
2  1  3  4    es werden nur die ersten zwei rotiert
1  3  4  2    
3  4  2  1    
4  2  1  3    
2  1  3  4    T[4]=L, also dec(L)
1  3  2  4    es werden nur die ersten drei rotiert
3  2  4  1    
2  4  1  3    
4  1  3  2    
1  3  2  4    T[4]=L, also dec(L)
3  2  1  4    es werden nur die ersten drei rotiert
2  1  4  3    
1  4  3  2    
4  3  2  1    
3  2  1  4    T[4]=L, also dec(L)
          es werden nur die ersten drei rotiert
2  1  3  4    T[3]=L, also dec(L)
          es werden nur die ersten zwei rotiert
1  2  3  4    T[2]=L, also dec(L)
          L hat den Wert 1 ==> Schluß					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:

unit Perm;

interface

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

type
  TPermutationen = class(TForm)
    SpinEditN: TSpinEdit;
    LabelN: TLabel;
    ButtonWeiter: TButton;
    ButtonAlle: TButton;
    Ausgabe: TMemo;
    ButtonStart: TButton;
    procedure ButtonWeiterClick(Sender: TObject);
    procedure ButtonStartClick(Sender: TObject);
    procedure ButtonAlleClick(Sender: TObject);
  private
    { Private-Deklarationen }
    Perm:Array[1..10]of Byte;
    N,Index:Byte;
    Anzahl:Integer;

    procedure Anzeigen;
  public
    { Public-Deklarationen }
  end;

var
  Permutationen: TPermutationen;

implementation

{$R *.dfm}

 procedure TPermutationen.ButtonWeiterClick(Sender: TObject);
  var Tausch,K:Byte;
  begin
   if Index>1 then
    begin
     Tausch:=Perm[1];
     for K:=2 to Index do Perm[K-1]:=Perm[K];
     Perm[Index]:=Tausch;
     if Perm[Index]=Index then dec(Index) else Anzeigen
    end
   else
    begin
     Ausgabe.Lines.Add('Anzahl der Permutationen: '+IntToStr(Anzahl));
     ButtonWeiter.Enabled:=False;
     ButtonAlle.Enabled:=False;
    end;
  end;

 procedure TPermutationen.ButtonStartClick(Sender: TObject);
  var K:Byte;
  begin
   N:=SpinEditN.Value;Ausgabe.Clear;
   for K:=1 to N do Perm[K]:=K;
   Anzahl:=0;Anzeigen;
   ButtonWeiter.Enabled:=True;
   ButtonAlle.Enabled:=True;
  end;

 procedure TPermutationen.Anzeigen;
  var K:Byte;
      Zeile:String;
  begin
   Zeile:='';
   for K:=1 to N do Zeile:=Zeile+Char(ord('@')+Perm[K])+' ';;
   Ausgabe.Lines.Add(Zeile);
   inc(Anzahl);Index:=N;
  end;

 procedure TPermutationen.ButtonAlleClick(Sender: TObject);
  var Tausch,K:Byte;
  begin
   N:=SpinEditN.Value;
   if N>8 then
    if MessageDlg('Bist du dir sicher',mtConfirmation,[mbYes,mbNo],0)=mrNo then exit;
   Ausgabe.Clear;
   for K:=1 to N do Perm[K]:=K;
   Anzahl:=0;Anzeigen;
   while Index>1 do
    begin
     Tausch:=Perm[1];
     for K:=2 to Index do Perm[K-1]:=Perm[K];
     Perm[Index]:=Tausch;
     if Perm[Index]=Index then dec(Index) else begin Index:=N;Anzeigen end;
    end;
   Ausgabe.Lines.Add('Anzahl der Permutationen: '+IntToStr(Anzahl));
   ButtonWeiter.Enabled:=False;
   ButtonAlle.Enabled:=False;
  end;

end.					

1:
2:
3:

     Tausch:=Perm[1];
     for K:=2 to Index do Perm[K-1]:=Perm[K];
     Perm[Index]:=Tausch;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:

Program PermSteinJohnsTrott;
//Permutationsenumeration nach Steinhaus-Johnson-Trotter
//aLa Delphi-Laie
{$IFDEF FPC}
  {$MODE DELPHI}
  {$Optimization ON}
  {$Optimization RegVar}
  {$Optimization PEEPHOLE}
  {$Optimization CSE}
  {$Optimization ASMCSE}
  //{$CODEALIGN Loop=1}(* <-Spasseshalber *) {$CODEALIGN proc=32}
{$Else}
  {$APPTYPE console}
{$Endif}

uses
  sysutils,classes;
type
  tFeld= array[0..19] of Integer;
var
  T1,T0: TDateTime;
  sl : TStringlist;
  zaehler:cardinal;

procedure GetPermutations(x:string);
var
  p,d : tFeld;
  Nr : longint;

  i,
  k,l,n:integer;
  first:boolean;

  h:char;
{$IFDEF AUSGABE}
  InvCnt_alt,InvCnt_neu,
  sAusgabe : String;
  function InvCnt:word;
  var
    k,l:word;
  begin
  result:=0;
  for k:=1 to pred(length(x)) do
    for l:=k to length(x) do
      if x[k]>x[l] then
        inc(result);
  end;
{$ENDIF}
  function Init(j: integer): boolean;
  begin
    writeln('Init ');
    for j := j downto 2 do Begin
      p[j]:=0;
      d[j]:=1
      end;
    result :=false
    end;

begin
{$IFDEF AUSGABE}
InvCnt_alt:=1;
Nr := 1;
For i := n downto 2 do
  Nr := Nr*i;
sl.capacity := Nr;
{$EndIF}
n := length(x);
zaehler:=0;
Nr := 0;

first:= true;
IF first then
  first := Init(length(x));

repeat
  n:=length(x);
  For i := n-1 downto 0 do Begin
    k:=0;
    repeat
      l:=p[n]+d[n];
      inc(zaehler);
      p[n]:=l;
      if l=n then begin
        d[n]:=-1;
        if n>2 then begin
          dec(n);
          continue
          end
        else
          break;
        end;
      if l<>0 then
        break;
      d[n]:=1;
      inc(k);

      if n>2 then
        dec(n);
      until false;

      IF L= n then // L , n = 2
        begin
        l:=1;
        first:=true;
        end;

  {3:}inc(Nr);
{$IFDEF AUSGABE}
      InvCnt_neu:=InvCnt;
      sAusgabe := Format('%s %5d InvZahl %3d  DiffInvZahl %3d',[x,Nr,InvCnt_neu,InvCnt_neu-InvCnt_alt]));
      sl.add(sAusgabe);
      InvCnt_alt:=InvCnt_neu;
{$ENDIF}

      l:=l+k;//nächster Tausch
      h:=x[l];
      x[l]:=x[succ(l)];
      x[succ(l)]:=h;
      //oder Ausgabe des Arrays / Strings erst hier, dann ist die letzte ausgegebene Permutation die Nullpermutation (bzw. das Einserelement)
      {Form1.ListBox1.Items.Add(inttostr(zaehler)+': '+x+', InvCnt: '+inttostr(InvCnt));
      Form1.ListBox1.Refresh;
      Form1.ListBox1.TopIndex:=pred(Form1.ListBox1.Items.Count);}
    end;
  until first;
  Writeln(Nr);
end;

procedure FormCreate(s : string);

begin
 T0 := now;
 GetPermutations(s);
 T1 := now;
end;

var
  i : integer;
  s : String;
Begin
 // Cpu aufwecken..
 formcreate( '123456789');
{$IFNDEF AUSGABE}
    s := '123456789ABC';
    FormCreate(s);
{$ELSE}
  s := '12345';
  sl := TStringlist.create;
  FormCreate(s);
  i:= sl.count;
  writeln(i);
  sl.sorted := true;
  sl.sorted := false;
  sl.add('');
  sl.add('Anzahl Permutationnen '+IntToStr(i));
  sl.add('');
  sl.add('Aufrufe zur Bestimmung der Tauschstelle '+InttoStr(Zaehler));
  sl.add('');
  sl.add(Format('Relation %5.3f',[Zaehler/i]));
  writeln(sl.text);
  sl.free;
{$ENDIF}
  writeln(FormatdateTime('HH:NN:SS.zzz',T1-T0));
end.					

1:
2:
3:

first:= true;
IF first then
  first := Init(length(x));					

1:
2:
3:
4:
5:
6:

for j:=2 to length(x) do
  begin
  p[j]:=0;
  d[j]:=1
  end;
first:=false;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:

procedure TForm1.BerechnenClick(Sender: TObject);
var n,k,anz,h,i,m:integer;
    x,y:array[1..20] of integer;
    t1:int64;
    liste:tstringlist;
procedure ausgabe;
var i:integer;
    kk:string;
begin
    kk:='';
    for i:=1 to k do kk:=kk+inttostr(x[i])+' ';
    liste.add(kk);
    application.processmessages;
end;
begin
    listbox1.clear;
    liste:=tstringlist.create;
    n:=updown1.position;
    k:=updown2.position;
    if k>n then k:=n;
    anz:=0;
    if k=n then m:=k-1
           else m:=k;
    for i:=1 to n do x[i]:=i;
    for i:=1 to m do y[i]:=i;

    t1:=gettickcount;
    i:=m;
    inc(anz);
{$IFDEF Ausgabe}
    ausgabe;
{$ENDIF}
    repeat
      if y[i]<n then
      begin
        inc(y[i]);
        h:=x[i];
        x[i]:=x[y[i]];
        x[y[i]]:=h;
        i:=m;
        inc(anz);
{$IFDEF Ausgabe}
        ausgabe
{$ENDIF}
      end
      else
      begin
        repeat
          h:=x[i];
          x[i]:=x[y[i]];
          x[y[i]]:=h;
          dec(y[i]);
        until y[i]<=i;
        dec(i);
      end;
      if anz mod 100000 = 0 then
      begin
        label3.caption:=inttostr(x[1]);
        application.processmessages;
      end;
    until (i=0);
    liste.add(inttostr(anz));
    liste.add(inttostr(gettickcount-t1)+' ms');
    listbox1.items:=liste;
    liste.free;
end;					

1:
2:
3:
4:
5:

  
# ./Perm
n=12,k=12
479001600
00:00:04.704