Генерация перестановок.

{ генерация перестановок }
uses crt;
const n = 4; { количество элементов в перестановке}
var a:array[1..n] of integer;
    j:integer;{счетчик}
    kol : longint;{количество перестановок}
procedure generate (l,r:integer;var k:longint);
var i,v:integer;
begin
if (l=r) then
  begin
    for i:=1 to n do write(a[i],' ');
    writeln;
    k:=k+1;
  end
else
  begin
    for i := l to r do
      begin
        v:=a[l]; a[l]:=a[i]; a[i]:=v; {обмен a[i],a[l]}
        generate(l+1,r,k); {вызов новой генерации}
        v:=a[l]; a[l]:=a[i]; a[i]:=v; {обмен a[i],a[l]}
      end;
  end;
end;
begin
clrscr;
for j := 1 to N do
A[j]:=j;
generate( 1,n,kol);
writeln('kol=',kol);
readln
end.

{ Алгоритм Нарайаны — нерекурсивный алгоритм, генерирующий по данной
 перестановке следующую за ней перестановку (в лексикографическом порядке).
 Придуман индийским математиком Пандитом Нарайаной в XIV веке. 
 
Каждая следующая перестановка строится следующим образом:
 
    На первом шаге программы, двигаясь с конца массива, сравниваем соседние
    элементы, если предыдущий (по расположению в массиве) элемент больше
    следующего, двигаемся дальше, если меньше, останавливаемся и запоминаем
    его номер (m), этот элемент будет изменен (на этом шаге он отмечается
    красным треугольником снизу, а потом просто красным цветом).
    
    Элементы, стоящие слева от m-го, не изменяем (они станут окрашенными
    в серый цвет). Среди элементов, стоящих справа, нужно выбрать элемент (k),
    который должен встать на место m-го. Это минимальный элемент среди тех,
    которые больше m-го (отмечается синим треугольником, потом просто
    синим цветом).
    
    Меняем m-ый и k-ый элементы.
    Осталось упорядочить по возрастанию элементы, стоящие справа от нового m-го
    элемента, но т.к. они упорядочены по убыванию, достаточно их обернуть
    (оборачиваемая часть обозначена стрелками). }
    
Var RS : String;
 
Function StRevers(St :String) : String;
Var
  ii  : Longint;
  St0 : String;
Begin
  St0:='';
 For ii:=length(St) downto 1 do
  St0:=St0+St[ii];
  StRevers:=St0;
end;
 
Function LexNext(S : String) : String;
Var
  len,m,k,t : Longint;
  Sch       : Char;
  cs        : String;
  flag      : Boolean;
Begin
  len:=Length(S); flag:=True;
  For m:=len-1 downto 1 do
    If S[m]<S[m+1] then Break;
  For k:=len downto m+1 do
    If S[k]>S[m] then
    Begin
      flag:=False;
      Break;
    end;
  If flag then LexNext:='' else
  Begin
    For t:=len downto m+1 do
      If (S[t]>S[m]) and (S[t]<=S[k]) then k:=t;
    cs:=S;
    Sch:=cs[m];
    cs[m]:=cs[k];
    cs[k]:=Sch;
    LexNext:=Copy(cs,1,m)+StRevers(Copy(cs,m+1,len-m));
  end;
end;
 
Begin
  RS:='abcd';
  While RS<>'' do
  Begin
    Writeln(RS);
    RS:=LexNext(RS);
  end;
end.

{ генерация перестановок }
uses crt;
const n = 4; { количество элементов в перестановке}
var a:array[1..n] of integer;
    j:integer;{счетчик}
    kol : longint;{количество перестановок}
procedure generate (l,r:integer;var k:longint);
var i,v:integer;
begin
if (l=r) then
  begin
    for i:=1 to n do write(a[i],' ');
    writeln;
    k:=k+1;
  end
else
  begin
    for i := l to r do
      begin
        v:=a[l]; a[l]:=a[i]; a[i]:=v; {обмен a[i],a[l]}
        generate(l+1,r,k); {вызов новой генерации}
        v:=a[l]; a[l]:=a[i]; a[i]:=v; {обмен a[i],a[l]}
      end;
  end;
end;
begin
clrscr;
for j := 1 to N do
A[j]:=j;
generate( 1,n,kol);
writeln('kol=',kol);
readln
end.

type mas=array[1..10] of integer;
procedure generate (var a:mas;n,l,r:integer;var k:longint);
var i,v:integer;
begin
if (l=r) then
  begin
    for i:=1 to n do write(a[i],' ');
    writeln;
    k:=k+1;
  end
else
  begin
    for i := l to r do
      begin
        v:=a[l]; a[l]:=a[i]; a[i]:=v; {обмен a[i],a[l]}
        generate(a,n,l+1,r,k); {вызов новой генерации}
        v:=a[l]; a[l]:=a[i]; a[i]:=v; {обмен a[i],a[l]}
      end;
  end;
end;
var n,j,kol:integer;
    a:mas;
begin
repeat
write('Введите размер массива от 2 до 10 n=');
readln(n);
until n in [2..10];
for j := 1 to N do
a[j]:=j;
generate(a,n,1,n,kol);
writeln('kol=',kol);
end.