vijos-p1158 2008.11.6

vijos-p1158 2008.11.6

描述Description  

小三的三分球总是很准的，但对于数学问题就完全没有想法了，他希望你来帮他解决下面的这个问题：对于给定的n，从1!、2!、3!、……、n!中至少删去几个数，才可以使剩下的数的乘积为完全平方数？

输入格式 Input Format 

仅一行，包含一个整数n(1≤n≤500)。 

输出格式 Output Format 

第一行包含一个整数k，表示最少需要删去的数字个数。

接下来一行，从小到大排列的k个[1,n]之间的整数，给出删数的方案。如果方案不止一种，输出方案从小到大排序序列最小的一组即可。

样例输入 Sample Input  

5

样例输出 Sample Output  

2

25

 

 

1.刚开始的错误程序：

program p_1158;
const maxn=500;

var a:array[1..500]of longint;
      b:array[1..500]of longint;
      f:array[1..500]of boolean;
      i,j,n,lb,p:longint;
      flag:boolean;
      f1:text;
procedure init;
var i:longint;
begin
         read(n);p:=1;
         for i:=1 to n do
             a[i]:=n+1-i;
         flag:=false;
         fillchar(f,sizeof(f),true);
end;
procedure change(u:longint);
var r,t:longint;
begin  p:=p*u;t:=p;
   for r:=2 to trunc(sqrt(t)) do
      if (p mod(r*r)=0) then p:=p div (r*r);
end;  {错在这里，当p的值因为p:=p div (r*r)在减小时，却要去mod 可能会比自己大的trunc(sqrt(t)) ，
这样就导致了错误}
function find:boolean;
var i:longint;
begin p:=1;
     for i:=2 to n do
              if a[i] mod 2<>0 then
                 change(i);
     if p<>1 then exit(false) else exit(true);

end;
procedure print(mm:longint);
var i:longint;
begin
      if find then
       begin
          writeln(mm);
          for i:=1 to mm-1 do
          write(b[i],' ');
          write(b[mm]);
          flag:=true;
       end;
end;
procedure deal(k,m,e:longint);
var i,j:longint;
begin
     if (k>m) then print(m)
       else
          for i:=e to n do
             if f[i] then begin
                          f[i]:=false;for j:=2 to i do dec(a[j]);b[k]:=i;deal(k+1,m,i+1);
                          f[i]:=true;for j:=2 to i do inc(a[j]);
                          end;
 end;

procedure doit;
var m:longint;
begin
   m:=0;
   repeat inc(m);
     deal(1,m,2);
   until flag;
end;
begin init;doit;end.

2.过五组，超时五组

program p_1158;
const maxn=500;

var a:array[1..500]of longint;
      b:array[1..500]of longint;
      f:array[1..500]of boolean;
      z:array[1..500]of longint;
      i,j,n,lb,p:longint;
      flag:boolean;
      f1:text;
procedure init;
var i:longint;
begin
         read(n);p:=1;
         for i:=1 to n do
             a[i]:=n+1-i;
         flag:=false;
         fillchar(f,sizeof(f),true);
end;
procedure change(u:longint);
var r,t:longint;
begin
   for r:=2 to trunc(sqrt(u)) do
       while (u mod r=0)do begin inc(z[r]);u:=u div r;end;
   inc(z[u]);
end;
function find:boolean;
var i:longint;
begin p:=1;
     fillchar(z,sizeof(z),0);
     for i:=2 to n do
              if a[i] mod 2<>0 then
                 change(i);
     repeat inc(p) until (z[p] mod 2=1)or(p=n);
     if (z[p] mod 2=1) then find:=false else find:=true;
end;
procedure print(mm:longint);
var i:longint;
begin
      if find then
       begin
          writeln(mm);
          for i:=1 to mm-1 do
          write(b[i],' ');
          write(b[mm]);
          flag:=true;
       end;
end;
procedure deal(k,m,e:longint);
var i,j:longint;
begin
if not(flag)then
     if (k>m) then begin print(m);end
       else
          for i:=e to n do
             if f[i] then begin
                          f[i]:=false;for j:=2 to i do dec(a[j]);b[k]:=i;deal(k+1,m,i+1);
                          f[i]:=true;for j:=2 to i do inc(a[j]);
                          end;
 end;

procedure doit;
var m:longint;
begin
   m:=0;
   repeat inc(m);
     deal(1,m,2);
   until flag;
end;
begin init;doit;end.