gear.pas

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

program Gear;

const maxn=30;
      ipf='gear.dat';                         {输入数据文件名}
      opf='gear.out';                         {输出数据文件名}

type arraytype=array[1..maxn] of integer;
     settype=set of byte;

var f:text;
    n,m,startgear,minmove:integer;
    a:array[1..maxn,1..maxn] of boolean;
    b:arraytype;

procedure initialize;                    {读数据，初始化}
var i,x,y:integer;
    s:string;
begin
     fillchar(a,sizeof(a),0);
     fillchar(b,sizeof(b),$FF);
     minmove:=maxint;
     assign(f,ipf); reset(f);
     readln(f,n,m);
     for i:=1 to m do begin
         readln(f,x,y);
         a[x,y]:=true; a[y,x]:=true;
     end;
     readln(f,startgear,s);
     while s[1]=' ' do delete(s,1,1);
     b[startgear]:=ord(s[1]='O');
     close(f);
end;

function num(s:settype):integer;         {计算集合 s 中的元素个数}
var k,i:integer;
begin
     k:=0;
     for i:=0 to n do
         if i in s then inc(k);
     num:=k;
end;

procedure try(x:integer; s:settype);     {尝试去掉某些阻塞的齿轮}
var d,e,p:arraytype;
    v:set of byte;
    open,closed,k,i,k1,k2:integer;
    notry:boolean;
begin
     if x>=minmove then exit;
     fillchar(d,sizeof(d),$FF);
     fillchar(e,sizeof(e),0);
     fillchar(p,sizeof(p),0);
     d[startgear]:=b[startgear];
     e[1]:=startgear;
     open:=1; closed:=0; notry:=true;
     repeat                            {广度优先找圈}
           inc(closed);
           k:=e[closed];
           for i:=1 to n do
               if (i in s) and a[i,k] then begin
                  if (d[i]<>-1) and (d[i]<>1-d[k]) then begin
                     v:=[];
                     k1:=k; k2:=i;
                     while k1<>k2 do begin
                           v:=v+[k1]+[k2];
                           k1:=p[k1]; k2:=p[k2];
                     end;
                     v:=v+[k1]-[startgear];
                     for k:=1 to n do
                         if k in v then try(x+1,s-[k]);  {去掉 k, 再尝试}
                     exit;
                  end else begin
                      if d[i]=-1 then begin
                         inc(open);
                         d[i]:=1-d[k];
                         e[open]:=i;
                         p[i]:=k;
                      end;
                  end;
               end;
     until closed>=open;
     k:=0;
     for i:=1 to n do inc(k,ord(d[i]=-1));
     if k<minmove then begin
        minmove:=k;
        b:=d;
     end;
end;

procedure done;                                 {输出结果到数据文件}
var block:boolean;
    i:integer;
begin
     assign(f,opf); rewrite(f);
     block:=false;
     for i:=1 to n do
         if b[i]=-1 then block:=true;
     if block then writeln(f,'B')
              else writeln(f,'W');
     write(f,'C ');
     for i:=1 to n do
         if b[i]=0 then write(f,i,' ');
     writeln(f);
     write(f,'O ');
     for i:=1 to n do
         if b[i]=1 then write(f,i,' ');
     writeln(f);
     if block then begin
        write(f,'R ');
        for i:=1 to n do
            if b[i]=-1 then write(f,i,' ');
        writeln(f);
     end;
     close(f);
end;

begin                                           {主程序}
     initialize;
     try(0,[1..n]);
     done;
end.