balls.pas

本光盘是《国际大学生程序设计竞赛例题解（一）》的配套光盘

program Balls;
type
  Tball=array[1..6] of byte;
  Tnode=record
          sp:byte;	{空盒在第sp个球的前面}
          d:Tball;	{a球的位置}
          fa:word;	{父节点}
        end;
  Tblock=array[0..999] of Tnode;
var
  c:array[0..11,0..11] of word;
  n,len,n2:integer;
  p1,p2,p1l,p1h,p2l,p2h:word;
  a:array[0..12] of ^Tblock;
  check:array[1..13,0..923] of boolean;
  power:array[3..7,1..6,1..12,1..13] of word;
  testcase,casen:integer;

procedure init;
var
  i,j,k,n:integer;
begin
  fillchar(c,sizeof(c),0);
  for i:=0 to 11 do
    begin
      c[i,0]:=1;
      for j:=1 to i do c[i,j]:=c[i-1,j-1]+c[i-1,j];
    end;
  for i:=0 to 12 do new(a[i]);

  for n:=3 to 7 do
    begin
      len:=n*2-2;
      for i:=1 to n-1 do
        for j:=1 to len+i-n do
          begin
            power[n,i,j,j]:=c[len-j,n-1-i];
            for k:=j+1 to len+i-n+1 do
              power[n,i,j,k]:=power[n,i,j,k-1]+c[len-k,n-1-i];
          end;
    end;
end;

function change(var d:Tball):word;	{将球的排列转换为数值}
var
  i,g,h:integer;
  p:word;
begin
  p:=0;
  if(d[1]>1) then inc(p,power[n,1,1,d[1]-1]);
  for i:=2 to n-1 do
    begin
      g:=d[i-1]+1;
      h:=d[i]-1;
      if(h>=g) then inc(p,power[n,i,g,h]);
    end;
  change:=p;
end;

procedure read_init;
var
  i,j,k,l:integer;
  s:array[1..14] of char;
  ch:char;
begin
  readln(n);
  n2:=n*2;len:=n2-2;
  j:=-1;
  for i:=1 to n2 do
    begin
      read(s[i]);
      if(s[i]=' ')and(j<0) then j:=i;
    end;
  a[0]^[0].sp:=j;
  for i:=j to len do s[i]:=s[i+2];
  j:=0;
  for i:=1 to len do if s[i]='a' then
    begin
      inc(j);
      a[0]^[0].d[j]:=i;
    end;
  p1:=0;p2:=0;
  fillchar(check,sizeof(check),true);
end;

procedure printnode(var q:Tnode);
var
  s:array[1..14] of char;
  i:integer;
begin
  for i:=1 to n2 do s[i]:='b';
  for i:=1 to n-1 do
    if q.d[i]<q.sp then s[q.d[i]]:='a' else s[q.d[i]+2]:='a';
  s[q.sp]:=' ';s[q.sp+1]:=' ';
  for i:=1 to n2 do write(s[i]);
end;

procedure print(p:word);
var
  w:array[1..100] of word;
  i,t:integer;
begin
  t:=0;
  while p<>0 do
    begin
      inc(t);
      w[t]:=p;
      p:=a[p div 1000]^[p mod 1000].fa;
    end;
  inc(t);
  w[t]:=0;
  for i:=t downto 1 do
    begin
      write(t-i,' ');
      printnode(a[w[i] div 1000]^[w[i] mod 1000]);
      writeln;
    end;
end;

function judge:boolean;	{判断是否重复}
var
  v:word;
begin
  judge:=false;
  v:=change(a[p2l]^[p2h].d);
  if not check[a[p2l]^[p2h].sp][v] then
    begin
      dec(p2);
      p2l:=p2 div 1000;p2h:=p2 mod 1000;
    end
  else
    begin
      check[a[p2l]^[p2h].sp][v]:=false;
      if v=0 then judge:=true;
    end;
end;

procedure sort(var q:Tball);
var
  i,j:integer;
  tmp:byte;
begin
  for i:=1 to n-2 do
    for j:=i+1 to n-1 do if q[j]<q[i] then
      begin
        tmp:=q[j];q[j]:=q[i];q[i]:=tmp;
      end;
end;

procedure search;
var
  i,j,k,l,sp:integer;
  b:array[1..20] of boolean;
begin
  p2l:=0;p2h:=0;
  if judge then begin print(0);exit; end;
  while p1<=p2 do
    begin
      p1l:=p1 div 1000;p1h:=p1 mod 1000;
      sp:=a[p1l]^[p1h].sp;
      k:=n;
      for i:=1 to n-1 do if a[p1l]^[p1h].d[i]>=sp then
        begin
          k:=i;break;
        end;
      fillchar(b,sizeof(b),true);
      b[len]:=false;
      if sp>1 then b[sp-1]:=false;

      {移动的球中第1个球为a球}
      for i:=1 to n-1 do if b[a[p1l]^[p1h].d[i]] then
        begin
          b[a[p1l]^[p1h].d[i]]:=false;
          inc(p2);
          p2l:=p2 div 1000;p2h:=p2 mod 1000;
          a[p2l]^[p2h].fa:=p1;
          a[p2l]^[p2h].d:=a[p1l]^[p1h].d;
          if a[p1l]^[p1h].d[i]<sp then
            begin
              a[p2l]^[p2h].sp:=a[p1l]^[p1h].d[i];
              a[p2l]^[p2h].d[i]:=sp-2;
              j:=i+1;
              if(i+1<k)and(a[p1l]^[p1h].d[i+1]=a[p1l]^[p1h].d[i]+1)then
                begin
                  a[p2l]^[p2h].d[i+1]:=sp-1;j:=i+2;
                end;
              while j<k do begin dec(a[p2l]^[p2h].d[j],2);inc(j); end;
            end
          else
            begin
              a[p2l]^[p2h].sp:=a[p1l]^[p1h].d[i]+2;
              a[p2l]^[p2h].d[i]:=sp;
              if(i<n-1)and(a[p1l]^[p1h].d[i+1]=a[p1l]^[p1h].d[i]+1) then a[p2l]^[p2h].d[i+1]:=sp+1;
              for j:=k to i-1 do inc(a[p2l]^[p2h].d[j],2);
            end;
          sort(a[p2l]^[p2h].d);
          if judge then begin print(p2);exit; end;
        end;

      {移动的球中第1个球为b球}
      j:=1;
      for i:=1 to len do if b[i] then
        begin
          while(j<n)and(a[p1l]^[p1h].d[j]<i) do inc(j);
          inc(p2);
          p2l:=p2 div 1000;p2h:=p2 mod 1000;
          a[p2l]^[p2h].fa:=p1;
          a[p2l]^[p2h].d:=a[p1l]^[p1h].d;
          if i<sp then
            begin
              a[p2l]^[p2h].sp:=i;
              if(j<n)and(a[p1l]^[p1h].d[j]=i+1)then
                begin
                  a[p2l]^[p2h].d[j]:=sp-1;
                  l:=j+1;
                end
              else l:=j;
              while l<k do begin dec(a[p2l]^[p2h].d[l],2);inc(l); end;
            end
          else
            begin
              a[p2l]^[p2h].sp:=i+2;
              if(j<n)and(a[p1l]^[p1h].d[j]=i+1)then a[p2l]^[p2h].d[j]:=sp+1;
              for l:=k to j-1 do inc(a[p2l]^[p2h].d[l],2);
            end;
          sort(a[p2l]^[p2h].d);
          if judge then begin print(p2);exit; end;
        end;
       inc(p1);
    end;
  writeln('NO SOLUTION');
end;

begin
  assign(input,'balls.in');reset(input);
  assign(output,'balls.out');rewrite(output);
  init;
  readln(testcase);
  for casen:=1 to testcase do
    begin
      if casen>1 then writeln;
      read_init;
      search;
    end;
  close(input);close(output);
end.