Перестановки (3 уровень)

Условие:
Даны n чисел в произвольном порядке. Вывести на экран всевозможные их перестановки.

Решение: (by Antrax <antrax@mail.nnov.ru>)
{Реккурсивный алгоритм перестановок...}
program Perest;
type m=array[1..200] of integer;
var
  a,b:m;
  i,n:integer;
procedure ChangePrint;
var
  i:integer;
begin
  for i:=1 to n do write(b[a[i]]:3);
  writeln
end;
procedure swap(var x,y:integer);
var
  k:integer;
begin
  k:=x;
  x:=y;
  y:=k
end;
procedure Change(n:integer);
var
  i:integer;
begin
  if n=1 then ChangePrint
  else
  begin
    change(n-1);
    for i:=1 to n-1 do
    begin
      swap(a[n],a[i]);
      Change(n-1);
      swap(a[n],a[i])
    end
  end
end;

begin
  write('Введите количество чисел:');
  readln(n);
  write('Введите числа:');
  for i:=1 to n do read(b[i]);
  for i:=1 to n do a[i]:=i;
  writeln('Перестановки:');
  Change(n);
  readln
end.

*********************
{Итеративный аглоритм перебора}
program change;
  const nmax=100;
var
  a,b:array[1..nmax] of integer;
  i,n:integer;
procedure Perest;
var
  i:integer;
  r,l,q,p:integer;
begin
  for i:=1 to n do
  a[i]:=i;
  for i:=1 to n do
  write(b[a[i]]:3);
  writeln;
  repeat
    l:=n-1;
    while (l>=1) and (a[l]>a[l+1]) do
    dec(l);
    if l>0 then
    begin
      p:=l+1;
      q:=n;
      while p<q do
      begin
        r:=a[q];
        a[q]:=a[p];
        a[p]:=r;
        inc(p);
        dec(q)
      end;
      for i:=l+1 to n do
      if a[l]<a[i] then
      begin
        r:=a[l];
        a[l]:=a[i];
        a[i]:=r;
        break
      end;
      for i:=1 to n do
      write(b[a[i]]:3);
    end;
    writeln;
  until l=0;
end;

begin
  write('Введите количество чисел:');
  readln(n);
  write('Введите числа:');
  for i:=1 to n do read(b[i]);
  readln;
  for i:=1 to n do a[i]:=i;
  perest;
  readln;
end.