写的很好的题解：http://www.cnblogs.com/zhj5chengfeng/archive/2013/08/23/3278557.html
我这种蒻蒻什么都不会啊……
代码：（copy的）
1 var 2 a:array[1..10000]of longint; 3 su,p:array[1..1000]of longint; 4 b:array[1..10000]of boolean; 5 ans:array[1..10000]of longint; 6 i,j,m,n,s,k,w,sum,c:longint; 7 procedure add(t,d:longint); 8 var 9 i:longint; 10 begin 11 for i:=1 to s do 12 while t mod su[i]=0 do 13 begin 14 inc(p[i],d); 15 t:=t div su[i]; 16 end; 17 end; 18 procedure cheng(t:longint); 19 var 20 i:longint; 21 begin 22 for i:=1 to c do 23 ans[i]:=ans[i]*t; 24 for i:=1 to c-1 do 25 begin 26 inc(ans[i+1],ans[i] div 10); 27 ans[i]:=ans[i] mod 10; 28 end; 29 while ans[c]>=10 do 30 begin 31 ans[c+1]:=ans[c] div 10; 32 ans[c]:=ans[c] mod 10; 33 inc(c); 34 end; 35 end; 36 begin 37 readln(n); 38 for i:=1 to n do 39 read(a[i]); 40 fillchar(b,sizeof(b),true); 41 for i:=2 to n do 42 if b[i] then 43 begin 44 inc(s); 45 su[s]:=i; 46 for j:=1 to n div i do 47 b[i*j]:=false; 48 end; 49 fillchar(p,sizeof(p),0); 50 sum:=n-2; 51 k:=n; 52 for i:=1 to n do 53 if a[i]<>-1 then 54 begin 55 for j:=1 to a[i]-1 do 56 begin 57 add(sum,1); 58 dec(sum); 59 add(j,-1); 60 end; 61 dec(k); 62 end; 63 c:=1; 64 fillchar(ans,sizeof(ans),0); 65 ans[1]:=1; 66 for i:=1 to s do 67 for j:=1 to p[i] do 68 cheng(su[i]); 69 for i:=1 to sum do 70 cheng(k); 71 for i:=c downto 1 do 72 write(ans[i]); 73 end.
尼玛，总是出现莫名的bug ，浪费我的时间！
1 var i,j,sum,tot,n:longint; 2 a,b,p,d:array[0..100000] of longint; 3 flag:boolean; 4 procedure init; 5 begin 6 readln(n);sum:=0;tot:=0; 7 for i:=1 to n do 8 begin 9 readln(d[i]); 10 if (d[i]=0) or (d[i]>n-1) then flag:=true; 11 if d[i]<>-1 then begin inc(tot);inc(sum,d[i]-1);end; 12 end; 13 end; 14 procedure incc(x:longint); 15 var i:longint; 16 begin 17 for i:=2 to x do 18 begin 19 if x mod i=0 then 20 while x mod i=0 do 21 begin 22 inc(p[i]); 23 x:=x div i; 24 if x=1 then break; 25 end; 26 end; 27 end; 28 procedure decc(x:longint); 29 var i:longint; 30 begin 31 for i:=2 to x do 32 begin 33 if x mod i=0 then 34 while x mod i=0 do 35 begin 36 dec(p[i]); 37 x:=x div i; 38 if x=1 then break; 39 end; 40 end; 41 end; 42 procedure mul(x:longint); 43 var i:longint; 44 begin 45 for i:=1 to b[0]+1 do 46 begin 47 b[i]:=b[i]*x; 48 inc(b[i+1],b[i] div 10000); 49 b[i]:=b[i] mod 10000; 50 end; 51 while b[b[0]+1]<>0 do inc(b[0]); 52 end; 53 procedure main; 54 begin 55 fillchar(p,sizeof(p),0); 56 for i:=n-2-sum+1 to n-2 do incc(i); 57 for i:=1 to n-2-sum do incc(n-tot); 58 for i:=1 to n do 59 if d[i]<>-1 then 60 begin 61 for j:=2 to d[i]-1 do decc(j); 62 end; 63 b[0]:=1;b[1]:=1; 64 for i:=2 to n do if p[i]<>0 then for j:=1 to p[i] do mul(i); 65 end; 66 procedure print; 67 begin 68 write(b[b[0]]); 69 for i:=b[0]-1 downto 1 do 70 begin 71 if b[i]>=1000 then write(b[i]) else 72 if b[i]>=100 then write('0',b[i]) else 73 if b[i]>=10 then write('00',b[i]) else 74 write('000',b[i]); 75 end; 76 end; 77 begin 78 assign(input,'input.txt');assign(output,'output.txt'); 79 reset(input);rewrite(output); 80 flag:=false; 81 init; 82 if flag then writeln(0) else begin main;print;end; 83 close(input);close(output); 84 end.