用一个递归可以很快解决的。
TYPE arr = ARRAY[1..30] OF INTEGER;
VAR
   a: arr; n: INTEGER; total: INTEGER;
PROCEDURE pri;
VAR
   i: INTEGER;
BEGIN
   FOR i:=1 TO n DO BEGIN
       WRITE(a[i],' ');
   END;
   total := total + 1;
   WRITELN;
END;
PROCEDURE p(i: INTEGER);
VAR
   j, k: INTEGER; f: BOOLEAN;
BEGIN
    FOR j:=1 TO n DO BEGIN
        a[i] := j;
        f := TRUE;
        FOR k:=1 TO i - 1 DO BEGIN
            IF a[k] = a[i] THEN f := FALSE;
        END;
        IF f THEN BEGIN
           IF i < n THEN p(i + 1) ELSE pri;
        END;
        a[i] := 0;
    END;
END;
BEGIN
    READLN(n);
    p(1);
    WRITELN;
    WRITE(total);
    READLN;
END.

呵呵，你继续回贴我就再给分哦！！
我这叫“少量多次”。


问你：这个程序是不是效率低了点？

效率怎么低了？

求全排列递归可是最快的方法，没有比这效率还高的了。

就是效率低，这个程序的易读性也是最高的。

有些人主张用回朔解这类题，其实我觉得回朔的程序易读性差（没有注释根本读不懂），所以我往往在无可奈何的情况下再用回朔。

我解释一下我的程序：
我一次递归实际上是求一个元素的值。我先从1-N中给它一个值，然后判断是不是和以前的值有重复的，若没有表示此取值成功，继续取下一个值；若有，则取下一个可能的值，如果所有元素的值都已确定，则输出。

呵呵，你还真行，那效率高的回溯你会吗？发来吧！！[em8]

(不知是否是回溯)(其实递归就是回溯的一种)
我的程序:
program quanpailie;
var n,total:longint;
    answer:array [1..10000] of integer;
procedure print;
var i,j:integer;
    can:boolean;
begin
  can:=true;
  for i:=1 to n-1 do
    for j:=i+1 to n do
      if answer[i]=answer[j] then can:=false;
  if can then
  begin
    for i:=1 to n do
      write(answer[i]);
    writeln;
    total:=total+1;
  end;
end;
procedure init(p:integer);
var i:integer;
begin
  if p>n then exit;
  for i:=1 to n do
    if answer[p]=0 then
    begin
      answer[p]:=i;
      if p=n then print;
      init(p+1);
      answer[p]:=0;
    end;
end;
begin
  readln(n);
  total:=0;
  fillchar(answer,sizeof(answer),0);
  init(1);
  writeln(total);
end.

看看……

如何??
缺点:如果输入的n大于9那就有毛病了:会有"123456789１０"这种东东的吗??
so,题目暗含条件:0<n<=9,且n为整数.
好象输入9的话会超时一点,虽然结果对(用数学方法算的,屏幕输出实在太快了,数得眼花缭乱),但输出时间足有一分钟!!!!!!
真晕~~

嗬嗬，说实话，matodied的程序是打印费1分钟，你的程序是先算10秒钟，再打印1分钟……谢谢

你要的用回朔做全排列的问题我终于做出来了，给我打分。
TYPE arr = ARRAY[1..30] OF INTEGER;
VAR
  a: arr;
  p, n, i, j, k, s: INTEGER;
  f: BOOLEAN;
BEGIN
    READLN(n);
    FOR i:=1 TO n DO a[i] := i;
    REPEAT
         s := s + 1; WRITE(s,' : ');
         FOR i:=1 TO n DO WRITE(a[i],' ');
         WRITELN;
         i := n;
         REPEAT
              IF i = 0 THEN HALT;
              f := TRUE; a[i] := a[i] + 1;
              IF a[i] > n THEN BEGIN
                 f := FALSE; a[i] := 1; i := i - 1;
              END;
              IF f THEN BEGIN
                 FOR j:=1 TO n - 1 DO BEGIN
                     FOR k:=j + 1 TO n DO BEGIN
                         IF a[j] = a[k] THEN BEGIN
                            f := FALSE; i := n;
                         END;
                     END;
                 END;
              END;
         UNTIL f;
    UNTIL p <> 0
END.