魔术球问题 2011-12-29

算法实现题8-4 魔术球问题（习题 8-14）
´问题描述：
假设有n根柱子，现要按下述规则在这n根柱子中依次放入编号为 1，2，3，¼的球。
（1）每次只能在某根柱子的最上面放球。
（2）在同一根柱子中，任何2个相邻球的编号之和为完全平方数。
试设计一个算法，计算出在n根柱子上最多能放多少个球。例如，在4 根柱子上最多可
放11个球。
´编程任务：
对于给定的n，计算在 n根柱子上最多能放多少个球。
´数据输入：
由文件input.txt提供输入数据。文件第1 行有 1个正整数n，表示柱子数。
´结果输出:
程序运行结束时，将 n 根柱子上最多能放的球数以及相应的放置方案输出到文件
output.txt中。文件的第一行是球数。接下来的n行，每行是一根柱子上的球的编号。

输入文件示例
input.txt
4 

 

输出文件示例
output.txt
11
1 8 
2 7 9 
3 6 10 
4 5 11 
  

 

————————————————————

将每个点 i拆成 xi和yi两个点

对于i,j 有i+j为完全平方数，且j>i 则建边 ｛xi,yj}

｛s,xi},{yi,t} 权值均为1。

依次枚举答案，通过网络最大流判断是否可行。

 

————————————————————

Program Stone;
var n,le,flow,m,s,t:longint;
    head,vh,dis,cur,pre,last:array[-1..5000]of longint;
    next,date,point:array[-50000..50000]of longint;
 procedure add(x,y:longint);
  begin
     inc(le);
     date[le]:=1;
     point[le]:=y;
     next[le]:=head[x];
     head[x]:=le;
     point[-le]:=x;
     next[-le]:=head[y];
     head[y]:=-le;
  end;
 function min(a,b:longint):longint;
  begin
    if a<b then min:=a else min:=b;
  end;
 function aug(x,nf:longint):longint;
 var i,j,l,d,minh,ins:longint;
  begin
    if x=t then exit(nf);
    l:=nf;
    i:=cur[x];
    while i<>0 do
     begin
       if (date[i]>0)and(dis[point[i]]+1=dis[x]) then
          begin
              cur[x]:=i;
              d:=aug(point[i],min(l,date[i]));
              if (d>0)and(x mod 2<>0) then begin
                                                      last[x]:=point[i];
                                                      pre[point[i]]:=x;
                                                   end;
              dec(date[i],d);
              inc(date[-i],d);
              dec(l,d);
              if (dis[s]=m*2+2)or(l=0) then exit(nf-l);
          end;
       i:=next[i];
     end;
    if l=nf then
     begin
        minh:=m*2+2;
        i:=head[x];
        while i<>0 do
         begin
           if (date[i]>0)and(dis[point[i]]<minh) then begin minh:=dis[point[i]];ins:=i;end;
           i:=next[i];
         end;
        cur[x]:=ins;
        dec(vh[dis[x]]);
        if vh[dis[x]]=0 then dis[s]:=m*2+2;
        dis[x]:=minh+1;
        inc(vh[dis[x]]);
     end;
    aug:=nf-l;
  end;
 procedure print;
 var i,j,k:longint;
  begin
    writeln(m-1);
    for i:=1 to m-1 do
     if pre[i*2]=0 then
      begin
        j:=i*2-1;
        while true do
         begin
           write((j+1)div 2,' ');
           if last[j]=0 then break;
           j:=last[j]-1;
         end;
        writeln;
      end;
    close(input);close(output);
    halt;
  end;
 procedure main;
 var i,j,k:longint;
  begin
    s:=0;t:=-1;m:=0;
    while true do
     begin
       inc(m);
       add(s,m*2-1);add(m*2,t);
       for i:=1 to m-1 do
        if sqr(trunc(sqrt(i+m)))=i+m then add(2*i-1,2*m);
       fillchar(vh,sizeof(vh),0);
       fillchar(dis,sizeof(dis),0);
       vh[0]:=m*2+2;
       for i:=-1 to m*2 do cur[i]:=head[i];
       while dis[s]<m*2+2 do inc(flow,aug(s,maxint));
       if m-flow>n then print;
     end;

  end;

Begin
 assign(input,'prog84.in');assign(output,'prog84.out');
 reset(input);rewrite(output);
   readln(n);
   main;
end.