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:

program Kombination;
{In einem Feld Komb werden die Indizes gespeichert.
Für jeden Index wird die vorhandene Anzahl angegeben und
daraus alle Anordnungen bestimmt.
k aus n mit mehrfachen.

Wenn Index 0 die kleinste Ziffer sei und Index n-1 die groesste Ziffer sei,
dann sind die Kombinationen aufsteigend sortiert.

Zu verwenden, wie auch immer, ohne Anspruch auf Korrektheit.}

{$IFDEF FPC}
  {$mode Delphi}
  {$DEBUGINFO-}
  {$R- $V- $O-}
  {$Optimization ON}
  {$Optimization regvar}
  {$Optimization PEEPHOLE}
  {$Optimization CSE}
  {$Optimization ASMCSE}
  {$CODEALIGN proc=32}
  {$ASMMODE INTEL}
{$ELSE}
  {$APPTYPE CONSOLE}
{$ENDIF}

uses
   sysutils;
type
  nativeinteger = longInt;//Int64;
const
  KombLaenge =3 ;//k
  KL_1 = KombLaenge-1;
  n = KombLaenge+2;// 3 aus 5

var
  PermCount: Int64;
  T1,T0 : int64;
  FeldAnzahl : array[0..n-1] of LongInt;
  Komb : array[0..KL_1] of byte;


function GetCPU_Time: int64;
type
  TCpu = record
            HiCpu,
            LoCpu : Dword;
         end;
var
  Cput : TCpu;
begin
  asm
  RDTSC;
  MOV Dword Ptr [CpuT.LoCpu],EAX;  MOV Dword Ptr [CpuT.HiCpu],EDX
  end;
  with Cput do  result := int64(HiCPU) shl 32 + LoCpu;
end;

procedure VerarbeitungKomb; //inline;
var
  I : nativeinteger;
Begin
  INC(PermCount);

  For i := Low(Komb) to High(Komb) do
    write(Komb[i]:2);
  writeln;
end;

procedure VerarbeitungKombZaehl; inline;

Begin
  INC(PermCount);
end;

procedure permute(depth:nativeinteger);
var
  i: nativeinteger;
Begin
  IF depth > KL_1 THEN Begin
//    VerarbeitungKombZaehl;
    VerarbeitungKomb;
    EXIT;
    end;

  i := Low(FeldAnzahl);
  repeat
    IF FeldAnzahl[i] >0 then begin
      dec(FeldAnzahl[i]);
      Komb[depth] := i;
      permute(depth+1);
      Komb[depth] := 0;// muesste nicht sein
      inc(FeldAnzahl[i]);
      end;
    inc(i);
  until i > High(FeldAnzahl);
end;

procedure Init;
var
  i: integer;
  sum: longint;
begin
  randomize;
  repeat
    sum := 0;
    For i := Low(FeldAnzahl) to High(FeldAnzahl) do Begin
      FeldAnzahl[i] := random(3);// KombLaenge;//-> PermCount = n^k
      inc(Sum,FeldAnzahl[i]);
      end;
  until Sum >= KombLaenge;

  write('  Index: ');
  For i := Low(FeldAnzahl) to High(FeldAnzahl) do
     write(i:2);
  writeln;
  write(' Anzahl: ');
  For i := Low(FeldAnzahl) to High(FeldAnzahl) do
     write(FeldAnzahl[i]:2);
  writeln;
  writeln('Weiter mit <ENTER>') ;
  ReadlN;
end;

var
  Time1,Time0: TDateTime;
  I: nativeinteger;

Begin
  Init;

  Time0 := Time;T0 := GetCPU_Time;
  permute(0);
  T1 := GetCPU_Time;Time1 := Time;

  writeln(PermCount:12,' Anzahl der Kombinationen');
  writeln((T1-T0)/PermCount:12:5,' CPU-Takte pro Durchgang');
  IF Time1-Time0 > 0 then
  Writeln((Time1-Time0)*(86000.0*1e9)/PermCount:12:6,' ns');
  writeln(FormatDateTime('HH:NN:SS.ZZZ',Time1-Time0));
end.					

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

  Index:  0 1 2 3 4
 Anzahl:  0 1 2 0 0
Weiter mit <ENTER>

 1 2 2
 2 1 2
 2 2 1
           3 Anzahl der Kombinationen
oder 
nur Zählen mit 7 aus 10 wobei alle 7 fach vorhanden:
  Index:  0 1 2 3 4 5 6 7 8 9
 Anzahl:  7 7 7 7 7 7 7 7 7 7
Weiter mit <ENTER>

    10000000 Anzahl der Kombinationen
    27.40196 CPU-Takte pro Durchgang
    7.763889 ns
00:00:00.078					

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:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    procedure FormCreate(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure GetPermutations(x:string);
var zaehler:cardinal;
  i,inversionsanzahl_alt,inversionsanzahl_neu:byte;
  h:char;
  d:array of integer;
  p:array of byte;
  j,k,l,n:byte;
  first:boolean;

  function inversionsanzahl: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;
  
  procedure Ausgabe;
  Begin
    inversionsanzahl_neu:=inversionsanzahl;
    Form1.ListBox1.Items.Add(inttostr(zaehler)+': '+x+', Inversionsanzahl: '+inttostr(inversionsanzahl_neu)+', Differenz: '+inttostr(inversionsanzahl_neu-inversionsanzahl_alt));
    Form1.ListBox1.Refresh;
    Form1.ListBox1.TopIndex:=pred(Form1.ListBox1.Items.Count);
    inversionsanzahl_alt:=inversionsanzahl_neu;
  end;  

  procedure step1;forward;

  procedure step2;
  begin
  if n>2 then
    begin
    dec(n);
    step1
    end
  else
    begin
    l:=1;
    first:=true
    end
  end;

  procedure step1;
  begin
  l:=p[n]+d[n];
  p[n]:=l;
  if l=n then
    begin
    d[n]:=-1;
    step2
    end
  else if l=0 then
    begin
    d[n]:=1;
    inc(k);
    step2
    end
  end;


begin
inversionsanzahl_alt:=1;
setlength(d,succ(length(x)));
setlength(p,succ(length(x)));
zaehler:=0;
for j:=1 to n do begin
  p[j]:=0;
  d[j]:=1
  end;
first:=false;

// Hier passiert es
repeat
  n:=length(x);
  for i:=1 to length(x){n} do Begin
    k:=0;

    step1;
    inc(zaehler);

    Ausgabe;

    l:=l+k;//nächster Tausch
    h:=x[l];
    x[l]:=x[succ(l)];
    x[succ(l)]:=h;
    end
  until first
end;

procedure TForm1.FormCreate(Sender: TObject);
var s:string;
begin
Form1.Show;
s:=Inputbox('Zu permutierenden String eingeben','String?',s);
GetPermutations(s)
end;

end.					

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

Mit tDat = Byte:
Permute_i
   479001600 Anzahl der Kombinationen
    35.39909 CPU-Takte pro Durchgang
   11.009300 ns
00:00:05.298
Permute_Move
   479001600 Anzahl der Kombinationen
    23.70283 CPU-Takte pro Durchgang
    7.370703 ns
00:00:03.547
Permute_s
   479001600 Anzahl der Kombinationen
    10.78625 CPU-Takte pro Durchgang
    3.353909 ns
00:00:01.614					

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

tDat = LongInt
Permute_i
   479001600 Anzahl der Kombinationen
    24.81255 CPU-Takte pro Durchgang
    7.715653 ns
00:00:03.713
Permute_Move
   479001600 Anzahl der Kombinationen
    36.27229 CPU-Takte pro Durchgang
   11.279441 ns
00:00:05.428					

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:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:

program Variation;
{In einem Feld Komb werden die Indizes gespeichert.
Für jeden Index wird die vorhandene Anzahl angegeben und
daraus alle Kombinationen bestimmt.
k aus n mit doppelten

Zu verwenden, wie auch immer, ohne Anspruch auf Korrektheit.}

{$IFDEF FPC}
  {$mode Delphi}
  {$DEBUGINFO-}
  {$R- $V- $O-}
  {$Optimization ON}
  {$Optimization regvar}
  {$Optimization PEEPHOLE}
  {$Optimization CSE}
  {$Optimization ASMCSE}
  {$CODEALIGN proc=32}
  {$ASMMODE INTEL}
{$ELSE}
  {$APPTYPE CONSOLE}
{$ENDIF}

uses
   sysutils;
const
  k =10;  //k
  KL_1 = k-1;
  n = k+3;// k aus n

type
//nativeInt = Longint;// Int64;
  tDat = Byte;
  tKombIndex = 0..KL_1;
  tKomb = array[tKombIndex] of tDat;

  tCallBack = function (const Komb:tKomb;depth:longInt): boolean;
  tPerm = procedure (depth:nativeint);
var
  T1,T0 : int64;
  PermCount: LongWord;//Int64;
  FeldAnzahl : array[0..k-1] of LongInt;
  Komb : tKomb;

  verarbeite: tCallBack;

  s: string;
  sKomb: pChar;
  Index : tDat;


function Check(const Komb:tKomb;depth:longInt): boolean;
begin
  //result := Komb[3]<>3;
  result := true;//false;
end;

function Check_Ausg(const Komb:tKomb;depth:longInt): boolean;
var
  i : integer;
  t: string[3];// 4 Byte = integer
  s: string[2*k+1];
begin
  i:= 0;
  s:='';
  repeat
    str(Komb[i]:2,T);
    s := s+t;
    inc(i);
  until i>depth;
  writeln(s);

  result := false;
end;

procedure PermMove;
  var
    Tausch:tDat;
  begin
  inc(PermCount);
  Index:=K;
  while Index>0 do
    begin
    Tausch:=Komb[0];
//    for K:=1 to Index-1 do
//      Perm[K-1]:=Perm[K];
    MOVE(Komb[1],Komb[0],(Index-1)*SizeOf(Komb[0]));
    Komb[Index-1]:=Tausch;
    if Tausch{Komb[Index]}=Index then
      dec(Index)
    else
      begin
      inc(PermCount);
      Index:=K;
      end;
    end;
  end;

function GetCPU_Time: int64;
type
  TCpu = record
            HiCpu,
            LoCpu : Dword;
         end;
var
  Cput : TCpu;
begin
  asm
  RDTSC;
  MOV Dword Ptr [CpuT.LoCpu],EAX;
  MOV Dword Ptr [CpuT.HiCpu],EDX
  end;
  with Cput do  result := int64(HiCPU) shl 32 + LoCpu;
end;


procedure Permute(depth:nativeint);
var
  i: nativeint;
Begin
  IF depth >= K THEN Begin
    inc(PermCOunt);
    EXIT;
    end;
  i := Low(FeldAnzahl);
  repeat
    IF FeldAnzahl[i] >0 then begin
      dec(FeldAnzahl[i]);
      Komb[depth] := i;
//      IF Verarbeite(Komb,depth) then
        permute(depth+1);
      inc(FeldAnzahl[i]);
      Komb[depth] := 0;
      end;
    inc(i);
  until i > High(FeldAnzahl);
end;

procedure Init;
var
  i,j: integer;
  sum: longint;
begin

  setlength(s,n);
  sKomb := @s[1];
  //For i := Low(Komb) to High(Komb)
  For i in tKombIndex  do Begin
    Komb[i] := i+1;
    sKomb[i] := chr(65+i);
    end;


  randomize;
  repeat
    sum := 0;
    For i := Low(FeldAnzahl) to High(FeldAnzahl) do Begin
      j := random(3);
      FeldAnzahl[i] := j;
      inc(Sum,j);
      end;
  until Sum >= n;

  write('  Index: ');
  For i := Low(FeldAnzahl) to High(FeldAnzahl) do
     write(i:2);
  writeln;
  write(' Anzahl: ');
  For i := Low(FeldAnzahl) to High(FeldAnzahl) do
     write(FeldAnzahl[i]:2);
  writeln;
  {
  write(' Anzahl: ');
  For i := Low(tKombAnzFeld) to High(tKombAnzFeld) do
     write(KombAnzFeld[i]:2);
  writeln;}


  PERMcount:=0;
  //ReadLn;
end;

procedure Permute_i(depth:nativeInt);
var
  i: nativeInt;
  tmp : tDat;
begin
  IF depth <= 0 then
    begin
//    Verarbeite(Komb,KL_1);
    inc(PermCOunt);
    EXIT;
    end;
  i := depth+1;
  repeat
    dec(i);
    tmp:= Komb[depth];
    Komb[depth]:=Komb[i];
    Komb[i] := tmp;
//    IF Verarbeite(Komb,depth) then
       Permute_i(depth-1);
    Komb[i] := Komb[depth];
    Komb[depth]:=tmp;
  until i<= 0;
end;

procedure Permute_s_3;
var
  stmp : array[0..3] of char;// koennte auch permut_s_4
  s : pChar;
begin
{theoretisch:
 1 2 3
 2 1 3
 1 3 2
 3 1 2
 3 2 1
 2 3 1}
  s:= sKomb;
  //Werte zwischenspeichern
  stmp[0] :=s[0];stmp[1] :=s[1];    //1 2 3
  {writeln(s);}inc(PermCount);
                                stmp[2] :=s[2];
  s[0]:= sTmp[1];s[1]:= sTmp[0];                   //2 1 3
  {writeln(s);}inc(PermCount);
                 s[1]:= sTmp[2];s[2]:= sTmp[0];    //2 3 1
  {writeln(s);}inc(PermCount);
  s[0]:= sTmp[2];s[1]:= sTmp[1];                   //3 2 1
  {writeln(s);}inc(PermCount);
                 s[1]:= sTmp[0];s[2]:= sTmp[1];    //3 1 2
  {writeln(s);}inc(PermCount);
  s[0]:= sTmp[0];s[1]:= sTmp[2];                   //1 3 2
  {writeln(s);}inc(PermCount);
  //Wieder herstellen
                  s[1]:=stmp[1];s[2]:= stmp[2];    //1 2 3
end;

procedure Permute_s(depth:nativeint);
var
  i: nativeInt;
  tmp : char;
begin
  IF depth<3 then begin
    Permute_s_3;
    EXIT;
    end;
  i := depth;
  repeat
    tmp:= sKomb[depth];
    sKomb[depth]:=sKomb[i];
    sKomb[i] := tmp;
    Permute_s(depth-1);
    sKomb[i] := sKomb[depth];
    sKomb[depth]:=tmp;
    dec(i);
  until i< 0;
end;

procedure Testlauf(proc:tPerm;depth:nativeInt);
var
  Time1,Time0: TDateTime;
begin
  PermCount:= 0;
  Time0 := Time;T0 := GetCPU_Time;
  proc(depth);
  T1 := GetCPU_Time;Time1 := Time;
  writeln(PermCount:12,' Anzahl der Kombinationen');
  IF PermCOunt>0 then begin
    writeln((T1-T0)/PermCount:12:5,' CPU-Takte pro Durchgang');
    IF Time1-Time0 > 0 then
      Writeln((Time1-Time0)*(86000.0*1e9)/PermCount:12:6,' ns');
    end;
  writeln(FormatDateTime('HH:NN:SS.ZZZ',Time1-Time0));
end;

var

  I: nativeint;
Begin
  Init;
  IF k < 11 then
    Testlauf(@permute,0);

  For i := Low(Komb) to High(Komb) do
    Komb[i] := i+1;
  Verarbeite := @Check;//_Ausg;
  writeln('Permute_i');
  Testlauf(@Permute_i,k-1);

  writeln('Permute_Move');
  For i := Low(Komb) to High(Komb) do
    Komb[i] := i+1;
  Testlauf(@PermMove,k);

  writeln('Permute_s');
  Testlauf(@Permute_s,k-1);
  writeln('Weiter mit <ENTER>') ;
  ReadLn;
end.